pax_global_header00006660000000000000000000000064116463607700014524gustar00rootroot0000000000000052 comment=51b0a027b1e29efb046d40f4962095fdbb3d2fe8 clfswm-20111015.git51b0a02/000077500000000000000000000000001164636077000147305ustar00rootroot00000000000000clfswm-20111015.git51b0a02/.gitignore000066400000000000000000000005011164636077000167140ustar00rootroot00000000000000# git-ls-files --others --exclude-from=.git/info/exclude # Lines that start with '#' are comments. # For a project mostly in C, the following would be a good set of # exclude patterns (uncomment them if you want to use them): *.fas *.fasl *.lib *.orig *.patch *.diff *~ # Personal scripts: 1disp-load.lisp git-commit.sh clfswm-20111015.git51b0a02/AUTHORS000066400000000000000000000010611164636077000157760ustar00rootroot00000000000000CLFSWM - A(nother) Common Lisp FullScreen Window Manager --------------------------------------------------------- Philippe Brochard pbrochard at common-lisp dot net test Contributors ------------ Xavier Maillard xma at gnu dot org Cyrille THOUVENIN Desmond O. Chang Sylvain HENRY ----------------------------------- Some of the CLFSWM code is based on tinywm: http://incise.org/index.cgi/TinyWM And on the excellent Shawn Betts (sabetts at vcn bc ca) Stumpwm: http://www.nongnu.org/stumpwm/ clfswm-20111015.git51b0a02/COPYING000066400000000000000000001045131164636077000157670ustar00rootroot00000000000000 GNU GENERAL PUBLIC LICENSE Version 3, 29 June 2007 Copyright (C) 2007 Free Software Foundation, Inc. Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The GNU General Public License is a free, copyleft license for software and other kinds of works. The licenses for most software and other practical works are designed to take away your freedom to share and change the works. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change all versions of a program--to make sure it remains free software for all its users. We, the Free Software Foundation, use the GNU General Public License for most of our software; it applies also to any other work released this way by its authors. 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 them 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 prevent others from denying you these rights or asking you to surrender the rights. Therefore, you have certain responsibilities if you distribute copies of the software, or if you modify it: responsibilities to respect the freedom of others. For example, if you distribute copies of such a program, whether gratis or for a fee, you must pass on to the recipients the same freedoms that you received. 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. Developers that use the GNU GPL protect your rights with two steps: (1) assert copyright on the software, and (2) offer you this License giving you legal permission to copy, distribute and/or modify it. For the developers' and authors' protection, the GPL clearly explains that there is no warranty for this free software. For both users' and authors' sake, the GPL requires that modified versions be marked as changed, so that their problems will not be attributed erroneously to authors of previous versions. Some devices are designed to deny users access to install or run modified versions of the software inside them, although the manufacturer can do so. This is fundamentally incompatible with the aim of protecting users' freedom to change the software. The systematic pattern of such abuse occurs in the area of products for individuals to use, which is precisely where it is most unacceptable. Therefore, we have designed this version of the GPL to prohibit the practice for those products. If such problems arise substantially in other domains, we stand ready to extend this provision to those domains in future versions of the GPL, as needed to protect the freedom of users. Finally, every program is threatened constantly by software patents. States should not allow patents to restrict development and use of software on general-purpose computers, but in those that do, we wish to avoid the special danger that patents applied to a free program could make it effectively proprietary. To prevent this, the GPL assures that patents cannot be used to render the program non-free. The precise terms and conditions for copying, distribution and modification follow. TERMS AND CONDITIONS 0. Definitions. "This License" refers to version 3 of the GNU General Public License. "Copyright" also means copyright-like laws that apply to other kinds of works, such as semiconductor masks. "The Program" refers to any copyrightable work licensed under this License. Each licensee is addressed as "you". "Licensees" and "recipients" may be individuals or organizations. To "modify" a work means to copy from or adapt all or part of the work in a fashion requiring copyright permission, other than the making of an exact copy. The resulting work is called a "modified version" of the earlier work or a work "based on" the earlier work. A "covered work" means either the unmodified Program or a work based on the Program. To "propagate" a work means to do anything with it that, without permission, would make you directly or secondarily liable for infringement under applicable copyright law, except executing it on a computer or modifying a private copy. Propagation includes copying, distribution (with or without modification), making available to the public, and in some countries other activities as well. To "convey" a work means any kind of propagation that enables other parties to make or receive copies. Mere interaction with a user through a computer network, with no transfer of a copy, is not conveying. An interactive user interface displays "Appropriate Legal Notices" to the extent that it includes a convenient and prominently visible feature that (1) displays an appropriate copyright notice, and (2) tells the user that there is no warranty for the work (except to the extent that warranties are provided), that licensees may convey the work under this License, and how to view a copy of this License. If the interface presents a list of user commands or options, such as a menu, a prominent item in the list meets this criterion. 1. Source Code. The "source code" for a work means the preferred form of the work for making modifications to it. "Object code" means any non-source form of a work. A "Standard Interface" means an interface that either is an official standard defined by a recognized standards body, or, in the case of interfaces specified for a particular programming language, one that is widely used among developers working in that language. The "System Libraries" of an executable work include anything, other than the work as a whole, that (a) is included in the normal form of packaging a Major Component, but which is not part of that Major Component, and (b) serves only to enable use of the work with that Major Component, or to implement a Standard Interface for which an implementation is available to the public in source code form. A "Major Component", in this context, means a major essential component (kernel, window system, and so on) of the specific operating system (if any) on which the executable work runs, or a compiler used to produce the work, or an object code interpreter used to run it. The "Corresponding Source" for a work in object code form means all the source code needed to generate, install, and (for an executable work) run the object code and to modify the work, including scripts to control those activities. However, it does not include the work's System Libraries, or general-purpose tools or generally available free programs which are used unmodified in performing those activities but which are not part of the work. For example, Corresponding Source includes interface definition files associated with source files for the work, and the source code for shared libraries and dynamically linked subprograms that the work is specifically designed to require, such as by intimate data communication or control flow between those subprograms and other parts of the work. The Corresponding Source need not include anything that users can regenerate automatically from other parts of the Corresponding Source. The Corresponding Source for a work in source code form is that same work. 2. Basic Permissions. All rights granted under this License are granted for the term of copyright on the Program, and are irrevocable provided the stated conditions are met. This License explicitly affirms your unlimited permission to run the unmodified Program. The output from running a covered work is covered by this License only if the output, given its content, constitutes a covered work. This License acknowledges your rights of fair use or other equivalent, as provided by copyright law. You may make, run and propagate covered works that you do not convey, without conditions so long as your license otherwise remains in force. You may convey covered works to others for the sole purpose of having them make modifications exclusively for you, or provide you with facilities for running those works, provided that you comply with the terms of this License in conveying all material for which you do not control copyright. Those thus making or running the covered works for you must do so exclusively on your behalf, under your direction and control, on terms that prohibit them from making any copies of your copyrighted material outside their relationship with you. Conveying under any other circumstances is permitted solely under the conditions stated below. Sublicensing is not allowed; section 10 makes it unnecessary. 3. Protecting Users' Legal Rights From Anti-Circumvention Law. No covered work shall be deemed part of an effective technological measure under any applicable law fulfilling obligations under article 11 of the WIPO copyright treaty adopted on 20 December 1996, or similar laws prohibiting or restricting circumvention of such measures. When you convey a covered work, you waive any legal power to forbid circumvention of technological measures to the extent such circumvention is effected by exercising rights under this License with respect to the covered work, and you disclaim any intention to limit operation or modification of the work as a means of enforcing, against the work's users, your or third parties' legal rights to forbid circumvention of technological measures. 4. Conveying Verbatim Copies. You may convey 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; keep intact all notices stating that this License and any non-permissive terms added in accord with section 7 apply to the code; keep intact all notices of the absence of any warranty; and give all recipients a copy of this License along with the Program. You may charge any price or no price for each copy that you convey, and you may offer support or warranty protection for a fee. 5. Conveying Modified Source Versions. You may convey a work based on the Program, or the modifications to produce it from the Program, in the form of source code under the terms of section 4, provided that you also meet all of these conditions: a) The work must carry prominent notices stating that you modified it, and giving a relevant date. b) The work must carry prominent notices stating that it is released under this License and any conditions added under section 7. This requirement modifies the requirement in section 4 to "keep intact all notices". c) You must license the entire work, as a whole, under this License to anyone who comes into possession of a copy. This License will therefore apply, along with any applicable section 7 additional terms, to the whole of the work, and all its parts, regardless of how they are packaged. This License gives no permission to license the work in any other way, but it does not invalidate such permission if you have separately received it. d) If the work has interactive user interfaces, each must display Appropriate Legal Notices; however, if the Program has interactive interfaces that do not display Appropriate Legal Notices, your work need not make them do so. A compilation of a covered work with other separate and independent works, which are not by their nature extensions of the covered work, and which are not combined with it such as to form a larger program, in or on a volume of a storage or distribution medium, is called an "aggregate" if the compilation and its resulting copyright are not used to limit the access or legal rights of the compilation's users beyond what the individual works permit. Inclusion of a covered work in an aggregate does not cause this License to apply to the other parts of the aggregate. 6. Conveying Non-Source Forms. You may convey a covered work in object code form under the terms of sections 4 and 5, provided that you also convey the machine-readable Corresponding Source under the terms of this License, in one of these ways: a) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by the Corresponding Source fixed on a durable physical medium customarily used for software interchange. b) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by a written offer, valid for at least three years and valid for as long as you offer spare parts or customer support for that product model, to give anyone who possesses the object code either (1) a copy of the Corresponding Source for all the software in the product that is covered by this License, on a durable physical medium customarily used for software interchange, for a price no more than your reasonable cost of physically performing this conveying of source, or (2) access to copy the Corresponding Source from a network server at no charge. c) Convey individual copies of the object code with a copy of the written offer to provide the Corresponding Source. This alternative is allowed only occasionally and noncommercially, and only if you received the object code with such an offer, in accord with subsection 6b. d) Convey the object code by offering access from a designated place (gratis or for a charge), and offer equivalent access to the Corresponding Source in the same way through the same place at no further charge. You need not require recipients to copy the Corresponding Source along with the object code. If the place to copy the object code is a network server, the Corresponding Source may be on a different server (operated by you or a third party) that supports equivalent copying facilities, provided you maintain clear directions next to the object code saying where to find the Corresponding Source. Regardless of what server hosts the Corresponding Source, you remain obligated to ensure that it is available for as long as needed to satisfy these requirements. e) Convey the object code using peer-to-peer transmission, provided you inform other peers where the object code and Corresponding Source of the work are being offered to the general public at no charge under subsection 6d. A separable portion of the object code, whose source code is excluded from the Corresponding Source as a System Library, need not be included in conveying the object code work. A "User Product" is either (1) a "consumer product", which means any tangible personal property which is normally used for personal, family, or household purposes, or (2) anything designed or sold for incorporation into a dwelling. In determining whether a product is a consumer product, doubtful cases shall be resolved in favor of coverage. For a particular product received by a particular user, "normally used" refers to a typical or common use of that class of product, regardless of the status of the particular user or of the way in which the particular user actually uses, or expects or is expected to use, the product. A product is a consumer product regardless of whether the product has substantial commercial, industrial or non-consumer uses, unless such uses represent the only significant mode of use of the product. "Installation Information" for a User Product means any methods, procedures, authorization keys, or other information required to install and execute modified versions of a covered work in that User Product from a modified version of its Corresponding Source. The information must suffice to ensure that the continued functioning of the modified object code is in no case prevented or interfered with solely because modification has been made. If you convey an object code work under this section in, or with, or specifically for use in, a User Product, and the conveying occurs as part of a transaction in which the right of possession and use of the User Product is transferred to the recipient in perpetuity or for a fixed term (regardless of how the transaction is characterized), the Corresponding Source conveyed under this section must be accompanied by the Installation Information. But this requirement does not apply if neither you nor any third party retains the ability to install modified object code on the User Product (for example, the work has been installed in ROM). The requirement to provide Installation Information does not include a requirement to continue to provide support service, warranty, or updates for a work that has been modified or installed by the recipient, or for the User Product in which it has been modified or installed. Access to a network may be denied when the modification itself materially and adversely affects the operation of the network or violates the rules and protocols for communication across the network. Corresponding Source conveyed, and Installation Information provided, in accord with this section must be in a format that is publicly documented (and with an implementation available to the public in source code form), and must require no special password or key for unpacking, reading or copying. 7. Additional Terms. "Additional permissions" are terms that supplement the terms of this License by making exceptions from one or more of its conditions. Additional permissions that are applicable to the entire Program shall be treated as though they were included in this License, to the extent that they are valid under applicable law. If additional permissions apply only to part of the Program, that part may be used separately under those permissions, but the entire Program remains governed by this License without regard to the additional permissions. When you convey a copy of a covered work, you may at your option remove any additional permissions from that copy, or from any part of it. (Additional permissions may be written to require their own removal in certain cases when you modify the work.) You may place additional permissions on material, added by you to a covered work, for which you have or can give appropriate copyright permission. Notwithstanding any other provision of this License, for material you add to a covered work, you may (if authorized by the copyright holders of that material) supplement the terms of this License with terms: a) Disclaiming warranty or limiting liability differently from the terms of sections 15 and 16 of this License; or b) Requiring preservation of specified reasonable legal notices or author attributions in that material or in the Appropriate Legal Notices displayed by works containing it; or c) Prohibiting misrepresentation of the origin of that material, or requiring that modified versions of such material be marked in reasonable ways as different from the original version; or d) Limiting the use for publicity purposes of names of licensors or authors of the material; or e) Declining to grant rights under trademark law for use of some trade names, trademarks, or service marks; or f) Requiring indemnification of licensors and authors of that material by anyone who conveys the material (or modified versions of it) with contractual assumptions of liability to the recipient, for any liability that these contractual assumptions directly impose on those licensors and authors. All other non-permissive additional terms are considered "further restrictions" within the meaning of section 10. If the Program as you received it, or any part of it, contains a notice stating that it is governed by this License along with a term that is a further restriction, you may remove that term. If a license document contains a further restriction but permits relicensing or conveying under this License, you may add to a covered work material governed by the terms of that license document, provided that the further restriction does not survive such relicensing or conveying. If you add terms to a covered work in accord with this section, you must place, in the relevant source files, a statement of the additional terms that apply to those files, or a notice indicating where to find the applicable terms. Additional terms, permissive or non-permissive, may be stated in the form of a separately written license, or stated as exceptions; the above requirements apply either way. 8. Termination. You may not propagate or modify a covered work except as expressly provided under this License. Any attempt otherwise to propagate or modify it is void, and will automatically terminate your rights under this License (including any patent licenses granted under the third paragraph of section 11). However, if you cease all violation of this License, then your license from a particular copyright holder is reinstated (a) provisionally, unless and until the copyright holder explicitly and finally terminates your license, and (b) permanently, if the copyright holder fails to notify you of the violation by some reasonable means prior to 60 days after the cessation. Moreover, your license from a particular copyright holder is reinstated permanently if the copyright holder notifies you of the violation by some reasonable means, this is the first time you have received notice of violation of this License (for any work) from that copyright holder, and you cure the violation prior to 30 days after your receipt of the notice. Termination of your rights under this section does not terminate the licenses of parties who have received copies or rights from you under this License. If your rights have been terminated and not permanently reinstated, you do not qualify to receive new licenses for the same material under section 10. 9. Acceptance Not Required for Having Copies. You are not required to accept this License in order to receive or run a copy of the Program. Ancillary propagation of a covered work occurring solely as a consequence of using peer-to-peer transmission to receive a copy likewise does not require acceptance. However, nothing other than this License grants you permission to propagate or modify any covered work. These actions infringe copyright if you do not accept this License. Therefore, by modifying or propagating a covered work, you indicate your acceptance of this License to do so. 10. Automatic Licensing of Downstream Recipients. Each time you convey a covered work, the recipient automatically receives a license from the original licensors, to run, modify and propagate that work, subject to this License. You are not responsible for enforcing compliance by third parties with this License. An "entity transaction" is a transaction transferring control of an organization, or substantially all assets of one, or subdividing an organization, or merging organizations. If propagation of a covered work results from an entity transaction, each party to that transaction who receives a copy of the work also receives whatever licenses to the work the party's predecessor in interest had or could give under the previous paragraph, plus a right to possession of the Corresponding Source of the work from the predecessor in interest, if the predecessor has it or can get it with reasonable efforts. You may not impose any further restrictions on the exercise of the rights granted or affirmed under this License. For example, you may not impose a license fee, royalty, or other charge for exercise of rights granted under this License, and you may not initiate litigation (including a cross-claim or counterclaim in a lawsuit) alleging that any patent claim is infringed by making, using, selling, offering for sale, or importing the Program or any portion of it. 11. Patents. A "contributor" is a copyright holder who authorizes use under this License of the Program or a work on which the Program is based. The work thus licensed is called the contributor's "contributor version". A contributor's "essential patent claims" are all patent claims owned or controlled by the contributor, whether already acquired or hereafter acquired, that would be infringed by some manner, permitted by this License, of making, using, or selling its contributor version, but do not include claims that would be infringed only as a consequence of further modification of the contributor version. For purposes of this definition, "control" includes the right to grant patent sublicenses in a manner consistent with the requirements of this License. Each contributor grants you a non-exclusive, worldwide, royalty-free patent license under the contributor's essential patent claims, to make, use, sell, offer for sale, import and otherwise run, modify and propagate the contents of its contributor version. In the following three paragraphs, a "patent license" is any express agreement or commitment, however denominated, not to enforce a patent (such as an express permission to practice a patent or covenant not to sue for patent infringement). To "grant" such a patent license to a party means to make such an agreement or commitment not to enforce a patent against the party. If you convey a covered work, knowingly relying on a patent license, and the Corresponding Source of the work is not available for anyone to copy, free of charge and under the terms of this License, through a publicly available network server or other readily accessible means, then you must either (1) cause the Corresponding Source to be so available, or (2) arrange to deprive yourself of the benefit of the patent license for this particular work, or (3) arrange, in a manner consistent with the requirements of this License, to extend the patent license to downstream recipients. "Knowingly relying" means you have actual knowledge that, but for the patent license, your conveying the covered work in a country, or your recipient's use of the covered work in a country, would infringe one or more identifiable patents in that country that you have reason to believe are valid. If, pursuant to or in connection with a single transaction or arrangement, you convey, or propagate by procuring conveyance of, a covered work, and grant a patent license to some of the parties receiving the covered work authorizing them to use, propagate, modify or convey a specific copy of the covered work, then the patent license you grant is automatically extended to all recipients of the covered work and works based on it. A patent license is "discriminatory" if it does not include within the scope of its coverage, prohibits the exercise of, or is conditioned on the non-exercise of one or more of the rights that are specifically granted under this License. You may not convey a covered work if you are a party to an arrangement with a third party that is in the business of distributing software, under which you make payment to the third party based on the extent of your activity of conveying the work, and under which the third party grants, to any of the parties who would receive the covered work from you, a discriminatory patent license (a) in connection with copies of the covered work conveyed by you (or copies made from those copies), or (b) primarily for and in connection with specific products or compilations that contain the covered work, unless you entered into that arrangement, or that patent license was granted, prior to 28 March 2007. Nothing in this License shall be construed as excluding or limiting any implied license or other defenses to infringement that may otherwise be available to you under applicable patent law. 12. No Surrender of Others' Freedom. If 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 convey a covered work so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not convey it at all. For example, if you agree to terms that obligate you to collect a royalty for further conveying from those to whom you convey the Program, the only way you could satisfy both those terms and this License would be to refrain entirely from conveying the Program. 13. Use with the GNU Affero General Public License. Notwithstanding any other provision of this License, you have permission to link or combine any covered work with a work licensed under version 3 of the GNU Affero General Public License into a single combined work, and to convey the resulting work. The terms of this License will continue to apply to the part which is the covered work, but the special requirements of the GNU Affero General Public License, section 13, concerning interaction through a network will apply to the combination as such. 14. Revised Versions of this License. The Free Software Foundation may publish revised and/or new versions of the GNU 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 that a certain numbered version of the GNU General Public License "or any later version" applies to it, you have the option of following the terms and conditions either of that numbered version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the GNU General Public License, you may choose any version ever published by the Free Software Foundation. If the Program specifies that a proxy can decide which future versions of the GNU General Public License can be used, that proxy's public statement of acceptance of a version permanently authorizes you to choose that version for the Program. Later license versions may give you additional or different permissions. However, no additional obligations are imposed on any author or copyright holder as a result of your choosing to follow a later version. 15. Disclaimer of Warranty. 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. 16. Limitation of Liability. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS 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. 17. Interpretation of Sections 15 and 16. If the disclaimer of warranty and limitation of liability provided above cannot be given local legal effect according to their terms, reviewing courts shall apply local law that most closely approximates an absolute waiver of all civil liability in connection with the Program, unless a warranty or assumption of liability accompanies a copy of the Program in return for a fee. 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 state 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 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 . Also add information on how to contact you by electronic and paper mail. If the program does terminal interaction, make it output a short notice like this when it starts in an interactive mode: Copyright (C) This program 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, your program's commands might be different; for a GUI interface, you would use an "about box". You should also get your employer (if you work as a programmer) or school, if any, to sign a "copyright disclaimer" for the program, if necessary. For more information on this, and how to apply and follow the GNU GPL, see . The GNU General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Lesser General Public License instead of this License. But first, please read . clfswm-20111015.git51b0a02/ChangeLog000066400000000000000000002262111164636077000165060ustar00rootroot000000000000002011-10-15 Philippe Brochard * src/clfswm-internal.lisp (place-window-from-hints): Use with-placement macro to place unmanaged windows in an arbitrary place. 2011-06-16 Philippe Brochard * src/clfswm-internal.lisp (clean-windows-in-all-frames): Prevent current root and current child being equal to child. 2011-06-13 Philippe Brochard * src/keysyms.lisp: Repeat Page_Down/Up keysym definitions at the end of the file to change keysyms priority. 2011-06-13 Sylvain HENRY * *.*: Minor spelling fix. 2011-06-12 Philippe Brochard * src/clfswm.lisp (:unmap-notify, :destroy-notify): Show all children just after the xlib tree cleanup -> reduce the flickering when a window is deleted or destroyed. * src/clfswm-internal.lisp (process-existing-windows): Do not process the notify window. 2011-06-08 Philippe Brochard * *: **** Release 1106 **** 2011-06-08 Philippe Brochard * src/clfswm-internal.lisp (clean-windows-in-all-frames): New function to prevent xlib error when a window is deleted. 2011-06-08 Philippe Brochard * src/clfswm-internal.lisp (delete-child-and-children-in-all-frames): Delete or destroy children before displaying all children. 2011-06-05 Philippe Brochard * src/clfswm-util.lisp (add-frame-in-parent-frame): New function and binding. 2011-06-04 Philippe Brochard * src/clfswm.lisp (main-unprotected): Destroy all frames windows before closing the display (not really needed). 2011-06-02 Philippe Brochard * src/clfswm-layout.lisp (inc-tile-layout-size) (dec-tile-layout-size, inc-slow-tile-layout-size) (dec-slow-tile-layout-size): New functions and bindings. 2011-06-01 Philippe Brochard * src/clfswm-expose-mode.lisp (define-expose-letter-keys): Add 0..1 and A..Z keys to select a child in exposé mode. * src/clfswm-internal.lisp (display-frame-info): Remove hidden infos in frames windows. * src/clfswm-util.lisp (ask-close/kill-current-window): Menu update. 2011-05-30 Philippe Brochard * src/clfswm-internal.lisp (get-parent-layout): Minor fullscreen size tweaking. 2011-05-29 Philippe Brochard * src/clfswm-internal.lisp (delete-child-and-children-in-all-frames): Show all children before deleting/destroying a windows, so prevent a flickering. (get-parent-layout): Return the fullscreen size when the current root is a window. 2011-05-28 Philippe Brochard * src/clfswm-internal.lisp (get-parent-layout): Handle correctly unmanaged windows. * src/clfswm-util.lisp (delete-focus-window-generic): Do not hide child before removing, so prevent a flickering. * src/clfswm-internal.lisp (show-all-children): Rectangular optimization to display only needed children. (show-all-children): Remove flickering on select-next/previous-brother. 2011-05-17 Philippe Brochard * src/clfswm-util.lisp (copy-focus-window, cut-focus-window): New functions and ask-close/kill-current-window menu and bindings entry. 2011-05-16 Philippe Brochard * src/clfswm-util.lisp (ask-close/kill-current-window): Add an *ask-close/kill-placement* placement window variable. 2011-05-09 Philippe Brochard * contrib/osd.lisp (funcall-button-from-code): Display osd documention for buttons and fix some redefining warnings. 2011-05-07 Philippe Brochard * src/clfswm-nw-hooks.lisp (make-permanent-nw-hook-frame): New function. Prevent to add or delete a new window hook for this frame. * src/clfswm-layout.lisp (update-layout-managed-children-position): New function. 2011-05-06 Philippe Brochard * src/bindings-second-mode.lisp (set-default-second-keys): select-brother-spatial-move-* binding update. * src/clfswm-layout.lisp (tile-left|right|top|bottom-layout): Ask to keep children positions or not. * src/clfswm-internal.lisp (fixe-real-size): Takes care of border size. * src/clfswm-layout.lisp (update-layout-managed-children): Fix a bug by using the parent frame instead of the current child. * src/clfswm-circulate-mode.lisp (select-brother-generic-spatial-move+right/left/up/down): New function to select a brother from another in a spatial move. 2011-04-19 Philippe Brochard * src/clfswm-pack.lisp (move-frame-constrained) (resize-frame-constrained): Use pixels instead of floating measure. 2011-04-18 Philippe Brochard * src/clfswm-pack.lisp (resize-frame-constrained): Takes care of border size. (implode-frame, implode-current-frame): New functions. Absorb all frames subchildren in frame. Explode frame opposite. 2011-04-17 Philippe Brochard * src/clfswm-pack.lisp (move-frame-constrained) (resize-frame-constrained): New function. Move and resize frame with the mouse constrained by other frame brothers. 2011-04-14 Philippe Brochard * src/clfswm-util.lisp (with-movement-select-next-brother) (with-movement-select-previous-brother) (with-movement-select-next-child): Use a simple method (do not enter in the circulate mode) to allow to circulate in all children or brothers. * src/clfswm-menu.lisp (open-menu): Save info hash table keys instead of deleting newly created keys. 2011-03-21 Philippe Brochard * src/clfswm-internal.lisp (x-px->fl, y-px->fl): Takes care of border size. 2011-03-20 Philippe Brochard * src/clfswm-info.lisp (show-config-variable): call produce-conf-var-doc. 2011-03-18 Philippe Brochard * src/clfswm-autodoc.lisp (produce-conf-var-doc-html): Produce a documentation for all configurable variables in CLFSWM - HTML version. * src/clfswm-internal.lisp (leave-frame): Hide all children except the current window. 2011-03-16 Philippe Brochard * src/clfswm-autodoc.lisp (produce-all-docs): Produce a documentation for all configurable variables in CLFSWM. * src/clfswm-layout.lisp (set-gimp-layout): Display a notify window with the help on the GIMP layout. 2011-03-12 Philippe Brochard * src/menu-def.lisp: Menu update to prevent cursor keys clash. * clfswm.asd: Change compilation order to prevent undefined variables. * src/clfswm-internal.lisp (show-child(frame)): Handle properly the show-root-frame-p parameter. 2011-03-11 Philippe Brochard * src/clfswm-util.lisp (move-frame, resize-frame): Do not move or resize a frame when it's the current root. 2011-03-10 Philippe Brochard * src/clfswm-internal.lisp (show-all-children): Handle properly duplicated child in multipe frames. 2011-03-09 Philippe Brochard * contrib/volume-mode.lisp (set-default-volume-keys): Add more keybindings (up/down, right/left) to raise/lower the volume. * src/clfswm-layout.lisp: Add a variable border size for frames and windows. 2011-03-08 Philippe Brochard * src/clfswm-util.lisp (cut-current-child, remove-current-child) (delete-current-child): Hide the current child before doing the action. * src/clfswm-internal.lisp (show-all-children): Hide windows not in the current root before displaying those in current root. Remove all hide-all unnecessary calls. * src/clfswm-configuration.lisp (save-variables-in-conf-file): Save only variables with a different value than their original value. 2011-03-07 Philippe Brochard * src/clfswm-info.lisp (show-config-variable): Use the new defconfig method. * src/clfswm-autodoc.lisp (produce-configuration-variables): Use the new defconfig method. * src/clfswm-configuration.lisp (create-configuration-menu): Change the config system with a more lispy one and a less string based one: (defconfig name value group doc). 2011-03-06 Philippe Brochard * src/clfswm-internal.lisp (show-all-children): Simplify the selection method. (show-child): Display an unmanaged window whe it's the current child. (show-all-children): add the ability to display all child from *root-frame* and hide all those who are not in *current-root*. -> remove hide-all-children when needed. * src/xlib-util.lisp (move-window,resize-window): Add a *color-move-window* border when moving or resizing a window. 2011-03-04 Philippe Brochard * src/clfswm-internal.lisp (show-all-children): Perform only one recusion on the clfswm tree: calculate geometry and place child in one pass. 2011-03-03 Philippe Brochard * src/clfswm-internal.lisp (show-all-children): Rethink of display child order to prevent very annoying flickering. 2011-02-27 Philippe Brochard * src/clfswm-util.lisp (query-yes-or-no): New function. * src/clfswm-configuration.lisp (reset-all-config-variables): New function and menu entry. (query-conf-value): Add the ability to leave the field blank to reset the variable to its default value. 2011-02-26 Philippe Brochard * src/clfswm-configuration.lisp (add-all-configuration-default-value): Add a default value to configurable variables. 2011-02-23 Philippe Brochard * src/clfswm.lisp (main-unprotected): Create the configuration menu only once at startup. 2011-02-22 Desmond O. Chang * contrib/amixer.lisp: Add a volume mode inspired by the emms volume package. Alsa mixer interface. * contrib/volume-mode.lisp: Add a volume mode inspired by the emms volume package. 2011-02-22 Desmond O. Chang * src/clfswm.lisp (main): Use ASDF:SYSTEM-SOURCE-DIRECTORY instead of *LOAD-TRUENAME*. *LOAD-TRUENAME* is only bound during a call to LOAD. If one eval CLFSWM:MAIN in repl, BASE-DIR will be an empty string. Use ASDF:SYSTEM-SOURCE-DIRECTORY to fix it. 2011-02-16 Philippe Brochard * src/clfswm.lisp (main-unprotected): Add a close hook. And close the notify window, the virtual keyboard and the clfswm terminal by default. 2011-02-15 Philippe Brochard * src/clfswm.lisp (main-unprotected): Destroy the notify window before closing the display. This fix a bug when resetting/reloading clfswm. 2011-02-12 Philippe Brochard * src/xlib-util.lisp (equal-wm-class-fun, equal-wm-name-fun) (raise-window-fun, raise-and-focus-window-fun): New functions. * src/config.lisp (*clfswm-terminal-cmd*): Switch from xterm to urxvt. (*never-managed-window-list*): Structure change to be more flexible. Let the choice to focus, raise and do nothing on never managed windows. 2011-02-09 Philippe Brochard * src/clfswm-util.lisp (mouse-focus-move/resize-generic): Take care of never managed windows to move or resize them if the raise parameter is true. * src/clfswm-internal.lisp (in-frame, in-window, in-child): New functions. 2011-02-08 Philippe Brochard * src/clfswm.lisp (main-mode): Raise or not unmanaged windows following request in *never-managed-window-list*. 2011-02-05 Philippe Brochard * *: **** Release 1102 **** 2011-02-05 Desmond O. Chang * src/keysyms.lisp: Add extended keysyms from stumpwm. 2011-02-01 Desmond O. Chang * src/clfswm-util.lisp (run-or-raise): New function (thanks to Desmond O. Chang). * src/clfswm-internal.lisp (with-all-*): add a nil block. 2011-01-28 Desmond O. Chang * src/clfswm-util.lisp (xdg-config-home): XDG_CONFIG_HOME should be $HOME/.config by default. 2010-12-29 Philippe Brochard * contrib/osd.lisp (display-doc): Add another method where a CLFSWM native window is used to display the key documentation. 2010-12-27 Philippe Brochard * src/xlib-util.lisp (with-xlib-protect): Force to revert to the main mode state. 2010-12-25 Philippe Brochard * src/clfswm-second-mode.lisp (second-key-mode): Call the second mode leave function only when the generic mode was ended. 2010-12-08 Philippe Brochard * src/clfswm-second-mode.lisp (sm-leave-function): Do not use *second-mode-program* anymore. 2010-12-07 Philippe Brochard * src/clfswm-second-mode.lisp (*second-mode-leave-function*): New variable bound to a function executed (when not null) on second mode leaving. 2010-11-14 Philippe Brochard * src/clfswm-util.lisp (find-child-under-mouse): Do not find hidden windows. 2010-11-13 Philippe Brochard * src/clfswm-expose-mode.lisp (expose-mode-display-accel-windows): Do not display the accel window for unmanaged windows. 2010-11-11 Philippe Brochard * src/clfswm-internal.lisp (set-current-root): Handle window-parent in set-current-root. * src/clfswm-util.lisp (mouse-click-to-focus-generic): Do not focus the parent child when the current root is a window. 2010-11-09 Philippe Brochard * src/clfswm-expose-mode.lisp (expose-windows-current-child-mode): New function an bindings. * src/clfswm-layout.lisp (tile-layout, set-tile-layout): Fill blanks if needed. 2010-11-07 Philippe Brochard * src/clfswm-layout.lisp (tile-layout-ask-keep-position): New function to let the user choose to keep child position with tile layout. * src/clfswm-internal.lisp (remove-frame-data-slot): New function. 2010-11-05 Philippe Brochard * src/clfswm-internal.lisp (frame-select-next-child) (frame-select-previous-child): New functions and bindings. Select the next/previous child in the current frame. 2010-10-31 Philippe Brochard * src/clfswm-query.lisp (query-mode-complet): New function: Handle completion in query-mode. 2010-10-30 Philippe Brochard * src/clfswm-query.lisp (query-print-string): Handle long lines correctly. 2010-10-27 Philippe Brochard * src/clfswm-expose-mode.lisp (expose-create-window): Ensure that all characters are printable. 2010-10-25 Philippe Brochard * contrib/server/server.lisp: Load clfswm client code in the main program and let the user start it with a --client command line option. * src/package.lisp (*main-entrance-hook*): New hook executed after loading configuration file and before opening the display. 2010-10-23 Philippe Brochard * src/xlib-util.lisp: Remove unnecessary xlib:display-finish-output. * src/clfswm-internal.lisp (show-child): Show window only if not hidden. * src/clfswm-keys.lisp (binding-substitute-modifier): Utility to change modifiers after binding definition. 2010-10-21 Philippe Brochard * contrib/osd.lisp: New file: OSD (On Screen Display) for presentations. * src/clfswm-menu.lisp (open-menu): Modularise function. 2010-10-13 Philippe Brochard * src/clfswm-info.lisp (show-first-aid-kit): Display the essential key binding in main and second mode. 2010-10-10 Philippe Brochard * src/clfswm-util.lisp (open-notify-window): Convert hello-window functions to a more generic Notify-window system. * src/tools.lisp (add-timer): Add an id to identify the timer. 2010-10-09 Philippe Brochard * src/tools.lisp (erase-timer): New function. * src/clfswm-util.lisp (display-hello-window): Add a timer to hide the hello window. Add Configuration variables. 2010-10-08 Philippe Brochard * src/clfswm-util.lisp (): Add an Hello window at startup. * src/tools.lisp (process-timers): Add a timer system. 2010-10-07 Philippe Brochard * src/clfswm-query.lisp (add-in-query-string): Handle correctly the mod-5 modifier. 2010-10-06 Philippe Brochard * src/clfswm-query.lisp (query-print-string): Change cursor color and show parenthesis matching with colors (on match and on errors). 2010-10-05 Philippe Brochard * src/clfswm-internal.lisp (show-all-children): Do not raise a child when its parent is hidden. 2010-10-02 Philippe Brochard * src/clfswm-circulate-mode.lisp (select-next-subchild): Add the possibility to circulate over subchild of the current child. * src/clfswm-expose-mode.lisp (expose-all-windows-mode) (expose-windows-generic): Add an escape-body function to return to the original state on escape key. * src/clfswm-util.lisp (bind-on-slot): Add an optional parameter to bind the current child from the configuration file. 2010-10-01 Philippe Brochard * src/clfswm-nw-hooks.lisp (absorb-window-nw-hook): Absorb new window hook: the frame absorb all new windows that match nw-absorb-test frame data slot. 2010-09-30 Philippe Brochard * src/clfswm-expose-mode.lisp (expose-create-window): Show window title in accel window. 2010-09-29 Philippe Brochard * configure: Use the Xavier Maillard clfswm script in contrib to build an executable in the standard way. 2010-09-26 Philippe Brochard * src/clfswm-expose-mode.lisp (expose-mode-display-accel-windows): New functions. Add a window on each child in the expose mode to quickly select them. * src/clfswm-internal.lisp (child-x, child-y, child-width) (child-height): New methods to get real child coordinates. 2010-09-25 Philippe Brochard * src/clfswm-layout.lisp (*-layout): Use child-position. * src/clfswm-internal.lisp (child-position): New function. * src/clfswm-expose-mode.lisp (expose-windows-mode) (expose-all-windows-mode): Use a generic mode. * src/xlib-util.lisp (with-handle-event-symbol): Use a filled list with handle-event-fun symbols instead of inspecting clfswm internals symbols on each mode change. * src/clfswm-expose-mode.lisp: Move and rename present*-windows in a separate clfswm-expose-mode.lisp file. * src/clfswm-util.lisp (speed-mouse-right, speed-mouse-down): Use screen size instead of hardcoded test coordinates. 2010-09-24 Philippe Brochard * src/clfswm-util.lisp (speed-mouse-reset, speed-mouse-left) (speed-mouse-right, speed-mouse-up, speed-mouse-down) (speed-mouse-undo, speed-mouse-first-history): New functions to quickly move the mouse. Implemented for the second mode. 2010-09-16 Philippe Brochard * contrib/clfswm: Move clfswm sources to $tmp_dir if there is no write permission on $clfswm_asd_path. So anybody can start clfswm even if there is no write permission on the source directory. 2010-09-12 Philippe Brochard * contrib/clfswm: Add support to cmucl, ccl and ecl. 2010-09-11 Philippe Brochard * src/clfswm-util.lisp (set-hide-unmanaged-window) (set-show-unmanaged-window, set-default-hide-unmanaged-window): New functions and menu entry. (set-globally-hide-unmanaged-window) (set-globally-show-unmanaged-window): New functions and menu entry. * src/clfswm-internal.lisp (hide-unmanager-window-p): New function. (show-child): Add a data slot on frame to hide or not unmanaged windows. * src/clfswm-corner.lisp (present-clfswm-terminal) (present-virtual-keyboard): Use a function (generic-present-body) instead of a macro (generate-present-body). * src/clfswm-util.lisp (update-menus): List all directories and subdirectories in $XDG_DATA_DIRS/applications. 2010-09-10 Philippe Brochard * src/clfswm-corner.lisp (generate-present-body): New macro. (present-clfswm-terminal, present-virtual-keyboard): Use generate-present-body. 2010-09-09 Philippe Brochard * src/clfswm-util.lisp (update-menus): Follow XDG specifications instead of the non-portable Debian update-menu. 2010-09-07 Philippe Brochard * src/clfswm.lisp (error-handler): New function do handle asynchronous errors and ignore them. (open-display): Install the new error-handler on display. 2010-09-05 Philippe Brochard * src/xlib-util.lisp (with-xlib-protect): Add a with-simple-restart on top of body execution. 2010-09-04 Philippe Brochard * src/clfswm.lisp (main-loop): Protect all xlib functions with an with-xlib-protect. * src/xlib-util.lisp (handle-event): use with-xlib-protect only in handle-event. Add a with-simple-restart to prevent a clisp/new-lisp infinite loop. 2010-08-30 Philippe Brochard * src/clfswm-corner.lisp (present-clfswm-terminal): Make the clfswm terminal working even on xterm title changes. 2010-08-29 Philippe Brochard * src/clfswm-util.lisp (run-other-window-manager): Update for clisp compatibility. * src/tools.lisp (do-execute): New parameter io to change the input/output method. * src/clfswm-util.lisp (hide-current-child): Prevent from removing the current root. * src/clfswm-internal.lisp (child-member): New predicate. (child-remove): New function. * src/*.lisp: Use child-member and child-remove everywhere it's needed. 2010-08-28 Philippe Brochard * src/clfswm.lisp (main-loop): Ensure that all events have been processed after a process-event. * src/clfswm-internal.lisp (is-in-current-child-p): New function. 2010-08-27 Philippe Brochard * src/clfswm.lisp (main-mode:configure-request): Raise the window only when present on the current child and focus it accordingly. 2010-08-26 Philippe Brochard * src/clfswm-circulate-mode.lisp (circulate-loop-function): Use is-a-key-pressed-p. * src/xlib-util.lisp (is-a-key-pressed-p): New predicate. * src/clfswm-keys.lisp (define-ungrab/grab): Use all values returned by xlib:keysym->keycodes. * src/*.lisp: Use the new child-equal-p to compare children. This prevent a bug with sbcl/cmucl when the standard equal function does not work with xlib:window. * src/clfswm-internal.lisp (child-equal-p): New predicate. 2010-08-25 Philippe Brochard * src/clfswm-generic-mode.lisp (generic-mode): Use an xlib:event-listen before processing event with xlib:process-event. This prevent a bug with CLX threaded implementation like sbcl. * src/clfswm.lisp (main-loop): Use an xlib:event-listen before processing event with xlib:process-event. This prevent a bug with CLX threaded implementation like sbcl. 2010-08-17 Philippe Brochard * contrib/server/key.lisp (ushell-sh): Add ccl and ecl support. * src/xlib-util.lisp (compress-motion-notify): Use a loop instead of an event-case. * src/clfswm-internal.lisp (with-find-in-all-frames): New macro. (find-parent-frame, find-frame-window, find-frame-by-name) (find-frame-by-number): Use with-find-in-all-frames to search in frames in the right order. * src/clfswm-util.lisp (mouse-click-to-focus-generic): Fix an unwanted flickering with unmanaged windows. 2010-08-16 Philippe Brochard * src/package.lisp: Remove event handler hooks as they're not needed anymore (To replace them: use closure and define-handler). * src/xlib-util.lisp (move-window, resize-window) (wait-mouse-button-release): Use a generic mode. * src/*.lisp: Replace the case to handle event with a more (tricky) lispy method which bind a function to each keywords associated to graphics events. 2010-07-23 Philippe Brochard * src/clfswm-util.lisp (delete-current-child): Invert bindings and menu entry between delete-current-child and remove-current-child. ie: Delete a child and its children in all frames by default. 2010-07-21 Philippe Brochard * src/package.lisp: Add a placement configuration group. * src/binding*.lisp: Bind control+g to escape the current action like emacs. * src/clfswm-internal.lisp (delete-child-and-children-in-all-frames): New function and binding: Second mode - Control+Delete delete the current child and its children in all frames (ie: close the current child and its children). 2010-07-20 Philippe Brochard * src/clfswm-internal.lisp (remove-child-in-frame): Do not destroy the frame window and the frame gc. Close a very annoying bug when cuting/pasting a frame or moving a child over frames with the mouse. * src/clfswm-util.lisp (mouse-click-to-focus-generic): Redisplay all children in *current-root* after moving/resizing a frame. 2010-07-18 Philippe Brochard * src/clfswm-util.lisp (delete-focus-window) (destroy-focus-window): Remove child in parent frame before stopping it. 2010-07-16 Philippe Brochard * src/clfswm-util.lisp (identify-key): Add a timeout in xlib:process-event. (mouse-click-to-focus-generic): Use find-child-under-mouse instead of the window passed by xlib:process-event. * src/xlib-util.lisp (move-window, resize-window) (wait-mouse-button-release): Add a timeout in xlib:process-event. 2010-04-11 Philippe Brochard * src/clfswm-util.lisp (run-other-window-manager): Add the ability to launch an other window manager and to return to clfswm. 2010-03-18 Philippe Brochard * src/clfswm-layout.lisp (set-tile-space-layout): Set default to 1%. 2009-12-15 Philippe Brochard * src/clfswm.lisp (main-loop): Add a *loop-hook* parameter and a loop timeout. * src/clfswm-generic-mode.lisp (generic-mode): Add a loop-hook parameter and a loop timeout. 2009-12-05 Philippe Brochard * src/clfswm.lisp (main): Add an alternate configuration filename parameter. * load.lisp: Add a debuging code example. 2009-11-14 Philippe Brochard * src/clfswm-configuration.lisp (create-configuration-menu): New menu to configure all clfswm variables while clfswm is running. 2009-11-12 Philippe Brochard * src/clfswm-util.lisp (save-configuration-variables): New function to save all configuration variables in clfswmrc. 2009-11-11 Philippe Brochard * src/clfswm-info.lisp (info-mode): Begining of mouse support in info mode. (set-default-info-keys): Add cursor key support in info mode. 2009-11-08 Philippe Brochard * contrib/reboot-halt.lisp: Add a Suspend/Reboot/Halt menu in contrib. * src/clfswm.lisp (main): Add a read-conf-file-p parameter to prevent reading the configuration file (this may be useful to produce the original documentation without user modifications with the rc configuration file). 2009-11-07 Philippe Brochard * src/bindings-second-mode.lisp (set-default-second-keys): Simplification of Escape key to close/kill/remove the focus window and unhide all windows. * src/bindings.lisp (set-default-main-keys): Simplification of Escape key to close/kill/remove the focus window and unhide all windows. * src/clfswm-util.lisp (ask-close/kill-current-window): Add remove focus and unhide all windows capabilities. 2009-10-10 Philippe Brochard * contrib/mpd.lisp (start-gmpc): Add gmpc in the mpd menu. 2009-07-29 Philippe Brochard * src/clfswm-layout.lisp (tile-layout, tile-horizontal-layout): Keep child order and don't make unnecessary child movement. (one-column-layout, one-line-layout): New layouts. 2009-06-29 Philippe Brochard * *: **** Release 0906 **** * contrib/cd-player.lisp: New file to handle the CD player. * contrib/xmms.lisp: New file to handle the xmms player. 2009-06-28 Philippe Brochard * src/clfswm-layout.lisp (set-no-layout-remember-size): New layout: Maximize windows in their frame - Leave frames to their actual size. * src/bindings-second-mode.lisp (set-default-second-keys): Bind "o" on set-open-in-new-frame-in-parent-frame-nw-hook. 2009-06-27 Philippe Brochard * contrib/keyb_fr.lisp: New file to handle an azerty keyboard. 2009-06-24 Philippe Brochard * contrib/mpd.lisp: Use a standard menu. * src/clfswm-info.lisp: Use a standard menu for the help-menu. 2009-06-22 Philippe Brochard * contrib/mpd.lisp: New file to handle the Music Player Daemon (MPD) 2009-06-19 Philippe Brochard * src/clfswm-autodoc.lisp (produce-doc, produce-doc-html): Minor number key cleanup. 2009-06-18 Philippe Brochard * src/config.lisp (get-fullscreen-size): One pixel adjustment (again). * src/clfswm-placement.lisp (*-child-placement): One pixel adjustment (again). 2009-06-16 Philippe Brochard * src/clfswm-circulate-mode.lisp (draw-circulate-mode-window): Ensure that all characters are printable. * src/config.lisp (get-fullscreen-size): Adjust default fullscreen sizes. * src/clfswm-placement.lisp (*-child-placement): Adjust coordinates to one pixel in the current child. 2009-06-04 Philippe Brochard * src/clfswm-query.lisp (query-enter-function): Assign font before width and height calculation. 2009-06-03 Philippe Brochard * src/xlib-util.lisp (banish-pointer): Use with-placement macro to bannish the pointer in an arbitrary place. * src/clfswm-info.lisp (info-mode): Use with-placement macro to place the info window in an arbitrary place. * src/clfswm-query.lisp (query-enter-function): Use with-placement macro to place the query window in an arbitrary place. * src/clfswm-placement.lisp: New file. Allow to place info windows or query windows on an arbitrary place. Allow to bannish the pointer on an arbitrary place. 2009-05-16 Philippe Brochard * src/clfswm-circulate-mode.lisp (reorder-child) (reorder-brother): Unfocus windows before reordering children or brothers. 2009-05-13 Philippe Brochard * src/clfswm-circulate-mode.lisp (reorder-brother): Ensure that the parent is a frame. * src/clfswm-second-mode.lisp (sm-handle-motion-notify): Handle motion with a default modifier. * src/clfswm.lisp (handle-motion-notify): Handle motion with a default modifier. * src/clfswm-info.lisp (info-mode): Handle motion with a default modifier. (info-mode): Optimization in loop function. 2009-05-10 Philippe Brochard * src/clfswm-circulate-mode.lisp (reorder-brother): Handle root-frame correctly. * clfswm.asd: Dependency fix for clfswm-generic-mode. * src/clfswm-circulate-mode.lisp (reorder-child) (reorder-brother): Handle empty frames. (reorder-brother): Redisplay only the parent frame of the current child. * src/clfswm-util.lisp (frame-toggle-maximize): Redisplay only the parent frame of the current frame. 2009-05-09 Philippe Brochard * src/clfswm-util.lisp (frame-toggle-maximize): New function: Maximize/Unmaximize the current frame in its parent frame. * src/clfswm-layout.lisp (maximize-layout): New layout: Maximize windows and frames in their parent frame. 2009-05-05 Philippe Brochard * src/*.lisp: Add support for Clozure Common Lisp (CCL). * src/clfswm-circulate-mode.lisp (reorder-child) (reorder-brother): Reinitialise on circulate type change child to brother or brother to child. * src/*.lisp (*): Use map-window instead of xlib:map-window. So calls xlib:display-finish-output on each map-request. So speed up the window display. * src/xlib-util.lisp (map-window): New function. Call xlib:display-finish-output on each map request. 2009-04-28 Philippe Brochard * src/clfswm-second-mode.lisp (sm-handle-motion-notify): Optimisation when drawing second mode window. 2009-04-27 Philippe Brochard * src/clfswm-circulate-mode.lisp (circulate-mode): Optimisation in window redraw. 2009-04-22 Philippe Brochard * src/clfswm-util.lisp (run-program-from-query-string): Launch command only with a return validation. 2009-04-22 Xavier Maillard * src/clfswm-query.lisp (query-string): Use a generic mode. 2009-04-19 Xavier Maillard * src/clfswm-info.lisp (info-mode): Use generic-mode for info-mode. 2009-04-18 Xavier Maillard * src/clfswm-generic-mode.lisp (generic-mode): Add a generic mode to define all other modes. 2009-04-05 Philippe Brochard * src/package.lisp (): Use *default-font-string* for all font-string. * src/clfswm-info.lisp (info-mode): Ensure integer windows size. 2009-02-17 Philippe Brochard * src/xlib-util.lisp (null-size-window-p): Better check of null sized windows. 2009-02-14 Philippe Brochard * src/clfswm.lisp (handle-map-request): Add a fix to manage correctly fullscreen windows (SDL particularly). 2008-12-20 Philippe Brochard * src/xlib-util.lisp (get-color): Allocate colors only once -> fix a segfault with clisp/new-clx. * src/clfswm.lisp (handle-motion-notify): Add a needed window argument. * src/clfswm-second-mode.lisp (sm-handle-motion-notify): Add a needed window argument. 2008-10-30 Philippe Brochard * src/xlib-util.lisp (wait-no-key-or-button-press) (wait-a-key-or-button-press): Check buttons press/release correctly" 2008-10-28 Philippe Brochard * src/menu-def.lisp: Add children navigation menu in the movement menu (select next/previous child/brother/level). 2008-10-26 Philippe Brochard * *: Rename 'sister' frame to 'brother' frame. * src/clfswm-keys.lisp (unalias-modifiers): Convert a modifier alias in a real modifier. * src/package.lisp (*modifier-alias*): New list of modifier alias For example: :alt is :mod-1, :numlock is :mod-2... * src/tools.lisp (remove-hook): New function. * src/clfswm-keys.lisp (with-capslock, without-capslock) (with-numlock, without-cnumlock): New functions. 2008-10-25 Philippe Brochard * src/clfswm-info.lisp: Use the *binding-hook* to create info keys and mouse bindings. * src/bindings-second-mode.lisp: Use the *binding-hook* to create second keys and mouse bindings. * src/bindings.lisp: Use the *binding-hook* to create main keys and mouse bindings. 2008-10-10 Philippe Brochard * src/clfswm-menu.lisp (open-menu): Remember parent menu to undo menu opening. 2008-10-09 Philippe Brochard * src/menu-def.lisp: Use a menu instead of a function for the standard menu. 2008-10-08 Philippe Brochard * src/clfswm-util.lisp (show-standard-menu): Display the standard menu from the 'update-menus' command. 2008-10-07 Philippe Brochard * src/clfswm-query.lisp (query-string): Do not ungrab keyboard if it's already grabbed. * src/clfswm-internal.lisp (display-frame-info): Use configurable colors and fix a bug with background. (display-frame-info): Set window background when displaying info. 2008-10-06 Philippe Brochard * src/xlib-util.lisp (my-character->keysyms): Use a macro to avoid warning with clisp/new-clx. 2008-10-04 Philippe Brochard * src/clfswm-util.lisp (jump-to-slot): Prevent to jump on a deleted child. 2008-09-23 Philippe Brochard * *: **** Release 0809 **** 2008-09-23 Philippe Brochard * src/clfswm-util.lisp (ensure-unique-name): New function and menu entry. (ensure-unique-number): New function and menu entry. 2008-09-22 Philippe Brochard * src/clfswm-nw-hooks.lisp (named-frame-nw-hook): New new window hook: open the next window in a named frame. (numbered-frame-nw-hook): New new window hook: open the next window in a numbered frame. * src/clfswm-query.lisp (query-string): Grab the keyboard in all cases. So query-string can be called even in the main mode. * src/clfswm-internal.lisp (show-all-children): Do not raise a child by default => far less flickering. 2008-09-19 Philippe Brochard * src/bindings-second-mode.lisp: Bind "t" to tile-current-frame. * src/menu-def.lisp: Change key binding for the CLFSWM menu entry. * src/xlib-util.lisp (xgrab-pointer): Handle the case where cursor is nil. (workaround on some CLX implementation). 2008-09-12 Philippe Brochard * src/menu-def.lisp: Add a menu to set a focus policy for all frames. * src/clfswm-util.lisp (set-focus-policy-generic-for-all) (all-frames-set-*-focus-policy): Set a focus policy for all frames. * src/clfswm.lisp (handle-enter-notify): sloppy-select mode. Select a child and its parents on mouse over. 2008-09-03 Philippe Brochard * src/clfswm.lisp (handle-enter-notify): Add a sloppy strict focus policy -> Sloppy focus only for windows in the current frame. (main-unprotected): Exit clfswm on init error (ie: when another window manager is running). * src/clfswm-util.lisp (reset-clfswm): New function. 2008-09-02 Philippe Brochard * src/clfswm-menu.lisp (init-menu): New function. * src/clfswm-util.lisp (reload-clfswm): New function to reload CLFSWM. (exit-clfswm): Rename quit-clfswm to exit-clfswm. * src/clfswm.lisp (main, main-unprotected): Handle error in a superior main function. Now CLFSWM can't break the X session. It just reinitialize the display and run a new main loop. * src/clfswm-corner.lisp: Make *clfswm-terminal* and *vt-keyboard-on* global to avoid warnings when loading clfswm. * src/clfswm-layout.lisp: Add a specific GIMP layout menu. (help-on-gimp-layout): Describe how to use the GIMP layout. 2008-09-01 Philippe Brochard * src/clfswm-layout.lisp (set-gimp-layout): Change the layout to main-window-right-layout. Change the keybinding for (shift)alt+tab to not select windows in the main window lisst. Bind F8 to add a window in the main window list. Bind F9 to remove a window in the main window list. Change the focus policy to :sloppy. (set-previous-layout): Restore the previous layout, keybinding and focus policy. 2008-08-31 Philippe Brochard * src/clfswm-menu.lisp (add-menu-comment): Add comments in menu. * src/clfswm-layout.lisp (main-window-left-layout) (main-window-bottom-layout, main-window-top-layout): New functions. Factorize layouts in menu. 2008-08-30 Philippe Brochard * src/clfswm-layout.lisp (main-window-right-layout): A possible GIMP layout: one or more main windows on one side of the frame. Others on the other size. * src/clfswm-util.lisp (current-frame-set-click/sloppy-focus-policy): Each frame can have a different focus policy (one of :click or :sloppy). The default focus policy is set with *default-focus-policy*. 2008-08-23 Philippe Brochard * src/clfswm-info.lisp (show-config-variable): New function. 2008-08-19 Philippe Brochard * src/clfswm-layout.lisp (tile-horizontal-layout): New layout. * src/clfswm-info.lisp: Colored help for key binding and corners actions. 2008-08-18 Philippe Brochard * src/clfswm-util.lisp (delete-focus-window) (destroy-focus-window): Remove chid only in handle-unmap/destroy-notify. Focus *current-root* only when closing/killing the current child. * src/clfswm-autodoc.lisp (produce-corner-*-doc): New autodoc functions or corners. 2008-08-17 Philippe Brochard * src/clfswm-corner.lisp (present-clfswm-terminal): New corner action: Hide/Unhide a terminal on mouse corner action. (By default right mouse button on the top left corner). * src/config.lisp (*never-managed-window-list*): New config variable. * src/clfswm-internal.lisp (never-managed-window-p): New function: Handle never managed window in a more simple way. * src/clfswm-corner.lisp: New file and new and more simple method to define corners actions. 2008-08-15 Philippe Brochard * src/clfswm-info.lisp (info-mode): Info line can now be colored. * src/clfswm-layout.lisp (fast-layout-switch) (define-fast-layout-switch): New functions: Switch between two layouts. * src/clfswm-second-mode.lisp (leave-second-mode): Takes care if really in the second mode. So leave-second-mode can be used even in the main mode. * src/clfswm-util.lisp (switch-to-last-child): New function: Store the current child and switch to the previous one. 2008-07-16 Philippe Brochard * src/clfswm-util.lisp (display-current-window-info): Display the window id. (have-to-present-virtual-keyboard): Add a virtual keyboard corner (top right by default). By default 'xvkbd' is used. 2008-06-28 Philippe Brochard * src/xlib-util.lisp (move-window, resize-window): Compress motion events. * src/clfswm.lisp (handle-motion-notify): Compress motion events. * src/clfswm-second-mode.lisp (sm-handle-motion-notify): Compress motion events. * src/clfswm-info.lisp (info-mode): Compress motion events. 2008-06-21 Philippe Brochard * src/clfswm-internal.lisp (show-all-children): Compute geometry and selection first and then show only necessary children. (show-child): remove unneeded display-p parameter. * src/config.lisp (get-fullscreen-size): Place the frame border outside the screen (this prevent the loose of 2 pixels per directions :) 2008-06-12 Philippe Brochard * src/clfswm-internal.lisp (focus-child): Algorithm change to raise only the selected child. 2008-06-08 Philippe Brochard * src/clfswm-internal.lisp (raise-p-list, show-all-children): Raise only viewable children. 2008-06-06 Philippe Brochard * src/clfswm-internal.lisp (show-all-children): Always raise all displayed children. Remove all references to raise-p. 2008-06-04 Philippe Brochard * src/menu-def.lisp (child-menu): New menu entry on raise/lower child in its frame. * src/bindings-second-mode.lisp ("Page_Down", "Page_Up"): New second mode binding on raise/lower child in its frame. * src/clfswm-nw-hooks.lisp (leave-focus-frame-nw-hook): Adapt behaviour to the new raise/lower property. Call clear-nw-hook before the rest of the hook. * src/bindings.lisp (mouse-click-to-focus-and-move-window) (mouse-click-to-focus-and-resize-window): Stop button event. This prevent a keyboard/pointer freeze. 2008-06-03 Philippe Brochard * src/clfswm-internal.lisp (frame-lower-child) (frame-raise-child): New functions to raise/lower a child in its frame. * src/clfswm-util.lisp (have-to-present-windows) (have-to-present-all-windows): New functions to have an MaxOS expose like on mouse click in screen corner. * src/clfswm-info.lisp ("Page_Down", "Page_Up"): Add boundaries. 2008-05-30 Philippe Brochard * src/clfswm-util.lisp (unhide-a-child-from-all-frames): Unhide a child from a choice in all frames with hidden children. * src/clfswm-info.lisp (info-mode-menu): Handle separators. 2008-05-28 Philippe Brochard * src/clfswm-util.lisp (hide-current-child, unhide-a-child) (unhide-all-children): New functions. * src/clfswm-info.lisp (info-mode-menu): Handle symbols and functions. * src/clfswm-util.lisp (hide/show-frame-window): new function and menu item. 2008-05-23 Philippe Brochard * src/clfswm-util.lisp (rename-current-child): Do not display the frame info for a window. 2008-05-20 Philippe Brochard * src/clfswm-internal.lisp (remove-child-in-frame): Destroy the frame window for the removed child and its children. 2008-05-18 Philippe Brochard * src/clfswm-autodoc.lisp (produce-*-doc-*): Add a note to use the autodoc functions. 2008-05-17 Philippe Brochard * src/clfswm-nw-hooks.lisp (default-frame-nw-hook): Do not handle the ROX pinboard (ie: leave it lowered in the root window as expected). * src/clfswm-layout.lisp (tile-left-space-layout): New layout. (tile-left-layout, tile-right-layout, tile-top-layout) (tile-bottom-layout): Use all the frame space when there is only one child. * src/clfswm-internal.lisp (place-window-from-hints): Center unmanaged windows in the root screen. * src/clfswm-nw-hooks.lisp (clear-nw-hook, clear-all-nw-hooks): new functions. 2008-05-15 Philippe Brochard * src/clfswm-util.lisp (current-frame-manage-window-type): Fix a typo in managed types. * src/clfswm-internal.lisp (show-child): Always display frame info even if the frame is hidden. * src/xlib-util.lisp (resize-window): Use a better algorithme to resize windows. 2008-05-13 Philippe Brochard * src/clfswm-util.lisp (with-movement): Display frame info for all frames in current root. 2008-05-12 Philippe Brochard * src/*.lisp: Rename 'brother' frames to 'sister' frames. * src/bindings-second-mode.lisp (define-second-key #\a): New binding on 'add-default-frame'. * src/clfswm-autodoc.lisp (produce-*-doc-*-in-file): Show a message to follow the autodocumentation process. 2008-05-10 Philippe Brochard * src/clfswm-util.lisp (bind-or-jump): Bind "Tab", "Return" and "Space" to jump to a child. "B" to bind a slot on the current child. * src/bindings-second-mode.lisp: Use "Tab" instead of "Iso_Left_Tab". 2008-05-07 Philippe Brochard * src/clfswm-util.lisp (find-child-under-mouse): Take care of unmanaged (hidden) windows. * src/clfswm-internal.lisp (place-window-from-hints): Give a minimal size for windows. (with-all-windows-frames-and-parent): New function. * src/config.lisp (*default-window-width/height*): New parameters. * src/clfswm-internal.lisp (place-window-from-hints): Center windows in the screen instead of in their frame. * src/bindings-second-mode.lisp (tile-space-current-frame): New binding on C-t. * src/clfswm-layout.lisp (register-layout): Intern the once name in the right package. 2008-05-05 Philippe Brochard * doc/dot-clfswmrc: Update to follow the new clfswm way. 2008-05-03 Philippe Brochard * src/clfswm-internal.lisp (set-current-child) (adapt-child-to-parent, show-child, hide-child): Handle the case where child is not a frame or a window. * src/clfswm-util.lisp (mouse-click-to-focus-generic,mouse-focus-move/resize-generic): Check if child is a frame. * src/clfswm-internal.lisp (managed-window-p): Handle the case where frame is null. (place-frame): Check if frame and parent are frames. * src/clfswm-info.lisp (info-mode): display all frame info before leaving. * src/clfswm-second-mode.lisp (second-key-mode): display all frame info before leaving. * src/clfswm-internal.lisp (display-all-frame-info): New function. 2008-05-02 Philippe Brochard * src/tools.lisp (getenv): Implemented for ECL. (urun-prog): Implemented for ECL. * src/clfswm-util.lisp (identify-key): Use a double buffer to display text. * src/clfswm-query.lisp (query-string): Use a double buffer to display text. * src/clfswm-info.lisp (draw-info-window): Use a double buffer to display text. * src/xlib-util.lisp (clear-pixmap-buffer, copy-pixmap-buffer): New functions. 2008-05-01 Philippe Brochard * src/clfswm-info.lisp (info-mode): Add boundaries in the info mode window. * src/menu-def.lisp: New file: move all menu definition in menu-def.lisp. * src/clfswm-layout.lisp (register-layout): Use a function instead of a macro. 2008-04-30 Philippe Brochard * src/clfswm-autodoc.lisp (produce-menu-doc, (produce-menu-doc-html): New functions. (produce-doc-*): Moved to clfswm-autodoc.lisp. * src/clfswm-util.lisp (paste-selection-no-clear): Prevent to paste a child on one of its own children. (this prevent a recursive bug). (move-child-to): Rename move/copy-current-child-by to move/copy-child-to. (mouse-move-window-over-frame): New function to move the window under the mouse cursor to another frame. * src/clfswm-internal.lisp (find-child-in-parent): New function. 2008-04-29 Philippe Brochard * src/clfswm-internal.lisp (show-all-children): Display unmanaged windows only when its window parent is the current child. 2008-04-28 Philippe Brochard * src/clfswm-util.lisp (manage-current-window) (unmanage-current-window): New functions: Allow to force to manage or unmanage a window by its parent frame. * src/bindings-second-mode.lisp (#\o): binded to set-open-in-new-frame-in-parent-frame-nw-hook and (#\o :control) to set-open-in-new-frame-in-root-frame-nw-hook * src/clfswm-util.lisp (with-current-window): New macro. * src/xlib-util.lisp (move-window, resize-window): Remove uneeded exposure and enter-window handle event. * src/clfswm-util.lisp (move-frame, resize-frame): Show all children for the current child after the move/resize. 2008-04-27 Philippe Brochard * src/xlib-util.lisp (resize-window): Take care of window size hints. * src/clfswm-util.lisp (mouse-focus-move/resize-generic): Allow to move/resize unmanaged windows. * src/xlib-util.lisp (move-window, resize-window): New functions. 2008-04-25 Philippe Brochard * src/clfswm-util.lisp (current-frame-manage-window-type): Let the user choose what window type the current frame must handle. (display-current-window-info): New function. (current-frame-manage-all-window-type) (current-frame-manage-only-normal-window-type) (current-frame-manage-no-window-type): New functions. * src/clfswm-internal.lisp (managed-window-p): New function. * src/package.lisp (frame): Managed type: new frame parameter. This allow to choose what window type a frame must handle. * src/*.lisp: Rename all 'father' occurrences to 'parent'. * src/clfswm-nw-hooks.lisp (open-in-new-frame-in-parent-frame-nw-hook): New new window hook. * src/clfswm-util.lisp (adapt-current-frame-to-window-hints): New function. * src/tools.lisp (ensure-printable): Return always a string even with a null string. 2008-04-24 Philippe Brochard * src/config.lisp (*default-nw-hook*): New variable to change the default new window hook. 2008-04-22 Philippe Brochard * clfswm.asd (clfswm): Add a dependency from clfswm-second-mode.lisp to clfswm.lisp. * src/clfswm-util.lisp (identify-key): Show the documentation for the function bound on a key. (with-movement): Move with-movement, current-frame-fill/pack/resize-* from bindings-second-mode.lisp to clfswm-util.lisp. * src/clfswm-menu.lisp: New menu system that let user change keys or functions associated to keys. 2008-04-18 Philippe Brochard * src/clfswm-internal.lisp (show-all-children): Display-child is the first child by default. Solve a bug with father-p. 2008-04-17 Philippe Brochard * src/clfswm-internal.lisp (add-frame): Add frame return the created frame. (show-all-children): Move the size computation outside the show-child part. * src/bindings-second-mode.lisp (with-movement): Redisplay only the current child. * src/clfswm-util.lisp (mouse-click-to-focus-generic): Redisplay only the current child. * src/clfswm-internal.lisp (show-all-children): New display-child parameter to display only the desired child and its children. (select-next/previous-child): Only display the current child. 2008-04-14 Philippe Brochard * src/clfswm.lisp (init-display): Move the default frame creation on the default init hook. * src/clfswm-keys.lisp (define-ungrab/grab): Handle all keysyms in the main mode (for example: "1" on an azerty keyboard). 2008-04-13 Philippe Brochard * src/clfswm-keys.lisp (find-key-from-code): Better handle of keysyms. Revert to old grabbing method for the main mode. 2008-04-12 Philippe Brochard * src/clfswm.lisp (init-display): Add key handling on no focus window and on frame windows. 2008-04-11 Philippe Brochard * src/clfswm.lisp (main): Keyboard handle strategie change: Grab all keys by default and replay just what is needed. No change for the second mode. * src/clfswm-keys.lisp: remove grab/ungrab main keys. (find-key-from-code): Test for shift and not shift presence. 2008-04-09 Philippe Brochard * src/clfswm-internal.lisp (switch-to-root-frame): show later - new key parameter to have less flickering. 2008-04-07 Philippe Brochard * src/bindings-second-mode.lisp (frame-layout-once-menu): Set the layout only one time and revert to no-layout to freely handle frames. * src/clfswm-nw-hooks.lisp (open-in-new-frame-in-root-frame-nw-hook): Tile layout with spaces with new created window. * src/clfswm-layout.lisp (register-layout): Now register automatically a once layout to set the layout only one time and revert to no-layout to freely handle frames. 2008-04-05 Philippe Brochard * src/clfswm-nw-hooks.lisp (leave-focus-frame-nw-hook): New nw-hook: Open the next window in the current frame and leave the focus to the current child. 2008-04-04 Philippe Brochard * src/bindings-second-mode.lisp: Add keys definitions to bind-or-jump in the second mode. * src/clfswm-util.lisp (bind-or-jump): remove the auto-defining macro for bind-or-jump-(1|2|3...). * src/clfswm-keys.lisp (define-define-key/mouse): Allow additional arguments to function. This allow to do things like: (define-main-key (key) 'my-function 10 20 'foo) -> 10 20 and 'foo are passed to my-function on key press. 2008-04-03 Philippe Brochard * src/clfswm-util.lisp (bind-or-jump): New (great) function. 2008-04-02 Philippe Brochard * src/clfswm-internal.lisp (child-fullname): New function * src/clfswm-info.lisp (info-mode-menu): Add an explicit optional docstring in info-mode-menu. An item can be '((key function) (key function)) or with docstring '((key function "documentation 1") (key function "bla bla") (key function)) * src/tools.lisp (ensure-n-elems): New function. * src/bindings-second-mode.lisp: Bind Alt+mouse-1/3 to move or resize a frame or the window's father. * src/clfswm.lisp (init-display): Remove tile-space-layout by default on the root frame. * src/clfswm-util.lisp (move/resize-frame): Add standard event hooks handlers (map-request, configure-notify...) * src/clfswm-internal.lisp (adapt-child-to-father): Limit minimal child size to 1x1. 2008-04-01 Philippe Brochard * src/bindings.lisp: Bind Alt+mouse-1/3 to move or resize a frame or the window's father. * src/clfswm-util.lisp (mouse-click-to-focus-generic): Stop button event only if there is a geometry change. (mouse-focus-move/resize-generic): Generic function to move or resize a frame or a window father frame. 2008-04-01 Philippe Brochard * src/clfswm-internal.lisp (show-all-children): Return t if there is a geometry change. 2008-03-30 Philippe Brochard * src/bindings.lisp (Up/Down): Swap select previous/next level. * src/bindings-second-mode.lisp (Up/Down): Swap select previous/next level. * src/clfswm.lisp (init-display): Create a default frame in the root frame. * src/clfswm-internal.lisp (place-frame): Place frame from real (pixel) coordinates. (with-all-*): Reverse the child list to manage the first child last (like in show-all-children). * src/config.lisp (*create-frame-on-root*): New variable: Create a new frame on the root window only if true. * src/clfswm-util.lisp (mouse-click-to-focus-generic): Create a new frame on the root window only if *create-frame-on-root* is true. * src/bindings-second-mode.lisp (sm-mouse-click-to-focus-generic): Create a new frame on the root window. 2008-03-29 Philippe Brochard * src/bindings-second-mode.lisp (sm-mouse-click-to-focus-generic): Focus, move and resize the current child (even if it's a window). 2008-03-28 Philippe Brochard * src/clfswm-util.lisp (mouse-click-to-focus-and-move) (mouse-click-to-focus-and-resize): New functions. * src/clfswm-internal.lisp (*-fl->px): Convert float coordinates to pixel. (*-px->fl): Convert pixel coordinates to float. * src/tools.lisp (call-hook): Move call-hook to tools.lisp. 2008-03-27 Philippe Brochard * src/clfswm-layout.lisp (no-layout): Use :first-only to raise only the first child. * src/clfswm-internal.lisp (hide-all): Split hide-all-children in hide-all and hide-all-children. (raise-if-needed): New function. (show-child): Use a first-p parameter to raise windows only when they are first child. 2008-03-26 Philippe Brochard * src/clfswm-internal.lisp (select-next/previous-level): Don't use show-all-children -> less flickering. 2008-03-25 Philippe Brochard * src/clfswm-info.lisp (keys-from-list): new function. * src/*: rename 'childs' in 'children'. * src/*: rename 'group' in 'frame'. 2008-03-22 Philippe Brochard * src/clfswm-pack.lisp (explode-group/explode-current-group): new functions. 2008-03-21 Philippe Brochard * src/clfswm-pack.lisp: Pack, Fill, Resize functions. 2008-03-16 Philippe Brochard * src/clfswm-nw-hooks.lisp: Register system for new window hooks. Bind control+o to open the next window in a new group in the root group (as open in next window in a new workspace in 0801 version). 2008-03-15 Philippe Brochard * src/clfswm-util.lisp (show/hide-all-groups-info/key): Show/hide all groups info window. 2008-03-14 Philippe Brochard * bindings-second-mode.lisp ("ISO_Left_Tab"): Use ISO_Left_Tab instead of Tab for select-previous-child. 2008-03-13 Philippe Brochard * clfswm-util.lisp (force-window-in-group/force-window-center-in-group): new functions. 2008-03-11 Philippe Brochard * clfswm-util.lisp (identify-key): Display the documentation associated to keys when identifying a key. 2008-03-10 Xavier Maillard * contrib/clfswm: Complete rewrite of the script. Detect error and act accordingly. Add command line arguments to configure the script execution. User can now choose different common lisp implementation (clisp and sbcl only), choose where to store the dumped image, where to find clfswm source. 2008-03-09 Philippe Brochard * clfswm-internal.lisp (process-new-window): Beginning of new window hook: each group have a hook to tell what he wants to do with the new created window. 2008-03-08 Xavier Maillard * contrib/clfswm: New script. Dump a CLISP image of CLFSWM then call the resulting executable. * clfswm.lisp (read-conf-file): Check for the user config file in XDG_CONFIG_HOME *first*. Freedesktop.org standards should be prefered whenever possible. 2008-02-27 Philippe Brochard * clfswm-layout.lisp (*-layout): Add an optional raise-p parameter in each layout. 2008-02-26 Philippe Brochard * clfswm-util.lisp (copy/cut-current-child): Does not affect the root group. (copy/move-current-child-by-name/number): new functions (focus-group-by-name/number): new functions (delete-group-by-name/number): new functions 2008-02-24 Philippe Brochard * ************************************************************ * *: Major update - No more reference to workspaces. The main * structure is a tree of groups or application windows. * * ************************************************************ * 2008-02-07 Philippe Brochard * clfswm.lisp (read-conf-file): Read configuration in $HOME/.clfswmrc or in /etc/clfswmrc or in $XDG_CONFIG_HOME/clfswm/clfswmrc. (xdg-config-home): Return the content of $XDG-CONFIG-HOME (default to $HOME/.config/). 2008-01-18 Philippe Brochard * clfswm-internal.lisp (show-all-group): Use *root* and *root-gc* by default. 2008-01-03 Philippe Brochard * clfswm-internal.lisp (find-window-group): New function. * clfswm*: Change to make clfswm run with clisp/new-clx. 2008-01-01 Philippe Brochard * clfswm-util.lisp (query-show-paren): Add show parent matching in query string. (query-string): Bind control+k to delete end of line. * clfswm-second-mode.lisp (draw-second-mode-window): Display the action on mouse motion in second mode. * clfswm.lisp (handle-exposure): Redisplay groups on exposure event but do not clear the root window. (handle-configure-request): Adjust unmanaged window from their request. * clfswm-internal.lisp (process-new-window): Adjust new window with the specified hints (max/min/base width/height). 2007-12-31 Philippe Brochard * clfswm.lisp (handle-configure-request): Send an Configuration Notify event. This solve a bug with xterm and rxvt who takes some times to be mapped. Now there is no delay. * bindings-second-mode.lisp (define-shell): Run programs after living the second mode. 2007-12-30 Philippe Brochard * clfswm-internal.lisp (process-new-window): Do not crop transient window to group size. (adapt-window-to-group): Do not crop transient window to group size. * clfswm.lisp (handle-configure-request): Adapt just the window to its group and don't take care of the configure request. Remove the bug with the Gimp outside the group and speed up the window manipulation. (handle-exposure): Remove show-all-group on exposure event -> Speed up. 2007-12-29 Philippe Brochard * clfswm-util.lisp (circulate-group-up-copy-window) (circulate-group-down-copy-window) (circulate-workspace-up-copy-group) (circulate-workspace-down-copy-group): Prevent the copy of the same window in the same workspace. * bindings-second-mode.lisp (release-copy-selected-window) (release-copy-selected-group): Prevent the copy of the same window in the same workspace. * clfswm-pager.lisp (generic-pager-move-window-on-previous-line) (generic-pager-move-window-on-next-line): Remove the copy property. (generic-pager-move-group-on-next-workspace) (generic-pager-move-group-on-previous-workspace): Prevent the copy of the same window in the same workspace. * bindings-pager.lisp (mouse-pager-copy-selected-window-release) (mouse-pager-copy-selected-group-release): Prevent the copy of the same window in the same workspace. * tools.lisp (setf/=): new macro to set a variable only when necessary. * clfswm-internal.lisp (adapt-window-to-group): use set/= to set x, y... only when necessary. 2007-12-28 Philippe Brochard * clfswm.lisp (handle-configure-notify, *configure-notify-hook*): new function and hook: force windows to stay in its group (solve a bug with the Gimp). 2007-12-25 Philippe Brochard * bindings-second-mode.lisp (mouse-motion): use hide-group to have less flickering when moving/resizing groups. * clfswm-internal.lisp (hide-group): new function. (show-all-group): clear-all: new parameter. 2007-12-22 Philippe Brochard * clfswm-keys.lisp (define-define-key): undefine-*-multi-name: new macro. * clfswm*: Color change for the pager. Typo or better description in bindings definitions. Define bindings for a qwerty keyboard by default. dot-clfswmrc show examples to switch to an azerty keyboard. License change to GPL v3. * config.lisp: new file - group all globals variables in this file. 2007-08-26 Philippe Brochard * xlib-util.lisp (hide-window): Remove structure-notivy events when hidding a window. 2007-05-16 Philippe Brochard * package.lisp (*sm-property-notify-hook*): Readded property-notify-hook in second mode. 2007-05-15 Philippe Brochard * clfswm-keys.lisp (produce-doc-html): Better clean up for strings. 2007-05-13 Philippe Brochard * clfswm-pack.lisp (tile-current-workspace-to/right/left/top/bottom): Tile the current workspace with the current window on one side and others on the other (this emulate the larswm, dwm, wmii way). See the default configuration file to enable this mode by default. * clfswm-pager.lisp (pager-tile-current-workspace-to): idem for the pager. 2007-05-12 Philippe Brochard * clfswm-pager.lisp (pager-draw-window-in-group): Add ensure-printable to print windows name even with non-ascii characters. 2007-05-11 Philippe Brochard * clfswm-pager.lisp (pager-explode-current-group): Create a new group for each window in group. (pager-implode-current-group): Move all windows in workspace to one group and remove other groups. * clfswm-pack.lisp (explode-group): Create a new group for each window in group. (implode-group): Move all windows in workspace to one group and remove other groups. * clfswm-util.lisp (identify-key): Remove local configuration variables and made them available for configuration from package.lisp. (query-string): idem. 2007-04-29 Philippe Brochard * netwm-util.lisp: Start of NetWM compliance. Add a Netwm client list gestion. 2007-04-28 Philippe Brochard * clfswm-internal.lisp (create-group-on-request): open a new group only when the current group is not empty. * bindings-second-mode.lisp (define-second-key-#\o-control): Fix a bug with null workspace. * clfswm-pager.lisp (pager-handle-event): Add a hook system. This hooks can be changed in the user configuration file. * package.lisp: All colors and font variables are set in package.lisp and can be configured in the user configuration file. Note: If you have configured some less ugly colors (esp. for the pager) don't hesitate to let me know :) * clfswm-second-mode.lisp (sm-handle-event): Add a hook system. This hooks can be changed in the user configuration file. * clfswm.lisp (handle-event): Add a hook system. This hooks can be changed in the user configuration file (~/.clfswmrc) 2007-04-25 Philippe Brochard * clfswm-util.lisp (stop-all-pending-actions): new function: reset arrow action, open next window in new workspace/group. * bindings.lisp (stop-all-pending-actions): new binding. (open-next-window-in-new-group-once): Open the next windows in a new group (only once) or open all new windows in a new group (like others windows managers). 2007-04-22 Philippe Brochard * clfswm.lisp (read-conf-file): New function to read a lisp configuration file at startup. (focus-group-under-mouse): Check if group isn't the current group ( prevent a bug with unclutter ). 2007-03-02 Philippe Brochard * bindings.lisp (run-program-from-query-string): A program can be launch from a input query window. 2007-03-01 Philippe Brochard * clfswm-info.lisp: Fix a bug with banish pointer in info mode. 2007-02-28 Philippe Brochard * clfswm.lisp (process-new-window): One can now open the next window in a workspace called by its number. * clfswm-util.lisp (query-font-string): Minimal editing capabilities. (eval-from-string): And an REPL in the window manager... :) 2007-02-26 Philippe Brochard * clfswm.lisp (process-new-window): One can now open the next window in a new workspace or a new group. * clfswm-pager.lisp (pager-mode): Display the next arrow action with the hidden windows. * clfswm.lisp (second-key-mode): Display the current workspace number and the next arrow action in the state window. * clfswm-pager.lisp (pager-mode): Hide all windows before leaving the pager mode and then redisplay only the current workspace. 2007-02-25 Philippe Brochard * clfswm.lisp (add-workspace): Workspaces are now numbered. So they can be focused with a keypress, sorted or renumbered. 2007-02-24 Philippe Brochard * clfswm-pager.lisp (pager-mode): Remove multiple silly pager-draw-display. This prevent a lot of flickering in the pager. * clfswm.lisp: Remove all display-force-output and replace them with only one display-finish-output in the event loop. 2006-11-06 Philippe Brochard * clfswm-pager.lisp (pager-center-group): New function - center a group at the middle of the screen. * clfswm-pack.lisp (center-group): New function - center a group at the middle of the screen. * clfswm.lisp (show-group): Add a cross line under the group. (show-group): Group are showned even if fullscreened. (init-display): Add an exposure event on the root window. 2006-11-05 Philippe Brochard * package.lisp (*default-group*): Default group is the same size of a fullscreened group. * bindings*: Use shift to move, control+shift to copy. * *.lisp: Add comments for configuration or alternatives. So grep for CONFIG to see where you can configure clfswm. And grep for Alternative to use some commented code. * clfswm.lisp (second-key-mode): Use a single window to show the second mode. See for alternatives at the end of this file. 2006-11-03 Philippe Brochard * clfswm-keys.lisp (define-define-key/mouse): Factorisation in a macro of key and mouse definitions. (define-define-key/mouse): Use state instead of modifiers list this fix a bug when the modifiers list is not in the rigth order. * clfswm.lisp (second-key-mode): Add a colored border in second mode. 2006-11-02 Philippe Brochard * clfswm-info.lisp (info-mode): Add an info mode. 2006-11-01 Philippe Brochard * clfswm.lisp (process-new-window): Change border size for transient windows. (show-all-windows-in-workspace): Unhide all windows even when the current group is in fullscreen mode. 2006-10-26 Philippe Brochard * clfswm-util.lisp (identify-key): Add an exposure handle-event to redisplay the identify window after a terminal switch. * clfswm-pager.lisp (pager-mode): Add an exposure handle-event to redisplay the pager after a terminal switch. 2006-10-24 Philippe Brochard * clfswm-util.lisp (identify-key): Add a window to display the keys to identify on screen. * bindings.lisp, bindings-pager.lisp: Define same keys to move/copy groups/windows in second mode and in pager. * clfswm.lisp (handle-event*): Same version in all clfswm (fix some drawing lags). (show-all-windows-in-workspace): unhide window before adapting it to group. 2006-10-23 Philippe Brochard * clfswm.lisp (handle-event): Revert to an older version. 2006-10-18 Philippe Brochard * clfswm-util.lisp (force-window-in-group) (force-window-center-in-group): New functions for transient windows. * clfswm-pager.lisp (pager-remove-current-workspace/group): bugfix: hide all windows before removing group or workspace. 2006-10-17 Philippe Brochard * bindings-pager.lisp (mouse-pager-move-selected-group) (mouse-pager-copy-selected-group) (mouse-pager-move-selected-window) (mouse-pager-copy-selected-window, mouse-pager-rotate-window-up) (mouse-pager-rotate-window-down): New functions to have mouse in pager mode. * clfswm-pager.lisp (pager-swap-window) (pager-copy-group-on-next/previous-workspace) (pager-copy-window-on-next/previous-line): New functions 2006-10-15 Philippe Brochard * clfswm-pager.lisp (pager-move-window-on-next/previous-line, (pager-move-group-on-next/previous-workspace): new functions. * clfswm-pack.lisp (resize-half-x-x-current-group): resize group to its half size (new functions). 2006-10-11 Philippe Brochard * clfswm-pager.lisp: workspaces, groups and windows can now be selectionned with the keyboard or the mouse. 2006-10-09 Philippe Brochard * clfswm-pager.lisp (pager-select-workspace-right/left): workspaces can now be selectionned with the keyboard. 2006-10-08 Philippe Brochard * clfswm-keys.lisp (undefine-main-key, undefine-second-key, undefine-mouse-action): new function to remove a previous defined key or mouse combination. 2006-10-07 Philippe Brochard * clfswm.lisp (main): Check for access error in init-display. * clfswm-keys.lisp (define-ungrab/grab): check for keysym and keycode before grabbing. * bindings.lisp: Remove nlambda and use defun to keep the function documentation with clisp. (define-shell): new macro to define shell command for the second mode. 2006-10-06 Philippe Brochard * clfswm-keys.lisp (define-ungrab/grab): use a cond instead of a boggus typecase. 2006-10-05 Philippe Brochard * bindings.lisp (accept-motion): Move group bugfix in upper mouse workspace circulation. * clfswm-util.lisp (absorb-orphan-window): new function. * clfswm-keys.lisp: Keysyms support. 2006-10-02 Philippe Brochard * clfswm.lisp (show-group): Use one gc for all groups and not one per group. 2006-10-01 Philippe Brochard * bindings.lisp (define-second-key (#\l :mod-1)): fix a typo. * clfswm.lisp (adapt-window-to-group): Adapt only windows with width and height outside group. 2006-09-28 Philippe Brochard * clfswm.lisp: First public release. clfswm-20111015.git51b0a02/Makefile.template000066400000000000000000000025051164636077000202040ustar00rootroot00000000000000# -*- makefile -*- DESTDIR=+DESTDIR+ BUILD_PATH=+BUILD_PATH+ build: @echo "Building" chmod a+x $(BUILD_PATH)/clfswm @echo "" @echo "Type 'make install' to install clfswm in '$(DESTDIR)/bin/clfswm'" @echo "" install: mkdir -p $(DESTDIR)/bin rm -rf $(DESTDIR)/lib/clfswm/ mkdir -p $(DESTDIR)/lib/clfswm/src mkdir -p $(DESTDIR)/share/doc/clfswm cp $(BUILD_PATH)/clfswm $(DESTDIR)/bin cp $(BUILD_PATH)/clfswm.asd $(DESTDIR)/lib/clfswm/ cp -R $(BUILD_PATH)/src/*.lisp $(DESTDIR)/lib/clfswm/src cp -R $(BUILD_PATH)/contrib $(DESTDIR)/lib/clfswm/ cp -R $(BUILD_PATH)/doc/* $(DESTDIR)/share/doc/clfswm/ cp -R $(BUILD_PATH)/AUTHORS $(DESTDIR)/share/doc/clfswm/ cp -R $(BUILD_PATH)/COPYING $(DESTDIR)/share/doc/clfswm/ cp -R $(BUILD_PATH)/README $(DESTDIR)/share/doc/clfswm/ cp -R $(BUILD_PATH)/TODO $(DESTDIR)/share/doc/clfswm/ cp -R $(BUILD_PATH)/ChangeLog $(DESTDIR)/share/doc/clfswm/ @echo "" @echo "clfswm has been installed in '$(DESTDIR)/bin/clfswm'" @echo "" uninstall: rm -rf $(DESTDIR)/bin/clfswm rm -rf $(DESTDIR)/lib/clfswm rm -rf $(DESTDIR)/share/doc/clfswm clean: find . \( -name "*~" -o -name "*.fas" -o -name "*.fasl" -o -name "*.lib" -o -name "*.lx32fsl" -o -name "*.x86f" \) -print0 | xargs -0 rm -f dist: clean cd .. && tar czvf clfswm-`date +%y%m%d`.tar.gz clfswm distclean: clean rm -f clfswm Makefile clfswm-20111015.git51b0a02/README000066400000000000000000000101761164636077000156150ustar00rootroot00000000000000 CLFSWM[0] - A(nother) Common Lisp FullScreen Window Manager CLFSWM is a 100% Common Lisp X11 window manager (based on [1]Tinywm and [2]Stumpwm. Many thanks to them). It can be driven only with the keyboard or with the mouse. A display contains a root frame and its children. A child can be a window or another frame. The root frame or its children can be the current root. The current root is fullscreen maximized (no decorations, no buttons, no menus: nothing, just the application fullscreen!). CLFSWM is highly dynamic. By default there is only one frame. Other frames are created/deleted on the fly. A window can be in more than one frame, so it can have multiple views of the same windows. Using CLFSWM is like walking through a tree of frames and windows. Enter in a child to make it the current root and make it fullscreen maximized. Leave it to make its parent the current root. Here is the default key binding to navigate through this tree: * Alt-Tab: circulate through children of the current child. * Alt-Left/Right: circulate through brother children (ie: this is like workspaces for a more conventional window manager) * Alt-Up: select the first child of the current frame. * Alt-Down: select the parent of the current child. * Alt-Enter: Make the current selected child the current root (ie maximize it) * Alt+Shift-Enter: Make the parent of the current root the current root (ie unmaximize the current root). There is no more need for a pager: you are in the pager! For its binding, CLFSWM has two modes: A main mode with minimal keys and mouse grabbing to avoid conflicts with others applications. And a second mode with more keys and mouse actions. For details of its usage, have a look at the files doc/keys.txt or doc/keys.html A lot of functions to manage CLFSWM can be found in the second mode menu. See the file menu-def.lisp for an overview. A frame can be placed anywhere in its parent frame. And can have different layouts to automatically manage its children (tile, tile to left, to bottom, no layout...). * Installation Boot up a common lisp implementation. I develop it with sbcl, I test it with cmucl regularly and I use it with clisp (you need the clx/xlib package). To use CLFSWM, load the load.lisp file. It loads the ASDF package, build the system and start the main loop. Another way is to do something like this: $ cd /in/the/directory/of/clfswm/ $ clisp/cmucl/sbcl/... # start a lisp > (load "asdf.lisp") ; asdf for clisp or cmucl or> (require :asdf) ; asdf for sbcl > (require :clx) ; clx for cmucl > (asdf:oos 'asdf:load-op :clfswm) ; compile and load the system > (in-package :clfswm) ; go in the clfswm package > (clfswm:main) ; start the main loop * Tweaking To change the default keybinding, have a look at the bindings*.lisp files and at the config.lisp file for global variables. All variables can be overwritten in a user configuration file: $XDG_CONFIG_HOME/clfswm/clfswmrc or $HOME/.clfswmrc or /etc/clfswmrc. It's a standard lisp file loaded at start up. There is an example in the clfswm source (see dot-clfswmrc). There is a lot of hooks in CLFSWM to tweak its behaviour. For example, if you want to add some frames at start up you can write your own init-hook (see dot-clfswmrc). * Lisp implementation note If you are using clisp/new-clx, be sure to use the last version (at least 2.43). Older versions are a little bit bogus. If you are using clisp/mit-clx or an other clx than clisp/new-clx, you may find a speed up with the compress notify event. See the variable *have-to-compress-notify* in the configuration file. * License CLFSWM is under the GNU General Public License - GPL license. You can find more information in the files COPYING. or on the [3]Free Software Foundation site. Philippe Brochard . Références http://common-lisp.net/project/clfswm/ http://trac.common-lisp.net/clfswm/ 1. http://incise.org/index.cgi/TinyWM 2. http://www.nongnu.org/stumpwm/ 3. http://www.gnu.org/ clfswm-20111015.git51b0a02/TODO000066400000000000000000000023601164636077000154210ustar00rootroot00000000000000This file contains suggestions for further work. Feel free to edit the wiki at http://trac.common-lisp.net/clfswm/wiki if you want something in clfswm. URGENT PROBLEMS =============== Should handle these soon. -> Nothing here yet. FOR THE NEXT RELEASE ==================== - Implement a save/restore root-frame system. And use it on error reset. MAYBE ===== - cd/pwd/find a la shell to navigate through frames. - Zoom: Concept: * zoom out: Behave as if the application window is bigger for the application but completely drawn in a small amount of space (miniature). The zoom factor is inferior to 100% * zoom in: Behave as a magnifying glass. The zoom factor is superior to 100%. The part of the application window shown (viewport) can be moved. Operation: * set-zoom-factor (frame, factor) * move-viewport (frame &optional (increment 1)) * left * right * up * down Note: This is done by some applications like the surf web browser from suckless: http://surf.suckless.org/ Maybe this can be done with a compositing system: http://en.wikipedia.org/wiki/Compositing_window_manager http://ktown.kde.org/~fredrik/composite_howto.html - Undo/redo clfswm-20111015.git51b0a02/clfswm.asd000066400000000000000000000070141164636077000167160ustar00rootroot00000000000000 ;;;; -*- Mode: Lisp -*- ;;;; Author: Philippe Brochard ;;;; ASDF System Definition ;;; (in-package #:asdf) (defsystem clfswm :description "CLFSWM: Fullscreen Window Manager" :version "Please, see in src/version.lisp" :author "Philippe Brochard " :licence "GNU Public License (GPL)" :components ((:module src :components ((:file "tools") (:file "version" :depends-on ("tools")) (:file "my-html" :depends-on ("tools")) (:file "package" :depends-on ("my-html" "tools" "version")) (:file "clfswm-placement" :depends-on ("package")) (:file "keysyms" :depends-on ("package")) (:file "xlib-util" :depends-on ("package" "keysyms" "tools" "clfswm-placement")) (:file "config" :depends-on ("package" "xlib-util")) (:file "netwm-util" :depends-on ("package" "xlib-util")) (:file "clfswm-keys" :depends-on ("package" "config" "xlib-util" "keysyms")) (:file "clfswm-autodoc" :depends-on ("package" "clfswm-keys" "my-html" "tools" "config")) (:file "clfswm-internal" :depends-on ("xlib-util" "clfswm-keys" "netwm-util" "tools" "config")) (:file "clfswm-generic-mode" :depends-on ("package" "tools" "xlib-util" "clfswm-internal")) (:file "clfswm-circulate-mode" :depends-on ("xlib-util" "clfswm-keys" "clfswm-generic-mode" "clfswm-internal" "netwm-util" "tools" "config")) (:file "clfswm" :depends-on ("xlib-util" "netwm-util" "clfswm-keys" "config" "clfswm-internal" "clfswm-circulate-mode" "tools")) (:file "clfswm-second-mode" :depends-on ("package" "clfswm" "clfswm-internal" "clfswm-generic-mode" "clfswm-placement")) (:file "clfswm-expose-mode" :depends-on ("package" "config" "clfswm-internal" "xlib-util" "tools" "clfswm-keys" "clfswm-generic-mode")) (:file "clfswm-corner" :depends-on ("package" "config" "clfswm-internal" "clfswm-expose-mode" "xlib-util")) (:file "clfswm-info" :depends-on ("package" "version" "xlib-util" "config" "clfswm-keys" "clfswm" "clfswm-internal" "clfswm-autodoc" "clfswm-corner" "clfswm-generic-mode" "clfswm-placement")) (:file "clfswm-menu" :depends-on ("package" "clfswm-info")) (:file "clfswm-query" :depends-on ("package" "config" "xlib-util" "clfswm-keys" "clfswm-generic-mode" "clfswm-placement")) (:file "clfswm-util" :depends-on ("clfswm" "keysyms" "clfswm-info" "clfswm-second-mode" "clfswm-query" "clfswm-menu" "clfswm-autodoc" "clfswm-corner")) (:file "clfswm-configuration" :depends-on ("package" "config" "clfswm-internal" "clfswm-util" "clfswm-query" "clfswm-menu")) (:file "menu-def" :depends-on ("clfswm-menu" "clfswm-configuration" "clfswm" "clfswm-util" "clfswm-info")) (:file "clfswm-layout" :depends-on ("package" "clfswm-internal" "clfswm-util" "clfswm-info" "menu-def")) (:file "clfswm-pack" :depends-on ("clfswm" "clfswm-util" "clfswm-second-mode" "clfswm-layout")) (:file "clfswm-nw-hooks" :depends-on ("package" "clfswm-util" "clfswm-info" "clfswm-layout" "menu-def")) (:file "bindings" :depends-on ("clfswm" "clfswm-internal" "clfswm-util" "clfswm-menu")) (:file "bindings-second-mode" :depends-on ("clfswm" "clfswm-util" "clfswm-query" "bindings" "clfswm-pack" "clfswm-menu" "menu-def" "clfswm-layout"))))) :depends-on ( #-:CLX :clx #+:sbcl :sb-posix )) clfswm-20111015.git51b0a02/configure000077500000000000000000000060151164636077000166410ustar00rootroot00000000000000#! /bin/sh CONFIGURE_VERSION=0.2 PREFIX="/usr/local" lisp=clisp lisp_opt='' lisp_bin='' dump_path="\$XDG_CACHE_HOME/clfswm/" clfswm_asd_path="$PREFIX/lib/clfswm" asdf_path="$PREFIX/lib/clfswm/contrib" usage () { echo "'configure' configures clfswm to adapt to many kinds of systems. Usage: ./configure [OPTION]... [VAR=VALUE]... Defaults for the options are specified in brackets. Configuration: -h, --help display this help and exit -V, --version display version information and exit --prefix=PREFIX install architecture-independent files in PREFIX [/usr/local] -l, --with-lisp use as the common lisp implementation type [$lisp] -b, --lisp-bin use as the common lisp program [$lisp_bin] (default: same as with-lisp type) -o, --lisp-opt use as lisp option [$lisp_opt] -d, --dump-path path to the dump directory [$dump_path] --with-clfswm path to clfswm.asd file [$clfswm_asd_path] --with-asdf path to the asdf.lisp file [$asdf_path] By default, 'make install' will install all the files in '/usr/local/bin', '/usr/local/lib' etc. You can specify an installation prefix other than '/usr/local' using '--prefix', for instance '--prefix \$HOME/clfswm'." exit 0 } version () { echo "Configure version: $CONFIGURE_VERSION" exit 0 } reset_clfswm_asd_path=true reset_asdf_path=true while test $# != 0 do case "$1" in --prefix) shift PREFIX="$1" ;; -d|--dump-path) shift dump_path="$1" ;; --with-clfswm) shift clfswm_asd_path="$1" reset_clfswm_asd_path=false ;; --with-asdf) shift asdf_path="$1" reset_asdf_path=false ;; -l|--with-lisp) shift case "$1" in '') usage;; clisp|sbcl|cmucl|ccl|ecl) lisp="$1" ;; esac ;; -b|--lisp-bin) shift lisp_bin="$1" ;; -o|--lisp-opt) shift lisp_opt="$1" ;; --) shift break ;; *) usage ;; esac shift done DESTDIR=$PREFIX if [ "$reset_clfswm_asd_path" = "true" ]; then clfswm_asd_path="$PREFIX/lib/clfswm" fi if [ "$reset_asdf_path" = "true" ]; then asdf_path="$PREFIX/lib/clfswm/contrib" fi echo " prefix=$PREFIX with-lisp=$lisp lisp-bin=$lisp_bin lisp-opt=$lisp_opt dump-path=$dump_path with-clfswm=$clfswm_asd_path with-asdf=$asdf_path" sed -e "s?^lisp=.*# +config+?lisp=\"$lisp\" # +config+?g" \ -e "s?^lisp_bin=.*# +config+?lisp_bin=\"$lisp_bin\" # +config+?g" \ -e "s?^lisp_opt=.*# +config+?lisp_opt=\"$lisp_opt\" # +config+?g" \ -e "s?^dump_path=.*# +config+?dump_path=\"$dump_path\" # +config+?g" \ -e "s?^clfswm_asd_path=.*# +config+?clfswm_asd_path=\"$clfswm_asd_path\" # +config+?g" \ -e "s?^asdf_path=.*# +config+?asdf_path=\"$asdf_path\" # +config+?g" \ $(pwd)/contrib/clfswm > $(pwd)/clfswm sed -e "s#+DESTDIR+#$DESTDIR#g" \ -e "s#+BUILD_PATH+#$(pwd)/#g" \ Makefile.template > Makefile echo "" echo "Type 'make' to build clfswm" echo "" clfswm-20111015.git51b0a02/contrib/000077500000000000000000000000001164636077000163705ustar00rootroot00000000000000clfswm-20111015.git51b0a02/contrib/README000066400000000000000000000006241164636077000172520ustar00rootroot00000000000000The contrib directory is here if you want to contribute to CLFSWM and if your code is not merged in the clfswm core. To contribute, place your files in the contrib directory. You can have your own repository and tell me if you want to merge it in the clfswm svn/git. To use a contributed code add a line like this in your configuration file: (load-contrib "contrib-example.lisp") Have fun, Philippe clfswm-20111015.git51b0a02/contrib/amixer.lisp000066400000000000000000000104331164636077000205470ustar00rootroot00000000000000;;; -------------------------------------------------------------------------- ;;; CLFSWM - FullScreen Window Manager ;;; ;;; -------------------------------------------------------------------------- ;;; Documentation: Volume mode ;;; -------------------------------------------------------------------------- ;;; ;;; (C) 2011 Desmond O. Chang ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;; ;;; Documentation: A volume mode. ;;; If you want to use this file, just add this line in ;;; your configuration file: ;;; ;;; (load-contrib "volume-mode.lisp") ;;; And with the alsa mixer: ;;; (load-contrib "amixer.lisp") ;;; ;;; This mode is inspired by the emms volume package. When you change the ;;; volume in main mode or second mode, clfswm will enter volume mode and ;;; set a timer to leave this mode. Changing volume in volume mode will ;;; reset the timer. You can also leave volume mode manually by return, ;;; escape or control-g. ;;; ;;; Special variable *VOLUME-MODE-TIMEOUT* controls the timeout in ;;; seconds. If it's positive, volume mode will exit when timeout occurs; ;;; if it's 0, volume mode will exit right now; if it's negative, volume ;;; will not exit even if timeout occurs. Default timeout is 3 seconds. ;;; ;;; Volume mode uses three special variables to control the mixer: ;;; *VOLUME-MUTE-FUNCTION*, *VOLUME-LOWER-FUNCTION* and ;;; *VOLUME-RAISE-FUNCTION*. Their values are functions which must accept ;;; no arguments and return two values indicating the mixer state. The ;;; first value is the volume ratio whose type must be (real 0 1). If the ;;; mixer is mute, the second value should be true, otherwise it should be ;;; false. If volume controller cannot get the mixer state, it must ;;; return NIL. ;;; ;;; Volume mode shows a mute sign, a percentage and a ratio bar on the ;;; screen. A plus sign '+' means it's unmute and a minus sign '-' means ;;; it's mute now. If volume mode doesn't know the mixer state, a message ;;; "unknown" will be shown. ;;; ;;; contrib/amixer.lisp shows how to use volume mode with alsa. ;;; ;;; -------------------------------------------------------------------------- (in-package :clfswm) (format t "Loading amixer code... ") (defvar *amixer-scontrol* "Master" "Default control for amixer commands.") (defun amixer-cmd (cmd scontrol &rest parameters) (let* ((sed "sed 's/^.*\\[\\([[:digit:]]\\+\\)%\\].*\\[\\(on\\|off\\)\\].*$/\\1%\\2/'") (fmt "amixer ~A ~A~{ ~A~} 2>/dev/null | tail -1 | ~A") (shell (format nil fmt cmd scontrol parameters sed)) (line (read-line (do-shell shell) nil nil))) (when line (let* ((ratio (parse-integer line :junk-allowed t)) (%-pos (position #\% line))) (values (and ratio (/ ratio 100)) (equal "off" (and %-pos (subseq line (1+ %-pos))))))))) (defun amixer-sset (&rest parameters) (apply 'amixer-cmd "sset" *amixer-scontrol* parameters)) (defparameter *volume-mute-function* (lambda () (amixer-sset "toggle"))) (defparameter *volume-lower-function* (lambda () (amixer-sset "5%-"))) (defparameter *volume-raise-function* (lambda () (amixer-sset "5%+"))) (defun amixer-lower-1% () "Lower 1% volume." (volume-set (lambda () (amixer-sset "1%-")))) (defun amixer-raise-1% () "Raise 1% volume." (volume-set (lambda () (amixer-sset "1%+")))) (defun amixer-volume-bind () (define-volume-key ("less") 'amixer-lower-1%) (define-volume-key ("greater") 'amixer-raise-1%) (define-second-key ("less") 'amixer-lower-1%) (define-second-key ("greater") 'amixer-raise-1%)) (add-hook *binding-hook* 'amixer-volume-bind) (format t "done~%") clfswm-20111015.git51b0a02/contrib/asdf.lisp000066400000000000000000004354651164636077000202170ustar00rootroot00000000000000;;; -*- mode: common-lisp; package: asdf; -*- ;;; This is ASDF: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to . ;;; Note first that the canonical source for ASDF is presently ;;; . ;;; ;;; If you obtained this copy from anywhere else, and you experience ;;; trouble using it, or find bugs, you may want to check at the ;;; location above for a more recent version (and for documentation ;;; and test files, if your copy came without them) before reporting ;;; bugs. There are usually two "supported" revisions - the git HEAD ;;; is the latest development version, whereas the revision tagged ;;; RELEASE may be slightly older but is considered `stable' ;;; -- LICENSE START ;;; (This is the MIT / X Consortium license as taken from ;;; http://www.opensource.org/licenses/mit-license.html on or about ;;; Monday; July 13, 2009) ;;; ;;; Copyright (c) 2001-2010 Daniel Barlow and contributors ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining ;;; a copy of this software and associated documentation files (the ;;; "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. ;;; ;;; -- LICENSE END ;;; The problem with writing a defsystem replacement is bootstrapping: ;;; we can't use defsystem to compile it. Hence, all in one file. #+xcvb (module ()) (cl:in-package :cl-user) (eval-when (:compile-toplevel :load-toplevel :execute) ;;; make package if it doesn't exist yet. ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it. (unless (find-package :asdf) (make-package :asdf :use '(:cl))) ;;; Implementation-dependent tweaks ;; (declaim (optimize (speed 2) (debug 2) (safety 3))) ; NO: rely on the implementation defaults. #+allegro (setf excl::*autoload-package-name-alist* (remove "asdf" excl::*autoload-package-name-alist* :test 'equalp :key 'car)) #+ecl (require :cmp)) (in-package :asdf) ;;;; Create packages in a way that is compatible with hot-upgrade. ;;;; See https://bugs.launchpad.net/asdf/+bug/485687 ;;;; See more at the end of the file. (eval-when (:load-toplevel :compile-toplevel :execute) (defvar *asdf-version* nil) (defvar *upgraded-p* nil) (let* ((asdf-version ;; the 1+ helps the version bumping script discriminate (subseq "VERSION:2.131" (1+ (length "VERSION")))) (existing-asdf (fboundp 'find-system)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) (unless (and existing-asdf already-there) (when existing-asdf (format *trace-output* "~&Upgrading ASDF package ~@[from version ~A ~]to version ~A~%" existing-version asdf-version)) (labels ((unlink-package (package) (let ((u (find-package package))) (when u (ensure-unintern u (loop :for s :being :each :present-symbol :in u :collect s)) (loop :for p :in (package-used-by-list u) :do (unuse-package u p)) (delete-package u)))) (ensure-exists (name nicknames use) (let ((previous (remove-duplicates (mapcar #'find-package (cons name nicknames)) :from-end t))) ;; do away with packages with conflicting (nick)names (map () #'unlink-package (cdr previous)) ;; reuse previous package with same name (let ((p (car previous))) (cond (p (rename-package p name nicknames) (ensure-use p use) p) (t (make-package name :nicknames nicknames :use use)))))) (find-sym (symbol package) (find-symbol (string symbol) package)) (intern* (symbol package) (intern (string symbol) package)) (remove-symbol (symbol package) (let ((sym (find-sym symbol package))) (when sym (unexport sym package) (unintern sym package) sym))) (ensure-unintern (package symbols) (loop :with packages = (list-all-packages) :for sym :in symbols :for removed = (remove-symbol sym package) :when removed :do (loop :for p :in packages :do (when (eq removed (find-sym sym p)) (unintern removed p))))) (ensure-shadow (package symbols) (shadow symbols package)) (ensure-use (package use) (dolist (used (reverse use)) (do-external-symbols (sym used) (unless (eq sym (find-sym sym package)) (remove-symbol sym package))) (use-package used package))) (ensure-fmakunbound (package symbols) (loop :for name :in symbols :for sym = (find-sym name package) :when sym :do (fmakunbound sym))) (ensure-export (package export) (let ((formerly-exported-symbols nil) (bothly-exported-symbols nil) (newly-exported-symbols nil)) (loop :for sym :being :each :external-symbol :in package :do (if (member sym export :test 'string-equal) (push sym bothly-exported-symbols) (push sym formerly-exported-symbols))) (loop :for sym :in export :do (unless (member sym bothly-exported-symbols :test 'string-equal) (push sym newly-exported-symbols))) (loop :for user :in (package-used-by-list package) :for shadowing = (package-shadowing-symbols user) :do (loop :for new :in newly-exported-symbols :for old = (find-sym new user) :when (and old (not (member old shadowing))) :do (unintern old user))) (loop :for x :in newly-exported-symbols :do (export (intern* x package))))) (ensure-package (name &key nicknames use unintern fmakunbound shadow export) (let* ((p (ensure-exists name nicknames use))) (ensure-unintern p unintern) (ensure-shadow p shadow) (ensure-export p export) (ensure-fmakunbound p fmakunbound) p))) (macrolet ((pkgdcl (name &key nicknames use export redefined-functions unintern fmakunbound shadow) `(ensure-package ',name :nicknames ',nicknames :use ',use :export ',export :shadow ',shadow :unintern ',(append #-(or gcl ecl) redefined-functions unintern) :fmakunbound ',(append fmakunbound)))) (unlink-package :asdf-utilities) (pkgdcl :asdf :use (:common-lisp) :redefined-functions (#:perform #:explain #:output-files #:operation-done-p #:perform-with-restarts #:component-relative-pathname #:system-source-file #:operate #:find-component #:find-system #:apply-output-translations #:translate-pathname*) :unintern (#:*asdf-revision* #:around #:asdf-method-combination #:split #:make-collector) :fmakunbound (#:system-source-file #:component-relative-pathname #:system-relative-pathname #:process-source-registry #:inherit-source-registry #:process-source-registry-directive) :export (#:defsystem #:oos #:operate #:find-system #:run-shell-command #:system-definition-pathname #:find-component ; miscellaneous #:compile-system #:load-system #:test-system #:clear-system #:compile-op #:load-op #:load-source-op #:test-op #:operation ; operations #:feature ; sort-of operation #:version ; metaphorically sort-of an operation #:version-satisfies #:input-files #:output-files #:output-file #:perform ; operation methods #:operation-done-p #:explain #:component #:source-file #:c-source-file #:cl-source-file #:java-source-file #:static-file #:doc-file #:html-file #:text-file #:source-file-type #:module ; components #:system #:unix-dso #:module-components ; component accessors #:module-components-by-name ; component accessors #:component-pathname #:component-relative-pathname #:component-name #:component-version #:component-parent #:component-property #:component-system #:component-depends-on #:system-description #:system-long-description #:system-author #:system-maintainer #:system-license #:system-licence #:system-source-file #:system-source-directory #:system-relative-pathname #:map-systems #:operation-on-warnings #:operation-on-failure #:component-visited-p ;;#:*component-parent-pathname* #:*system-definition-search-functions* #:*central-registry* ; variables #:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour* #:*resolve-symlinks* #:*asdf-verbose* #:asdf-version #:operation-error #:compile-failed #:compile-warned #:compile-error #:error-name #:error-pathname #:load-system-definition-error #:error-component #:error-operation #:system-definition-error #:missing-component #:missing-component-of-version #:missing-dependency #:missing-dependency-of-version #:circular-dependency ; errors #:duplicate-names #:try-recompiling #:retry #:accept ; restarts #:coerce-entry-to-directory #:remove-entry-from-registry #:clear-configuration #:initialize-output-translations #:disable-output-translations #:clear-output-translations #:ensure-output-translations #:apply-output-translations #:compile-file* #:compile-file-pathname* #:enable-asdf-binary-locations-compatibility #:*default-source-registries* #:initialize-source-registry #:compute-source-registry #:clear-source-registry #:ensure-source-registry #:process-source-registry #:system-registered-p #:asdf-message ;; Utilities #:absolute-pathname-p ;; #:aif #:it ;; #:appendf #:coerce-name #:directory-pathname-p ;; #:ends-with #:ensure-directory-pathname #:getenv ;; #:get-uid ;; #:length=n-p #:merge-pathnames* #:pathname-directory-pathname #:read-file-forms ;; #:remove-keys ;; #:remove-keyword #:resolve-symlinks #:split-string #:component-name-to-pathname-components #:split-name-type #:truenamize #:while-collecting))) (setf *asdf-version* asdf-version *upgraded-p* (if existing-version (cons existing-version *upgraded-p*) *upgraded-p*)))))) ;; More cleanups in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687 (when *upgraded-p* #+ecl (when (find-class 'compile-op nil) (defmethod update-instance-for-redefined-class :after ((c compile-op) added deleted plist &key) (declare (ignore added deleted)) (let ((system-p (getf plist 'system-p))) (when system-p (setf (getf (slot-value c 'flags) :system-p) system-p))))) (when (find-class 'module nil) (eval '(defmethod update-instance-for-redefined-class :after ((m module) added deleted plist &key) (declare (ignorable deleted plist)) (when *asdf-verbose* (format *trace-output* "Updating ~A~%" m)) (when (member 'components-by-name added) (compute-module-components-by-name m)))))) ;;;; ------------------------------------------------------------------------- ;;;; User-visible parameters ;;;; (defun asdf-version () "Exported interface to the version of ASDF currently installed. A string. You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.000\")." *asdf-version*) (defvar *resolve-symlinks* t "Determine whether or not ASDF resolves symlinks when defining systems. Defaults to T.") (defvar *compile-file-warnings-behaviour* (or #+clisp :ignore :warn) "How should ASDF react if it encounters a warning when compiling a file? Valid values are :error, :warn, and :ignore.") (defvar *compile-file-failure-behaviour* (or #+sbcl :error #+clisp :ignore :warn) "How should ASDF react if it encounters a failure (per the ANSI spec of COMPILE-FILE) when compiling a file? Valid values are :error, :warn, and :ignore. Note that ASDF ALWAYS raises an error if it fails to create an output file when compiling.") (defvar *verbose-out* nil) (defvar *asdf-verbose* t) (defparameter +asdf-methods+ '(perform-with-restarts perform explain output-files operation-done-p)) #+allegro (eval-when (:compile-toplevel :execute) (defparameter *acl-warn-save* (when (boundp 'excl:*warn-on-nested-reader-conditionals*) excl:*warn-on-nested-reader-conditionals*)) (when (boundp 'excl:*warn-on-nested-reader-conditionals*) (setf excl:*warn-on-nested-reader-conditionals* nil))) ;;;; ------------------------------------------------------------------------- ;;;; ASDF Interface, in terms of generic functions. (macrolet ((defdef (def* def) `(defmacro ,def* (name formals &rest rest) `(progn #+(or ecl gcl) (fmakunbound ',name) ,(when (and #+ecl (symbolp name)) `(declaim (notinline ,name))) ; fails for setf functions on ecl (,',def ,name ,formals ,@rest))))) (defdef defgeneric* defgeneric) (defdef defun* defun)) (defgeneric* find-system (system &optional error-p)) (defgeneric* perform-with-restarts (operation component)) (defgeneric* perform (operation component)) (defgeneric* operation-done-p (operation component)) (defgeneric* explain (operation component)) (defgeneric* output-files (operation component)) (defgeneric* input-files (operation component)) (defgeneric* component-operation-time (operation component)) (defgeneric* operation-description (operation component) (:documentation "returns a phrase that describes performing this operation on this component, e.g. \"loading /a/b/c\". You can put together sentences using this phrase.")) (defgeneric* system-source-file (system) (:documentation "Return the source file in which system is defined.")) (defgeneric* component-system (component) (:documentation "Find the top-level system containing COMPONENT")) (defgeneric* component-pathname (component) (:documentation "Extracts the pathname applicable for a particular component.")) (defgeneric* component-relative-pathname (component) (:documentation "Returns a pathname for the component argument intended to be interpreted relative to the pathname of that component's parent. Despite the function's name, the return value may be an absolute pathname, because an absolute pathname may be interpreted relative to another pathname in a degenerate way.")) (defgeneric* component-property (component property)) (defgeneric* (setf component-property) (new-value component property)) (defgeneric* version-satisfies (component version)) (defgeneric* find-component (base path) (:documentation "Finds the component with PATH starting from BASE module; if BASE is nil, then the component is assumed to be a system.")) (defgeneric* source-file-type (component system)) (defgeneric* operation-ancestor (operation) (:documentation "Recursively chase the operation's parent pointer until we get to the head of the tree")) (defgeneric* component-visited-p (operation component) (:documentation "Returns the value stored by a call to VISIT-COMPONENT, if that has been called, otherwise NIL. This value stored will be a cons cell, the first element of which is a computed key, so not interesting. The CDR wil be the DATA value stored by VISIT-COMPONENT; recover it as (cdr (component-visited-p op c)). In the current form of ASDF, the DATA value retrieved is effectively a boolean, indicating whether some operations are to be performed in order to do OPERATION X COMPONENT. If the data value is NIL, the combination had been explored, but no operations needed to be performed.")) (defgeneric* visit-component (operation component data) (:documentation "Record DATA as being associated with OPERATION and COMPONENT. This is a side-effecting function: the association will be recorded on the ROOT OPERATION \(OPERATION-ANCESTOR of the OPERATION\). No evidence that DATA is ever interesting, beyond just being non-NIL. Using the data field is probably very risky; if there is already a record for OPERATION X COMPONENT, DATA will be quietly discarded instead of recorded. Starting with 2.006, TRAVERSE will store an integer in data, so that nodes can be sorted in decreasing order of traversal.")) (defgeneric* (setf visiting-component) (new-value operation component)) (defgeneric* component-visiting-p (operation component)) (defgeneric* component-depends-on (operation component) (:documentation "Returns a list of dependencies needed by the component to perform the operation. A dependency has one of the following forms: ( *), where is a class designator and each is a component designator, which means that the component depends on having been performed on each ; or (FEATURE ), which means that the component depends on 's presence in *FEATURES*. Methods specialized on subclasses of existing component types should usually append the results of CALL-NEXT-METHOD to the list.")) (defgeneric* component-self-dependencies (operation component)) (defgeneric* traverse (operation component) (:documentation "Generate and return a plan for performing OPERATION on COMPONENT. The plan returned is a list of dotted-pairs. Each pair is the CONS of ASDF operation object and a COMPONENT object. The pairs will be processed in order by OPERATE.")) ;;;; ------------------------------------------------------------------------- ;;;; General Purpose Utilities (defmacro while-collecting ((&rest collectors) &body body) "COLLECTORS should be a list of names for collections. A collector defines a function that, when applied to an argument inside BODY, will add its argument to the corresponding collection. Returns multiple values, a list for each collection, in order. E.g., \(while-collecting \(foo bar\) \(dolist \(x '\(\(a 1\) \(b 2\) \(c 3\)\)\) \(foo \(first x\)\) \(bar \(second x\)\)\)\) Returns two values: \(A B C\) and \(1 2 3\)." (let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collectors)) (initial-values (mapcar (constantly nil) collectors))) `(let ,(mapcar #'list vars initial-values) (flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v) (values))) collectors vars) ,@body (values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars)))))) (defmacro aif (test then &optional else) `(let ((it ,test)) (if it ,then ,else))) (defun* pathname-directory-pathname (pathname) "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME, and NIL NAME, TYPE and VERSION components" (when pathname (make-pathname :name nil :type nil :version nil :defaults pathname))) (defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*)) "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that if the SPECIFIED pathname does not have an absolute directory, then the HOST and DEVICE come from the DEFAULTS. Also, if either argument is NIL, then the other argument is returned unmodified." (when (null specified) (return-from merge-pathnames* defaults)) (when (null defaults) (return-from merge-pathnames* specified)) (let* ((specified (pathname specified)) (defaults (pathname defaults)) (directory (pathname-directory specified)) #-(or sbcl cmu) (directory (if (stringp directory) `(:absolute ,directory) directory)) (name (or (pathname-name specified) (pathname-name defaults))) (type (or (pathname-type specified) (pathname-type defaults))) (version (or (pathname-version specified) (pathname-version defaults)))) (labels ((ununspecific (x) (if (eq x :unspecific) nil x)) (unspecific-handler (p) (if (typep p 'logical-pathname) #'ununspecific #'identity))) (multiple-value-bind (host device directory unspecific-handler) (#-gcl ecase #+gcl case (first directory) ((nil) (values (pathname-host defaults) (pathname-device defaults) (pathname-directory defaults) (unspecific-handler defaults))) ((:absolute) (values (pathname-host specified) (pathname-device specified) directory (unspecific-handler specified))) ((:relative) (values (pathname-host defaults) (pathname-device defaults) (if (pathname-directory defaults) (append (pathname-directory defaults) (cdr directory)) directory) (unspecific-handler defaults))) #+gcl (t (assert (stringp (first directory))) (values (pathname-host defaults) (pathname-device defaults) (append (pathname-directory defaults) directory) (unspecific-handler defaults)))) (make-pathname :host host :device device :directory directory :name (funcall unspecific-handler name) :type (funcall unspecific-handler type) :version (funcall unspecific-handler version)))))) (define-modify-macro appendf (&rest args) append "Append onto list") ;; only to be used on short lists. (define-modify-macro orf (&rest args) or "or a flag") (defun* first-char (s) (and (stringp s) (plusp (length s)) (char s 0))) (defun* last-char (s) (and (stringp s) (plusp (length s)) (char s (1- (length s))))) (defun* asdf-message (format-string &rest format-args) (declare (dynamic-extent format-args)) (apply #'format *verbose-out* format-string format-args)) (defun* split-string (string &key max (separator '(#\Space #\Tab))) "Split STRING into a list of components separated by any of the characters in the sequence SEPARATOR. If MAX is specified, then no more than max(1,MAX) components will be returned, starting the separation from the end, e.g. when called with arguments \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")." (block nil (let ((list nil) (words 0) (end (length string))) (flet ((separatorp (char) (find char separator)) (done () (return (cons (subseq string 0 end) list)))) (loop :for start = (if (and max (>= words (1- max))) (done) (position-if #'separatorp string :end end :from-end t)) :do (when (null start) (done)) (push (subseq string (1+ start) end) list) (incf words) (setf end start)))))) (defun* split-name-type (filename) (let ((unspecific ;; Giving :unspecific as argument to make-pathname is not portable. ;; See CLHS make-pathname and 19.2.2.2.3. ;; We only use it on implementations that support it. (or #+(or ccl ecl gcl lispworks sbcl) :unspecific))) (destructuring-bind (name &optional (type unspecific)) (split-string filename :max 2 :separator ".") (if (equal name "") (values filename unspecific) (values name type))))) (defun* component-name-to-pathname-components (s &optional force-directory) "Splits the path string S, returning three values: A flag that is either :absolute or :relative, indicating how the rest of the values are to be interpreted. A directory path --- a list of strings, suitable for use with MAKE-PATHNAME when prepended with the flag value. A filename with type extension, possibly NIL in the case of a directory pathname. FORCE-DIRECTORY forces S to be interpreted as a directory pathname \(third return value will be NIL, final component of S will be treated as part of the directory path. The intention of this function is to support structured component names, e.g., \(:file \"foo/bar\"\), which will be unpacked to relative pathnames." (check-type s string) (let* ((components (split-string s :separator "/")) (last-comp (car (last components)))) (multiple-value-bind (relative components) (if (equal (first components) "") (if (equal (first-char s) #\/) (values :absolute (cdr components)) (values :relative nil)) (values :relative components)) (setf components (remove "" components :test #'equal)) (cond ((equal last-comp "") (values relative components nil)) ; "" already removed (force-directory (values relative components nil)) (t (values relative (butlast components) last-comp)))))) (defun* remove-keys (key-names args) (loop :for (name val) :on args :by #'cddr :unless (member (symbol-name name) key-names :key #'symbol-name :test 'equal) :append (list name val))) (defun* remove-keyword (key args) (loop :for (k v) :on args :by #'cddr :unless (eq k key) :append (list k v))) (defun* getenv (x) (#+abcl ext:getenv #+allegro sys:getenv #+clisp ext:getenv #+clozure ccl:getenv #+(or cmu scl) (lambda (x) (cdr (assoc x ext:*environment-list* :test #'string=))) #+ecl si:getenv #+gcl system:getenv #+lispworks lispworks:environment-variable #+sbcl sb-ext:posix-getenv x)) (defun* directory-pathname-p (pathname) "Does PATHNAME represent a directory? A directory-pathname is a pathname _without_ a filename. The three ways that the filename components can be missing are for it to be NIL, :UNSPECIFIC or the empty string. Note that this does _not_ check to see that PATHNAME points to an actually-existing directory." (flet ((check-one (x) (member x '(nil :unspecific "") :test 'equal))) (and (check-one (pathname-name pathname)) (check-one (pathname-type pathname)) t))) (defun* ensure-directory-pathname (pathspec) "Converts the non-wild pathname designator PATHSPEC to directory form." (cond ((stringp pathspec) (ensure-directory-pathname (pathname pathspec))) ((not (pathnamep pathspec)) (error "Invalid pathname designator ~S" pathspec)) ((wild-pathname-p pathspec) (error "Can't reliably convert wild pathnames.")) ((directory-pathname-p pathspec) pathspec) (t (make-pathname :directory (append (or (pathname-directory pathspec) (list :relative)) (list (file-namestring pathspec))) :name nil :type nil :version nil :defaults pathspec)))) (defun* absolute-pathname-p (pathspec) (and pathspec (eq :absolute (car (pathname-directory (pathname pathspec)))))) (defun* length=n-p (x n) ;is it that (= (length x) n) ? (check-type n (integer 0 *)) (loop :for l = x :then (cdr l) :for i :downfrom n :do (cond ((zerop i) (return (null l))) ((not (consp l)) (return nil))))) (defun* ends-with (s suffix) (check-type s string) (check-type suffix string) (let ((start (- (length s) (length suffix)))) (and (<= 0 start) (string-equal s suffix :start1 start)))) (defun* read-file-forms (file) (with-open-file (in file) (loop :with eof = (list nil) :for form = (read in nil eof) :until (eq form eof) :collect form))) #-(and (or win32 windows mswindows mingw32) (not cygwin)) (progn #+ecl #.(cl:and (cl:< ext:+ecl-version-number+ 100601) '(ffi:clines "#include " "#include ")) (defun* get-uid () #+allegro (excl.osi:getuid) #+clisp (loop :for s :in '("posix:uid" "LINUX:getuid") :for f = (ignore-errors (read-from-string s)) :when f :return (funcall f)) #+(or cmu scl) (unix:unix-getuid) #+ecl #.(cl:if (cl:< ext:+ecl-version-number+ 100601) '(ffi:c-inline () () :int "getuid()" :one-liner t) '(ext::getuid)) #+sbcl (sb-unix:unix-getuid) #-(or allegro clisp cmu ecl sbcl scl) (let ((uid-string (with-output-to-string (*verbose-out*) (run-shell-command "id -ur")))) (with-input-from-string (stream uid-string) (read-line stream) (handler-case (parse-integer (read-line stream)) (error () (error "Unable to find out user ID"))))))) (defun* pathname-root (pathname) (make-pathname :host (pathname-host pathname) :device (pathname-device pathname) :directory '(:absolute) :name nil :type nil :version nil)) (defun* probe-file* (p) "when given a pathname P, probes the filesystem for a file or directory with given pathname and if it exists return its truename." (etypecase p (null nil) (string (probe-file* (parse-namestring p))) (pathname (unless (wild-pathname-p p) #.(or #+(or allegro clozure cmu ecl sbcl scl) '(probe-file p) #+clisp (aif (find-symbol (string :probe-pathname) :ext) `(,it p)) '(ignore-errors (truename p))))))) (defun* truenamize (p) "Resolve as much of a pathname as possible" (block nil (when (typep p 'logical-pathname) (return p)) (let* ((p (merge-pathnames* p)) (directory (pathname-directory p))) (when (typep p 'logical-pathname) (return p)) (let ((found (probe-file* p))) (when found (return found))) #-(or sbcl cmu) (when (stringp directory) (return p)) (when (not (eq :absolute (car directory))) (return p)) (let ((sofar (probe-file* (pathname-root p)))) (unless sofar (return p)) (flet ((solution (directories) (merge-pathnames* (make-pathname :host nil :device nil :directory `(:relative ,@directories) :name (pathname-name p) :type (pathname-type p) :version (pathname-version p)) sofar))) (loop :for component :in (cdr directory) :for rest :on (cdr directory) :for more = (probe-file* (merge-pathnames* (make-pathname :directory `(:relative ,component)) sofar)) :do (if more (setf sofar more) (return (solution rest))) :finally (return (solution nil)))))))) (defun* resolve-symlinks (path) #-allegro (truenamize path) #+allegro (excl:pathname-resolve-symbolic-links path)) (defun* default-directory () (truenamize (pathname-directory-pathname *default-pathname-defaults*))) (defun* lispize-pathname (input-file) (make-pathname :type "lisp" :defaults input-file)) (defparameter *wild-path* (make-pathname :directory '(:relative :wild-inferiors) :name :wild :type :wild :version :wild)) (defun* wilden (path) (merge-pathnames* *wild-path* path)) (defun* directorize-pathname-host-device (pathname) (let* ((root (pathname-root pathname)) (wild-root (wilden root)) (absolute-pathname (merge-pathnames* pathname root)) (foo (make-pathname :directory '(:absolute "FOO") :defaults root)) (separator (last-char (namestring foo))) (root-namestring (namestring root)) (root-string (substitute-if #\/ (lambda (x) (or (eql x #\:) (eql x separator))) root-namestring))) (multiple-value-bind (relative path filename) (component-name-to-pathname-components root-string t) (declare (ignore relative filename)) (let ((new-base (make-pathname :defaults root :directory `(:absolute ,@path)))) (translate-pathname absolute-pathname wild-root (wilden new-base)))))) ;;;; ------------------------------------------------------------------------- ;;;; Classes, Conditions (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)) (declaim (ftype (function (t) t) format-arguments format-control error-name error-pathname error-condition duplicate-names-name error-component error-operation module-components module-components-by-name circular-dependency-components) (ftype (function (t t) t) (setf module-components-by-name))) (define-condition formatted-system-definition-error (system-definition-error) ((format-control :initarg :format-control :reader format-control) (format-arguments :initarg :format-arguments :reader format-arguments)) (:report (lambda (c s) (apply #'format s (format-control c) (format-arguments c))))) (define-condition load-system-definition-error (system-definition-error) ((name :initarg :name :reader error-name) (pathname :initarg :pathname :reader error-pathname) (condition :initarg :condition :reader error-condition)) (:report (lambda (c s) (format s "~@" (error-name c) (error-pathname c) (error-condition c))))) (define-condition circular-dependency (system-definition-error) ((components :initarg :components :reader circular-dependency-components)) (:report (lambda (c s) (format s "~@" (circular-dependency-components c))))) (define-condition duplicate-names (system-definition-error) ((name :initarg :name :reader duplicate-names-name)) (:report (lambda (c s) (format s "~@" (duplicate-names-name c))))) (define-condition missing-component (system-definition-error) ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires) (parent :initform nil :reader missing-parent :initarg :parent))) (define-condition missing-component-of-version (missing-component) ((version :initform nil :reader missing-version :initarg :version))) (define-condition missing-dependency (missing-component) ((required-by :initarg :required-by :reader missing-required-by))) (define-condition missing-dependency-of-version (missing-dependency missing-component-of-version) ()) (define-condition operation-error (error) ((component :reader error-component :initarg :component) (operation :reader error-operation :initarg :operation)) (:report (lambda (c s) (format s "~@" (error-operation c) (error-component c))))) (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 :accessor component-in-order-to) ;; This one is used by POIU. Maybe in the future by ASDF instead of in-order-to? ;; POIU is a parallel (multi-process build) extension of ASDF. See ;; http://www.cliki.net/poiu (load-dependencies :accessor component-load-dependencies :initform nil) ;; XXX crap name, but it's an official API name! (do-first :initform nil :initarg :do-first :accessor component-do-first) ;; methods defined using the "inline" style inside a defsystem form: ;; need to store them somewhere so we can delete them when the system ;; is re-evaluated (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) (absolute-pathname) (operation-times :initform (make-hash-table) :accessor component-operation-times) ;; XXX we should provide some atomic interface for updating the ;; component properties (properties :accessor component-properties :initarg :properties :initform nil))) (defun* component-find-path (component) (reverse (loop :for c = component :then (component-parent c) :while c :collect (component-name c)))) (defmethod print-object ((c component) stream) (print-unreadable-object (c stream :type t :identity nil) (format stream "~@<~{~S~^ ~}~@:>" (component-find-path c)))) ;;;; methods: conditions (defmethod print-object ((c missing-dependency) s) (format s "~@<~A, required by ~A~@:>" (call-next-method c nil) (missing-required-by c))) (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) (when (missing-parent c) (component-name (missing-parent c))))) (defmethod print-object ((c missing-component-of-version) s) (format s "~@" (missing-requires c) (missing-version c) (when (missing-parent c) (component-name (missing-parent c))))) (defmethod component-system ((component component)) (aif (component-parent component) (component-system it) component)) (defvar *default-component-class* 'cl-source-file) (defun* compute-module-components-by-name (module) (let ((hash (make-hash-table :test 'equal))) (setf (module-components-by-name module) hash) (loop :for c :in (module-components module) :for name = (component-name c) :for previous = (gethash name (module-components-by-name module)) :do (when previous (error 'duplicate-names :name name)) :do (setf (gethash name (module-components-by-name module)) c)) hash)) (defclass module (component) ((components :initform nil :initarg :components :accessor module-components) (components-by-name :accessor module-components-by-name) ;; What to do if we can't satisfy a dependency of one of this module's ;; components. This allows a limited form of conditional processing. (if-component-dep-fails :initform :fail :initarg :if-component-dep-fails :accessor module-if-component-dep-fails) (default-component-class :initform *default-component-class* :initarg :default-component-class :accessor module-default-component-class))) (defun* component-parent-pathname (component) ;; No default anymore (in particular, no *default-pathname-defaults*). ;; If you force component to have a NULL pathname, you better arrange ;; for any of its children to explicitly provide a proper absolute pathname ;; wherever a pathname is actually wanted. (let ((parent (component-parent component))) (when parent (component-pathname parent)))) (defmethod component-pathname ((component component)) (if (slot-boundp component 'absolute-pathname) (slot-value component 'absolute-pathname) (let ((pathname (merge-pathnames* (component-relative-pathname component) (pathname-directory-pathname (component-parent-pathname component))))) (unless (or (null pathname) (absolute-pathname-p pathname)) (error "Invalid relative pathname ~S for component ~S" pathname (component-find-path component))) (setf (slot-value component 'absolute-pathname) pathname) pathname))) (defmethod component-property ((c component) property) (cdr (assoc property (slot-value c 'properties) :test #'equal))) (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))))) new-value) (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) (source-file :reader system-source-file :initarg :source-file :writer %set-system-source-file))) ;;;; ------------------------------------------------------------------------- ;;;; version-satisfies (defmethod version-satisfies ((c component) version) (unless (and version (slot-boundp c 'version)) (return-from version-satisfies t)) (version-satisfies (component-version c) version)) (defmethod version-satisfies ((cver string) version) (let ((x (mapcar #'parse-integer (split-string cver :separator "."))) (y (mapcar #'parse-integer (split-string version :separator ".")))) (labels ((bigger (x y) (cond ((not y) t) ((not x) nil) ((> (car x) (car y)) t) ((= (car x) (car y)) (bigger (cdr x) (cdr y)))))) (and (= (car x) (car y)) (or (not (cdr y)) (bigger (cdr x) (cdr y))))))) ;;;; ------------------------------------------------------------------------- ;;;; Finding systems (defun* make-defined-systems-table () (make-hash-table :test 'equal)) (defvar *defined-systems* (make-defined-systems-table) "This is a hash table whose keys are strings, being the names of the systems, and whose values are pairs, the first element of which is a universal-time indicating when the system definition was last updated, and the second element of which is a system object.") (defun* coerce-name (name) (typecase name (component (component-name name)) (symbol (string-downcase (symbol-name name))) (string name) (t (sysdef-error "~@" name)))) (defun* system-registered-p (name) (gethash (coerce-name name) *defined-systems*)) (defun* clear-system (name) "Clear the entry for a system in the database of systems previously loaded. Note that this does NOT in any way cause the code of the system to be unloaded." ;; There is no "unload" operation in Common Lisp, and a general such operation ;; cannot be portably written, considering how much CL relies on side-effects ;; of global data structures. ;; Note that this does a setf gethash instead of a remhash ;; this way there remains a hint in the *defined-systems* table ;; that the system was loaded at some point. (setf (gethash (coerce-name name) *defined-systems*) nil)) (defun* map-systems (fn) "Apply FN to each defined system. FN should be a function of one argument. It will be called with an object of type asdf:system." (maphash (lambda (_ datum) (declare (ignore _)) (destructuring-bind (_ . def) datum (declare (ignore _)) (funcall fn def))) *defined-systems*)) ;;; for the sake of keeping things reasonably neat, we adopt a ;;; convention that functions in this list are prefixed SYSDEF- (defparameter *system-definition-search-functions* '(sysdef-central-registry-search sysdef-source-registry-search sysdef-find-asdf)) (defun* system-definition-pathname (system) (let ((system-name (coerce-name system))) (or (some (lambda (x) (funcall x system-name)) *system-definition-search-functions*) (let ((system-pair (system-registered-p system-name))) (and system-pair (system-source-file (cdr system-pair))))))) (defvar *central-registry* nil "A list of 'system directory designators' ASDF uses to find systems. A 'system directory designator' is a pathname or an expression which evaluates to a pathname. For example: (setf asdf:*central-registry* (list '*default-pathname-defaults* #p\"/home/me/cl/systems/\" #p\"/usr/share/common-lisp/systems/\")) This is for backward compatibilily. Going forward, we recommend new users should be using the source-registry. ") (defun* probe-asd (name defaults) (block nil (when (directory-pathname-p defaults) (let ((file (make-pathname :defaults defaults :version :newest :case :local :name name :type "asd"))) (when (probe-file file) (return file))) #+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp)) (let ((shortcut (make-pathname :defaults defaults :version :newest :case :local :name (concatenate 'string name ".asd") :type "lnk"))) (when (probe-file shortcut) (let ((target (parse-windows-shortcut shortcut))) (when target (return (pathname target))))))))) (defun* sysdef-central-registry-search (system) (let ((name (coerce-name system)) (to-remove nil) (to-replace nil)) (block nil (unwind-protect (dolist (dir *central-registry*) (let ((defaults (eval dir))) (when defaults (cond ((directory-pathname-p defaults) (let ((file (probe-asd name defaults))) (when file (return file)))) (t (restart-case (let* ((*print-circle* nil) (message (format nil "~@" system dir defaults))) (error message)) (remove-entry-from-registry () :report "Remove entry from *central-registry* and continue" (push dir to-remove)) (coerce-entry-to-directory () :report (lambda (s) (format s "Coerce entry to ~a, replace ~a and continue." (ensure-directory-pathname defaults) dir)) (push (cons dir (ensure-directory-pathname defaults)) to-replace)))))))) ;; cleanup (dolist (dir to-remove) (setf *central-registry* (remove dir *central-registry*))) (dolist (pair to-replace) (let* ((current (car pair)) (new (cdr pair)) (position (position current *central-registry*))) (setf *central-registry* (append (subseq *central-registry* 0 position) (list new) (subseq *central-registry* (1+ position)))))))))) (defun* make-temporary-package () (flet ((try (counter) (ignore-errors (make-package (format nil "~A~D" :asdf counter) :use '(:cl :asdf))))) (do* ((counter 0 (+ counter 1)) (package (try counter) (try counter))) (package package)))) (defun* safe-file-write-date (pathname) ;; If FILE-WRITE-DATE returns NIL, it's possible that ;; the user or some other agent has deleted an input file. ;; Also, generated files will not exist at the time planning is done ;; and calls operation-done-p which calls safe-file-write-date. ;; So it is very possible that we can't get a valid file-write-date, ;; and we can survive and we will continue the planning ;; as if the file were very old. ;; (or should we treat the case in a different, special way?) (or (and pathname (probe-file pathname) (file-write-date pathname)) (progn (when (and pathname *asdf-verbose*) (warn "Missing FILE-WRITE-DATE for ~S: treating it as zero." pathname)) 0))) (defmethod find-system (name &optional (error-p t)) (find-system (coerce-name name) error-p)) (defmethod find-system ((name string) &optional (error-p t)) (catch 'find-system (let* ((in-memory (system-registered-p name)) (on-disk (system-definition-pathname name))) (when (and on-disk (or (not in-memory) (< (car in-memory) (safe-file-write-date on-disk)))) (let ((package (make-temporary-package))) (unwind-protect (handler-bind ((error (lambda (condition) (error 'load-system-definition-error :name name :pathname on-disk :condition condition)))) (let ((*package* package)) (asdf-message "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%" on-disk *package*) (load on-disk))) (delete-package package)))) (let ((in-memory (system-registered-p name))) (cond (in-memory (when on-disk (setf (car in-memory) (safe-file-write-date on-disk))) (cdr in-memory)) (error-p (error 'missing-component :requires name))))))) (defun* register-system (name system) (asdf-message "~&~@<; ~@;registering ~A as ~A~@:>~%" system name) (setf (gethash (coerce-name name) *defined-systems*) (cons (get-universal-time) system))) (defun* find-system-fallback (requested fallback &optional source-file) (setf fallback (coerce-name fallback) source-file (or source-file *compile-file-truename* *load-truename*) requested (coerce-name requested)) (when (equal requested fallback) (let* ((registered (cdr (gethash fallback *defined-systems*))) (system (or registered (make-instance 'system :name fallback :source-file source-file)))) (unless registered (register-system fallback system)) (throw 'find-system system)))) (defun* sysdef-find-asdf (name) (find-system-fallback name "asdf")) ;;;; ------------------------------------------------------------------------- ;;;; Finding components (defmethod find-component ((base string) path) (let ((s (find-system base nil))) (and s (find-component s path)))) (defmethod find-component ((base symbol) path) (cond (base (find-component (coerce-name base) path)) (path (find-component path nil)) (t nil))) (defmethod find-component ((base cons) path) (find-component (car base) (cons (cdr base) path))) (defmethod find-component ((module module) (name string)) (unless (slot-boundp module 'components-by-name) ;; SBCL may miss the u-i-f-r-c method!!! (compute-module-components-by-name module)) (values (gethash name (module-components-by-name module)))) (defmethod find-component ((component component) (name symbol)) (if name (find-component component (coerce-name name)) component)) (defmethod find-component ((module module) (name cons)) (find-component (find-component module (car name)) (cdr name))) ;;; component subclasses (defclass source-file (component) ((type :accessor source-file-explicit-type :initarg :type :initform nil))) (defclass cl-source-file (source-file) ((type :initform "lisp"))) (defclass c-source-file (source-file) ((type :initform "c"))) (defclass java-source-file (source-file) ((type :initform "java"))) (defclass static-file (source-file) ()) (defclass doc-file (static-file) ()) (defclass html-file (doc-file) ((type :initform "html"))) (defmethod source-file-type ((component module) (s module)) (declare (ignorable component s)) :directory) (defmethod source-file-type ((component source-file) (s module)) (declare (ignorable s)) (source-file-explicit-type component)) (defun* merge-component-name-type (name &key type defaults) ;; The defaults are required notably because they provide the default host ;; to the below make-pathname, which may crucially matter to people using ;; merge-pathnames with non-default hosts, e.g. for logical-pathnames. ;; NOTE that the host and device slots will be taken from the defaults, ;; but that should only matter if you either (a) use absolute pathnames, or ;; (b) later merge relative pathnames with CL:MERGE-PATHNAMES instead of ;; ASDF:MERGE-PATHNAMES* (etypecase name (pathname name) (symbol (merge-component-name-type (string-downcase name) :type type :defaults defaults)) (string (multiple-value-bind (relative path filename) (component-name-to-pathname-components name (eq type :directory)) (multiple-value-bind (name type) (cond ((or (eq type :directory) (null filename)) (values nil nil)) (type (values filename type)) (t (split-name-type filename))) (let* ((defaults (pathname (or defaults *default-pathname-defaults*))) (host (pathname-host defaults)) (device (pathname-device defaults))) (make-pathname :directory `(,relative ,@path) :name name :type type :host host :device device))))))) (defmethod component-relative-pathname ((component component)) (merge-component-name-type (or (slot-value component 'relative-pathname) (component-name component)) :type (source-file-type component (component-system component)) :defaults (component-parent-pathname component))) ;;;; ------------------------------------------------------------------------- ;;;; Operations ;;; one of these is instantiated whenever #'operate is called (defclass operation () ( ;; as of danb's 2003-03-16 commit e0d02781, :force can be: ;; T to force the inside of existing system, ;; but not recurse to other systems we depend on. ;; :ALL (or any other atom) to force all systems ;; including other systems we depend on. ;; (SYSTEM1 SYSTEM2 ... SYSTEMN) ;; to force systems named in a given list ;; However, but this feature never worked before ASDF 1.700 and is currently cerror'ed out. (forced :initform nil :initarg :force :accessor operation-forced) (original-initargs :initform nil :initarg :original-initargs :accessor operation-original-initargs) (visited-nodes :initform (make-hash-table :test 'equal) :accessor operation-visited-nodes) (visiting-nodes :initform (make-hash-table :test 'equal) :accessor operation-visiting-nodes) (parent :initform nil :initarg :parent :accessor operation-parent))) (defmethod print-object ((o operation) stream) (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 (ignorable operation slot-names force)) ;; empty method to disable initarg validity checking (values)) (defun* node-for (o c) (cons (class-name (class-of o)) c)) (defmethod operation-ancestor ((operation operation)) (aif (operation-parent operation) (operation-ancestor it) operation)) (defun* make-sub-operation (c o dep-c dep-o) "C is a component, O is an operation, DEP-C is another component, and DEP-O, confusingly enough, is an operation class specifier, not an operation." (let* ((args (copy-list (operation-original-initargs o))) (force-p (getf args :force))) ;; 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))))) (defmethod visit-component ((o operation) (c component) data) (unless (component-visited-p o c) (setf (gethash (node-for o c) (operation-visited-nodes (operation-ancestor o))) (cons t data)))) (defmethod component-visited-p ((o operation) (c component)) (gethash (node-for o c) (operation-visited-nodes (operation-ancestor o)))) (defmethod (setf visiting-component) (new-value operation component) ;; MCL complains about unused lexical variables (declare (ignorable operation component)) new-value) (defmethod (setf visiting-component) (new-value (o operation) (c component)) (let ((node (node-for o c)) (a (operation-ancestor o))) (if new-value (setf (gethash node (operation-visiting-nodes a)) t) (remhash node (operation-visiting-nodes a))) new-value)) (defmethod component-visiting-p ((o operation) (c component)) (let ((node (node-for o c))) (gethash node (operation-visiting-nodes (operation-ancestor o))))) (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)) (component-in-order-to c)))) (defmethod component-self-dependencies ((o operation) (c component)) (let ((all-deps (component-depends-on o c))) (remove-if-not (lambda (x) (member (component-name c) (cdr x) :test #'string=)) all-deps))) (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)) (declare (ignorable operation c)) nil) (defmethod component-operation-time (o c) (gethash (type-of o) (component-operation-times c))) (defmethod operation-done-p ((o operation) (c component)) (let ((out-files (output-files o c)) (in-files (input-files o c)) (op-time (component-operation-time o c))) (flet ((earliest-out () (reduce #'min (mapcar #'safe-file-write-date out-files))) (latest-in () (reduce #'max (mapcar #'safe-file-write-date in-files)))) (cond ((and (not in-files) (not out-files)) ;; arbitrary decision: an operation that uses nothing to ;; produce nothing probably isn't doing much. ;; e.g. operations on systems, modules that have no immediate action, ;; but are only meaningful through traversed dependencies t) ((not out-files) ;; an operation without output-files is probably meant ;; for its side-effects in the current image, ;; assumed to be idem-potent, ;; e.g. LOAD-OP or LOAD-SOURCE-OP of some CL-SOURCE-FILE. (and op-time (>= op-time (latest-in)))) ((not in-files) ;; an operation without output-files and no input-files ;; is probably meant for its side-effects on the file-system, ;; assumed to have to be done everytime. ;; (I don't think there is any such case in ASDF unless extended) nil) (t ;; an operation with both input and output files is assumed ;; as computing the latter from the former, ;; assumed to have been done if the latter are all older ;; than the former. ;; e.g. COMPILE-OP of some CL-SOURCE-FILE. ;; We use >= instead of > to play nice with generated files. ;; This opens a race condition if an input file is changed ;; after the output is created but within the same second ;; of filesystem time; but the same race condition exists ;; whenever the computation from input to output takes more ;; than one second of filesystem time (or just crosses the ;; second). So that's cool. (and (every #'probe-file in-files) (every #'probe-file out-files) (>= (earliest-out) (latest-in)))))))) ;;; For 1.700 I've done my best to refactor TRAVERSE ;;; by splitting it up in a bunch of functions, ;;; so as to improve the collection and use-detection algorithm. --fare ;;; The protocol is as follows: we pass around operation, dependency, ;;; bunch of other stuff, and a force argument. Return a force flag. ;;; The returned flag is T if anything has changed that requires a rebuild. ;;; The force argument is a list of components that will require a rebuild ;;; if the flag is T, at which point whoever returns the flag has to ;;; mark them all as forced, and whoever recurses again can use a NIL list ;;; as a further argument. (defvar *forcing* nil "This dynamically-bound variable is used to force operations in recursive calls to traverse.") (defgeneric* do-traverse (operation component collect)) (defun* %do-one-dep (operation c collect required-op required-c required-v) ;; collects a partial plan that results from performing required-op ;; on required-c, possibly with a required-vERSION (let* ((dep-c (or (let ((d (find-component (component-parent c) required-c))) (and d (version-satisfies d required-v) d)) (if required-v (error 'missing-dependency-of-version :required-by c :version required-v :requires required-c) (error 'missing-dependency :required-by c :requires required-c)))) (op (make-sub-operation c operation dep-c required-op))) (do-traverse op dep-c collect))) (defun* do-one-dep (operation c collect required-op required-c required-v) ;; this function is a thin, error-handling wrapper around ;; %do-one-dep. Returns a partial plan per that function. (loop (restart-case (return (%do-one-dep operation c collect required-op required-c required-v)) (retry () :report (lambda (s) (format s "~@" (component-find-path required-c))) :test (lambda (c) #| (print (list :c1 c (typep c 'missing-dependency))) (when (typep c 'missing-dependency) (print (list :c2 (missing-requires c) required-c (equalp (missing-requires c) required-c)))) |# (or (null c) (and (typep c 'missing-dependency) (equalp (missing-requires c) required-c)))))))) (defun* do-dep (operation c collect op dep) ;; type of arguments uncertain: ;; op seems to at least potentially be a symbol, rather than an operation ;; dep is a list of component names (cond ((eq op 'feature) (if (member (car dep) *features*) nil (error 'missing-dependency :required-by c :requires (car dep)))) (t (let ((flag nil)) (flet ((dep (op comp ver) (when (do-one-dep operation c collect op comp ver) (setf flag t)))) (dolist (d dep) (if (atom d) (dep op d nil) ;; structured dependencies --- this parses keywords ;; the keywords could be broken out and cleanly (extensibly) ;; processed by EQL methods (cond ((eq :version (first d)) ;; https://bugs.launchpad.net/asdf/+bug/527788 (dep op (second d) (third d))) ;; This particular subform is not documented and ;; has always been broken in the past. ;; Therefore no one uses it, and I'm cerroring it out, ;; after fixing it ;; See https://bugs.launchpad.net/asdf/+bug/518467 ((eq :feature (first d)) (cerror "Continue nonetheless." "Congratulations, you're the first ever user of FEATURE dependencies! Please contact the asdf-devel mailing-list.") (when (find (second d) *features* :test 'string-equal) (dep op (third d) nil))) (t (error "Bad dependency ~a. Dependencies must be (:version ), (:feature [version]), or a name" d)))))) flag)))) (defvar *visit-count* 0) ; counter that allows to sort nodes from operation-visited-nodes (defun* do-collect (collect x) (funcall collect x)) (defmethod do-traverse ((operation operation) (c component) collect) (let ((flag nil)) ;; return value: must we rebuild this and its dependencies? (labels ((update-flag (x) (when x (setf flag t))) (dep (op comp) (update-flag (do-dep operation c collect op comp)))) ;; Have we been visited yet? If so, just process the result. (aif (component-visited-p operation c) (progn (update-flag (cdr it)) (return-from do-traverse flag))) ;; dependencies (when (component-visiting-p operation c) (error 'circular-dependency :components (list c))) (setf (visiting-component operation c) t) (unwind-protect (progn ;; first we check and do all the dependencies for the module. ;; Operations planned in this loop will show up ;; in the results, and are consumed below. (let ((*forcing* nil)) ;; upstream dependencies are never forced to happen just because ;; the things that depend on them are.... (loop :for (required-op . deps) :in (component-depends-on operation c) :do (dep required-op deps))) ;; constituent bits (let ((module-ops (when (typep c 'module) (let ((at-least-one nil) ;; This is set based on the results of the ;; dependencies and whether we are in the ;; context of a *forcing* call... ;; inter-system dependencies do NOT trigger ;; building components (*forcing* (or *forcing* (and flag (not (typep c 'system))))) (error nil)) (while-collecting (internal-collect) (dolist (kid (module-components c)) (handler-case (update-flag (do-traverse operation kid #'internal-collect)) (missing-dependency (condition) (when (eq (module-if-component-dep-fails c) :fail) (error condition)) (setf error condition)) (:no-error (c) (declare (ignore c)) (setf at-least-one t)))) (when (and (eq (module-if-component-dep-fails c) :try-next) (not at-least-one)) (error error))))))) (update-flag (or *forcing* (not (operation-done-p operation c)) ;; For sub-operations, check whether ;; the original ancestor operation was forced, ;; or names us amongst an explicit list of things to force... ;; except that this check doesn't distinguish ;; between all the things with a given name. Sigh. ;; BROKEN! (let ((f (operation-forced (operation-ancestor operation)))) (and f (or (not (consp f)) ;; T or :ALL (and (typep c 'system) ;; list of names of systems to force (member (component-name c) f :test #'string=))))))) (when flag (let ((do-first (cdr (assoc (class-name (class-of operation)) (component-do-first c))))) (loop :for (required-op . deps) :in do-first :do (do-dep operation c collect required-op deps))) (do-collect collect (vector module-ops)) (do-collect collect (cons operation c))))) (setf (visiting-component operation c) nil))) (visit-component operation c (when flag (incf *visit-count*))) flag)) (defun* flatten-tree (l) ;; You collected things into a list. ;; Most elements are just things to collect again. ;; A (simple-vector 1) indicate that you should recurse into its contents. ;; This way, in two passes (rather than N being the depth of the tree), ;; you can collect things with marginally constant-time append, ;; achieving linear time collection instead of quadratic time. (while-collecting (c) (labels ((r (x) (if (typep x '(simple-vector 1)) (r* (svref x 0)) (c x))) (r* (l) (dolist (x l) (r x)))) (r* l)))) (defmethod traverse ((operation operation) (c component)) ;; cerror'ing a feature that seems to have NEVER EVER worked ;; ever since danb created it in his 2003-03-16 commit e0d02781. ;; It was both fixed and disabled in the 1.700 rewrite. (when (consp (operation-forced operation)) (cerror "Continue nonetheless." "Congratulations, you're the first ever user of the :force (list of system names) feature! Please contact the asdf-devel mailing-list to collect a cookie.") (setf (operation-forced operation) (mapcar #'coerce-name (operation-forced operation)))) (flatten-tree (while-collecting (collect) (let ((*visit-count* 0)) (do-traverse operation c #'collect))))) (defmethod perform ((operation operation) (c source-file)) (sysdef-error "~@" (class-of operation) (class-of c))) (defmethod perform ((operation operation) (c module)) (declare (ignorable operation c)) nil) (defmethod explain ((operation operation) (component component)) (asdf-message "~&;;; ~A~%" (operation-description operation component))) (defmethod operation-description (operation component) (format nil "~A on component ~S" (class-of operation) (component-find-path component))) ;;;; ------------------------------------------------------------------------- ;;;; compile-op (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*) (flags :initarg :flags :accessor compile-op-flags :initform #-ecl nil #+ecl '(:system-p t)))) (defun output-file (operation component) "The unique output file of performing OPERATION on COMPONENT" (let ((files (output-files operation component))) (assert (length=n-p files 1)) (first files))) (defmethod perform :before ((operation compile-op) (c source-file)) (map nil #'ensure-directories-exist (output-files operation c))) #+ecl (defmethod perform :after ((o compile-op) (c cl-source-file)) ;; Note how we use OUTPUT-FILES to find the binary locations ;; This allows the user to override the names. (let* ((files (output-files o c)) (object (first files)) (fasl (second files))) (c:build-fasl fasl :lisp-files (list object)))) (defmethod perform :after ((operation operation) (c component)) (setf (gethash (type-of operation) (component-operation-times c)) (get-universal-time))) (declaim (ftype (function ((or pathname string) &rest t &key &allow-other-keys) (values t t t)) compile-file*)) ;;; perform is required to check output-files to find out where to put ;;; its answers, in case it has been overridden for site policy (defmethod perform ((operation compile-op) (c cl-source-file)) #-:broken-fasl-loader (let ((source-file (component-pathname c)) ;; on some implementations, there are more than one output-file, ;; but the first one should always be the primary fasl that gets loaded. (output-file (first (output-files operation c))) (*compile-file-warnings-behaviour* (operation-on-warnings operation)) (*compile-file-failure-behaviour* (operation-on-failure operation))) (multiple-value-bind (output warnings-p failure-p) (apply #'compile-file* source-file :output-file output-file (compile-op-flags operation)) (when warnings-p (case (operation-on-warnings operation) (:warn (warn "~@" operation c)) (:error (error 'compile-warned :component c :operation operation)) (:ignore nil))) (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)) (declare (ignorable operation)) (let ((p (lispize-pathname (component-pathname c)))) #-:broken-fasl-loader (list (compile-file-pathname p #+ecl :type #+ecl :object) #+ecl (compile-file-pathname p :type :fasl)) #+:broken-fasl-loader (list p))) (defmethod perform ((operation compile-op) (c static-file)) (declare (ignorable operation c)) nil) (defmethod output-files ((operation compile-op) (c static-file)) (declare (ignorable operation c)) nil) (defmethod input-files ((operation compile-op) (c static-file)) (declare (ignorable operation c)) nil) (defmethod operation-description ((operation compile-op) component) (declare (ignorable operation)) (format nil "compiling component ~S" (component-find-path component))) ;;;; ------------------------------------------------------------------------- ;;;; load-op (defclass basic-load-op (operation) ()) (defclass load-op (basic-load-op) ()) (defmethod perform ((o load-op) (c cl-source-file)) #-ecl (mapcar #'load (input-files o c)) #+ecl (loop :for i :in (input-files o c) :unless (string= (pathname-type i) "fas") :collect (let ((output (compile-file-pathname (lispize-pathname i)))) (load output)))) (defmethod perform-with-restarts (operation component) (perform operation component)) (defmethod perform-with-restarts ((o load-op) (c cl-source-file)) (declare (ignorable o)) (loop :with state = :initial :until (or (eq state :success) (eq state :failure)) :do (case state (:recompiled (setf state :failure) (call-next-method) (setf state :success)) (:failed-load (setf state :recompiled) (perform (make-instance 'compile-op) c)) (t (with-simple-restart (try-recompiling "Recompile ~a and try loading it again" (component-name c)) (setf state :failed-load) (call-next-method) (setf state :success)))))) (defmethod perform-with-restarts ((o compile-op) (c cl-source-file)) (loop :with state = :initial :until (or (eq state :success) (eq state :failure)) :do (case state (:recompiled (setf state :failure) (call-next-method) (setf state :success)) (:failed-compile (setf state :recompiled) (perform-with-restarts o c)) (t (with-simple-restart (try-recompiling "Try recompiling ~a" (component-name c)) (setf state :failed-compile) (call-next-method) (setf state :success)))))) (defmethod perform ((operation load-op) (c static-file)) (declare (ignorable operation c)) nil) (defmethod operation-done-p ((operation load-op) (c static-file)) (declare (ignorable operation c)) t) (defmethod output-files ((operation operation) (c component)) (declare (ignorable operation c)) nil) (defmethod component-depends-on ((operation load-op) (c component)) (declare (ignorable operation)) (cons (list 'compile-op (component-name c)) (call-next-method))) (defmethod operation-description ((operation load-op) component) (declare (ignorable operation)) (format nil "loading component ~S" (component-find-path component))) ;;;; ------------------------------------------------------------------------- ;;;; load-source-op (defclass load-source-op (basic-load-op) ()) (defmethod perform ((o load-source-op) (c cl-source-file)) (declare (ignorable o)) (let ((source (component-pathname c))) (setf (component-property c 'last-loaded-as-source) (and (load source) (get-universal-time))))) (defmethod perform ((operation load-source-op) (c static-file)) (declare (ignorable operation c)) nil) (defmethod output-files ((operation load-source-op) (c component)) (declare (ignorable operation c)) nil) ;;; FIXME: we simply copy load-op's dependencies. this is Just Not Right. (defmethod component-depends-on ((o load-source-op) (c component)) (declare (ignorable o)) (let ((what-would-load-op-do (cdr (assoc 'load-op (component-in-order-to c))))) (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)) (declare (ignorable o)) (if (or (not (component-property c 'last-loaded-as-source)) (> (safe-file-write-date (component-pathname c)) (component-property c 'last-loaded-as-source))) nil t)) (defmethod operation-description ((operation load-source-op) component) (declare (ignorable operation)) (format nil "loading component ~S" (component-find-path component))) ;;;; ------------------------------------------------------------------------- ;;;; test-op (defclass test-op (operation) ()) (defmethod perform ((operation test-op) (c component)) (declare (ignorable operation c)) nil) (defmethod operation-done-p ((operation test-op) (c system)) "Testing a system is _never_ done." (declare (ignorable operation c)) nil) (defmethod component-depends-on :around ((o test-op) (c system)) (declare (ignorable o)) (cons `(load-op ,(component-name c)) (call-next-method))) ;;;; ------------------------------------------------------------------------- ;;;; Invoking Operations (defgeneric* operate (operation-class system &key &allow-other-keys)) (defmethod operate (operation-class system &rest args &key ((:verbose *asdf-verbose*) *asdf-verbose*) version force &allow-other-keys) (declare (ignore force)) (let* ((*package* *package*) (*readtable* *readtable*) (op (apply #'make-instance operation-class :original-initargs args args)) (*verbose-out* (if *asdf-verbose* *standard-output* (make-broadcast-stream))) (system (if (typep system 'component) system (find-system system)))) (unless (version-satisfies system version) (error 'missing-component-of-version :requires system :version version)) (let ((steps (traverse op system))) (with-compilation-unit () (loop :for (op . component) :in steps :do (loop (restart-case (progn (perform-with-restarts op component) (return)) (retry () :report (lambda (s) (format s "~@" (operation-description op component)))) (accept () :report (lambda (s) (format s "~@" (operation-description op component))) (setf (gethash (type-of op) (component-operation-times component)) (get-universal-time)) (return)))))) (values op steps)))) (defun* oos (operation-class system &rest args &key force verbose version &allow-other-keys) (declare (ignore force verbose version)) (apply #'operate operation-class system args)) (let ((operate-docstring "Operate does three things: 1. It creates an instance of OPERATION-CLASS using any keyword parameters as initargs. 2. It finds the asdf-system specified by SYSTEM (possibly loading it from disk). 3. It then calls TRAVERSE with the operation and system as arguments The traverse operation is wrapped in WITH-COMPILATION-UNIT and error handling code. If a VERSION argument is supplied, then operate also ensures that the system found satisfies it using the VERSION-SATISFIES method. Note that dependencies may cause the operation to invoke other operations on the system or its components: the new operations will be created with the same initargs as the original one. ")) (setf (documentation 'oos 'function) (format nil "Short for _operate on system_ and an alias for the OPERATE function. ~&~&~a" operate-docstring)) (setf (documentation 'operate 'function) operate-docstring)) (defun* load-system (system &rest args &key force verbose version &allow-other-keys) "Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for details." (declare (ignore force verbose version)) (apply #'operate 'load-op system args)) (defun* compile-system (system &rest args &key force verbose version &allow-other-keys) "Shorthand for `(operate 'asdf:compile-op system)`. See OPERATE for details." (declare (ignore force verbose version)) (apply #'operate 'compile-op system args)) (defun* test-system (system &rest args &key force verbose version &allow-other-keys) "Shorthand for `(operate 'asdf:test-op system)`. See OPERATE for details." (declare (ignore force verbose version)) (apply #'operate 'test-op system args)) ;;;; ------------------------------------------------------------------------- ;;;; Defsystem (defun* load-pathname () (let ((pn (or *load-pathname* *compile-file-pathname*))) (if *resolve-symlinks* (and pn (resolve-symlinks pn)) pn))) (defun* determine-system-pathname (pathname pathname-supplied-p) ;; The defsystem macro calls us to determine ;; the pathname of a system as follows: ;; 1. the one supplied, ;; 2. derived from *load-pathname* via load-pathname ;; 3. taken from the *default-pathname-defaults* via default-directory (let* ((file-pathname (load-pathname)) (directory-pathname (and file-pathname (pathname-directory-pathname file-pathname)))) (or (and pathname-supplied-p (merge-pathnames* pathname directory-pathname)) directory-pathname (default-directory)))) (defmacro defsystem (name &body options) (destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system) defsystem-depends-on &allow-other-keys) options (let ((component-options (remove-keys '(:defsystem-depends-on :class) options))) `(progn ;; system must be registered before we parse the body, otherwise ;; we recur when trying to find an existing system of the same name ;; to reuse options (e.g. pathname) from ,@(loop :for system :in defsystem-depends-on :collect `(load-system ,system)) (let ((s (system-registered-p ',name))) (cond ((and s (eq (type-of (cdr s)) ',class)) (setf (car s) (get-universal-time))) (s (change-class (cdr s) ',class)) (t (register-system (quote ,name) (make-instance ',class :name ',name)))) (%set-system-source-file (load-pathname) (cdr (system-registered-p ',name)))) (parse-component-form nil (list* :module (coerce-name ',name) :pathname ,(determine-system-pathname pathname pathname-arg-p) ',component-options)))))) (defun* class-for-type (parent type) (or (loop :for symbol :in (list (unless (keywordp type) type) (find-symbol (symbol-name type) *package*) (find-symbol (symbol-name type) :asdf)) :for class = (and symbol (find-class symbol nil)) :when (and class (subtypep class 'component)) :return class) (and (eq type :file) (or (module-default-component-class parent) (find-class *default-component-class*))) (sysdef-error "~@" type))) (defun* maybe-add-tree (tree op1 op2 c) "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)) (defvar *serial-depends-on* nil) (defun* sysdef-error-component (msg type name value) (sysdef-error (concatenate 'string msg "~&The value specified for ~(~A~) ~A is ~S") type name value)) (defun* check-component-input (type name weakly-depends-on depends-on components in-order-to) "A partial test of the values of a component." (unless (listp depends-on) (sysdef-error-component ":depends-on must be a list." type name depends-on)) (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* %remove-component-inline-methods (component) (dolist (name +asdf-methods+) (map () ;; this is inefficient as most of the stored ;; methods will not be for this particular gf ;; But this is hardly performance-critical (lambda (m) (remove-method (symbol-function name) m)) (component-inline-methods component))) ;; clear methods, then add the new ones (setf (component-inline-methods component) nil)) (defun* %define-component-inline-methods (ret rest) (dolist (name +asdf-methods+) (let ((keyword (intern (symbol-name name) :keyword))) (loop :for data = rest :then (cddr data) :for key = (first data) :for value = (second data) :while data :when (eq key keyword) :do (destructuring-bind (op qual (o c) &body body) value (pushnew (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret))) ,@body)) (component-inline-methods ret))))))) (defun* %refresh-component-inline-methods (component rest) (%remove-component-inline-methods component) (%define-component-inline-methods component rest)) (defun* parse-component-form (parent options) (destructuring-bind (type name &rest rest &key ;; the following list of keywords is reproduced below in the ;; remove-keys form. important to keep them in sync components pathname default-component-class perform explain output-files operation-done-p weakly-depends-on depends-on serial in-order-to ;; list ends &allow-other-keys) options (declare (ignorable perform explain output-files operation-done-p)) (check-component-input type name weakly-depends-on depends-on components in-order-to) (when (and parent (find-component parent name) ;; ignore the same object when rereading the defsystem (not (typep (find-component parent name) (class-for-type parent type)))) (error 'duplicate-names :name name)) (let* ((other-args (remove-keys '(components pathname default-component-class perform explain output-files operation-done-p weakly-depends-on depends-on serial in-order-to) rest)) (ret (or (find-component parent name) (make-instance (class-for-type parent type))))) (when weakly-depends-on (appendf depends-on (remove-if (complement #'find-system) weakly-depends-on))) (when *serial-depends-on* (push *serial-depends-on* depends-on)) (apply #'reinitialize-instance ret :name (coerce-name name) :pathname pathname :parent parent other-args) (component-pathname ret) ; eagerly compute the absolute pathname (when (typep ret 'module) (setf (module-default-component-class ret) (or default-component-class (and (typep parent 'module) (module-default-component-class parent)))) (let ((*serial-depends-on* nil)) (setf (module-components ret) (loop :for c-form :in components :for c = (parse-component-form ret c-form) :for name = (component-name c) :collect c :when serial :do (setf *serial-depends-on* name)))) (compute-module-components-by-name ret)) (setf (component-load-dependencies ret) depends-on) ;; Used by POIU (setf (component-in-order-to ret) (union-of-dependencies in-order-to `((compile-op (compile-op ,@depends-on)) (load-op (load-op ,@depends-on))))) (setf (component-do-first ret) `((compile-op (load-op ,@depends-on)))) (%refresh-component-inline-methods ret rest) ret))) ;;;; --------------------------------------------------------------------------- ;;;; run-shell-command ;;;; ;;;; run-shell-command functions for other lisp implementations will be ;;;; gratefully accepted, if they do the same thing. ;;;; If the docstring is ambiguous, send a bug report. ;;;; ;;;; We probably should move this functionality to its own system and deprecate ;;;; use of it from the asdf package. However, this would break unspecified ;;;; existing software, so until a clear alternative exists, we can't deprecate ;;;; it, and even after it's been deprecated, we will support it for a few ;;;; years so everyone has time to migrate away from it. -- fare 2009-12-01 (defun* run-shell-command (control-string &rest args) "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))) (asdf-message "; $ ~A~%" command) #+abcl (ext:run-shell-command command :output *verbose-out*) #+allegro ;; will this fail if command has embedded quotes - it seems to work (multiple-value-bind (stdout stderr exit-code) (excl.osi:command-output (format nil "~a -c \"~a\"" #+mswindows "sh" #-mswindows "/bin/sh" command) :input nil :whole nil #+mswindows :show-window #+mswindows :hide) (format *verbose-out* "~{~&; ~a~%~}~%" stderr) (format *verbose-out* "~{~&; ~a~%~}~%" stdout) exit-code) #+clisp ;XXX not exactly *verbose-out*, I know (ext:run-shell-command command :output :terminal :wait t) #+clozure (nth-value 1 (ccl:external-process-status (ccl:run-program "/bin/sh" (list "-c" command) :input nil :output *verbose-out* :wait t))) #+ecl ;; courtesy of Juan Jose Garcia Ripoll (si:system command) #+gcl (lisp:system command) #+lispworks (system:call-system-showing-output command :shell-type "/bin/sh" :show-cmd nil :prefix "" :output-stream *verbose-out*) #+sbcl (sb-ext:process-exit-code (apply #'sb-ext:run-program #+win32 "sh" #-win32 "/bin/sh" (list "-c" command) :input nil :output *verbose-out* #+win32 '(:search t) #-win32 nil)) #+(or cmu scl) (ext:process-exit-code (ext:run-program "/bin/sh" (list "-c" command) :input nil :output *verbose-out*)) #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl) (error "RUN-SHELL-COMMAND not implemented for this Lisp"))) ;;;; --------------------------------------------------------------------------- ;;;; system-relative-pathname (defmethod system-source-file ((system-name string)) (system-source-file (find-system system-name))) (defmethod system-source-file ((system-name symbol)) (system-source-file (find-system system-name))) (defun* system-source-directory (system-designator) "Return a pathname object corresponding to the directory in which the system specification (.asd file) is located." (make-pathname :name nil :type nil :defaults (system-source-file system-designator))) (defun* relativize-directory (directory) (cond ((stringp directory) (list :relative directory)) ((eq (car directory) :absolute) (cons :relative (cdr directory))) (t directory))) (defun* relativize-pathname-directory (pathspec) (let ((p (pathname pathspec))) (make-pathname :directory (relativize-directory (pathname-directory p)) :defaults p))) (defun* system-relative-pathname (system name &key type) (merge-pathnames* (merge-component-name-type name :type type) (system-source-directory system))) ;;; --------------------------------------------------------------------------- ;;; implementation-identifier ;;; ;;; produce a string to identify current implementation. ;;; Initially stolen from SLIME's SWANK, hacked since. (defparameter *implementation-features* '(:allegro :lispworks :sbcl :clozure :digitool :cmu :clisp :corman :cormanlisp :armedbear :gcl :ecl :scl)) (defparameter *os-features* '((:windows :mswindows :win32 :mingw32) (:solaris :sunos) :linux ;; for GCL at least, must appear before :bsd. :macosx :darwin :apple :freebsd :netbsd :openbsd :bsd :unix)) (defparameter *architecture-features* '((:x86-64 :amd64 :x86_64 :x8664-target) (:x86 :i686 :i586 :pentium3 :i486 :i386 :pc386 :iapx386 :x8632-target :pentium4) :hppa64 :hppa :ppc64 (:ppc32 :ppc :powerpc) :sparc64 :sparc :java-1.4 :java-1.5 :java-1.6 :java-1.7)) (defun* lisp-version-string () (let ((s (lisp-implementation-version))) (declare (ignorable s)) #+allegro (format nil "~A~A~A~A" excl::*common-lisp-version-number* ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox (if (eq excl:*current-case-mode* :case-sensitive-lower) "M" "A") ;; Note if not using International ACL ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm (excl:ics-target-case (:-ics "8") (:+ics "")) (if (member :64bit *features*) "-64bit" "")) #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*) #+clisp (subseq s 0 (position #\space s)) #+clozure (format nil "~d.~d-fasl~d" ccl::*openmcl-major-version* ccl::*openmcl-minor-version* (logand ccl::fasl-version #xFF)) #+cmu (substitute #\- #\/ s) #+digitool (subseq s 8) #+ecl (format nil "~A~@[-~A~]" s (let ((vcs-id (ext:lisp-implementation-vcs-id))) (when (>= (length vcs-id) 8) (subseq vcs-id 0 8)))) #+gcl (subseq s (1+ (position #\space s))) #+lispworks (format nil "~A~@[~A~]" s (when (member :lispworks-64bit *features*) "-64bit")) ;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; f-f-v redundant w/ version #+(or cormanlisp mcl sbcl scl) s #-(or allegro armedbear clisp clozure cmu cormanlisp digitool ecl gcl lispworks mcl sbcl scl) s)) (defun* first-feature (features) (labels ((fp (thing) (etypecase thing (symbol (let ((feature (find thing *features*))) (when feature (return-from fp feature)))) ;; allows features to be lists of which the first ;; member is the "main name", the rest being aliases (cons (dolist (subf thing) (when (find subf *features*) (return-from fp (first thing)))))) nil)) (loop :for f :in features :when (fp f) :return :it))) (defun* implementation-type () (first-feature *implementation-features*)) (defun* implementation-identifier () (labels ((maybe-warn (value fstring &rest args) (cond (value) (t (apply #'warn fstring args) "unknown")))) (let ((lisp (maybe-warn (implementation-type) "No implementation feature found in ~a." *implementation-features*)) (os (maybe-warn (first-feature *os-features*) "No os feature found in ~a." *os-features*)) (arch (maybe-warn (first-feature *architecture-features*) "No architecture feature found in ~a." *architecture-features*)) (version (maybe-warn (lisp-version-string) "Don't know how to get Lisp implementation version."))) (substitute-if #\_ (lambda (x) (find x " /:\\(){}[]$#`'\"")) (format nil "~(~@{~a~^-~}~)" lisp version os arch))))) ;;; --------------------------------------------------------------------------- ;;; Generic support for configuration files (defparameter *inter-directory-separator* #+(or unix cygwin) #\: #-(or unix cygwin) #\;) (defun* user-homedir () (truename (user-homedir-pathname))) (defun* try-directory-subpath (x sub &key type) (let* ((p (and x (ensure-directory-pathname x))) (tp (and p (probe-file* p))) (sp (and tp (merge-pathnames* (merge-component-name-type sub :type type) p))) (ts (and sp (probe-file* sp)))) (and ts (values sp ts)))) (defun* user-configuration-directories () (remove-if #'null (flet ((try (x sub) (try-directory-subpath x sub :type :directory))) `(,(try (getenv "XDG_CONFIG_HOME") "common-lisp/") ,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS") :for dir :in (split-string dirs :separator ":") :collect (try dir "common-lisp/")) #+(and (or win32 windows mswindows mingw32) (not cygwin)) ,@`(#+lispworks ,(try (sys:get-folder-path :common-appdata) "common-lisp/config/") ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData ,(try (getenv "APPDATA") "common-lisp/config/")) ,(try (user-homedir) ".config/common-lisp/"))))) (defun* system-configuration-directories () (remove-if #'null (append #+(and (or win32 windows mswindows mingw32) (not cygwin)) (flet ((try (x sub) (try-directory-subpath x sub :type :directory))) `(,@`(#+lispworks ,(try (sys:get-folder-path :local-appdata) "common-lisp/config/") ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData ,(try (getenv "ALLUSERSPROFILE") "Application Data/common-lisp/config/")))) (list #p"/etc/common-lisp/")))) (defun* in-first-directory (dirs x) (loop :for dir :in dirs :thereis (and dir (probe-file* (merge-pathnames* x (ensure-directory-pathname dir)))))) (defun* in-user-configuration-directory (x) (in-first-directory (user-configuration-directories) x)) (defun* in-system-configuration-directory (x) (in-first-directory (system-configuration-directories) x)) (defun* configuration-inheritance-directive-p (x) (let ((kw '(:inherit-configuration :ignore-inherited-configuration))) (or (member x kw) (and (length=n-p x 1) (member (car x) kw))))) (defun* validate-configuration-form (form tag directive-validator &optional (description tag)) (unless (and (consp form) (eq (car form) tag)) (error "Error: Form doesn't specify ~A ~S~%" description form)) (loop :with inherit = 0 :for directive :in (cdr form) :do (if (configuration-inheritance-directive-p directive) (incf inherit) (funcall directive-validator directive)) :finally (unless (= inherit 1) (error "One and only one of ~S or ~S is required" :inherit-configuration :ignore-inherited-configuration))) form) (defun* validate-configuration-file (file validator description) (let ((forms (read-file-forms file))) (unless (length=n-p forms 1) (error "One and only one form allowed for ~A. Got: ~S~%" description forms)) (funcall validator (car forms)))) (defun* hidden-file-p (pathname) (equal (first-char (pathname-name pathname)) #\.)) (defun* validate-configuration-directory (directory tag validator) (let ((files (sort (ignore-errors (remove-if 'hidden-file-p (directory (make-pathname :name :wild :type "conf" :defaults directory) #+sbcl :resolve-symlinks #+sbcl nil))) #'string< :key #'namestring))) `(,tag ,@(loop :for file :in files :append (mapcar validator (read-file-forms file))) :inherit-configuration))) ;;; --------------------------------------------------------------------------- ;;; asdf-output-translations ;;; ;;; this code is heavily inspired from ;;; asdf-binary-translations, common-lisp-controller and cl-launch. ;;; --------------------------------------------------------------------------- (defvar *output-translations* () "Either NIL (for uninitialized), or a list of one element, said element itself being a sorted list of mappings. Each mapping is a pair of a source pathname and destination pathname, and the order is by decreasing length of namestring of the source pathname.") (defvar *user-cache* (flet ((try (x &rest sub) (and x `(,x ,@sub)))) (or (try (getenv "XDG_CACHE_HOME") "common-lisp" :implementation) #+(and (or win32 windows mswindows mingw32) (not cygwin)) (try (getenv "APPDATA") "common-lisp" "cache" :implementation) '(:home ".cache" "common-lisp" :implementation)))) (defvar *system-cache* ;; No good default, plus there's a security problem ;; with other users messing with such directories. *user-cache*) (defun* output-translations () (car *output-translations*)) (defun* (setf output-translations) (new-value) (setf *output-translations* (list (stable-sort (copy-list new-value) #'> :key (lambda (x) (etypecase (car x) ((eql t) -1) (pathname (length (pathname-directory (car x))))))))) new-value) (defun* output-translations-initialized-p () (and *output-translations* t)) (defun* clear-output-translations () "Undoes any initialization of the output translations. You might want to call that before you dump an image that would be resumed with a different configuration, so the configuration would be re-read then." (setf *output-translations* '()) (values)) (defparameter *wild-asd* (make-pathname :directory '(:relative :wild-inferiors) :name :wild :type "asd" :version :newest)) (declaim (ftype (function (t &optional boolean) (values (or null pathname) &optional)) resolve-location)) (defun* resolve-relative-location-component (super x &optional wildenp) (let* ((r (etypecase x (pathname x) (string x) (cons (let ((car (resolve-relative-location-component super (car x) nil))) (if (null (cdr x)) car (let ((cdr (resolve-relative-location-component (merge-pathnames* car super) (cdr x) wildenp))) (merge-pathnames* cdr car))))) ((eql :default-directory) (relativize-pathname-directory (default-directory))) ((eql :implementation) (implementation-identifier)) ((eql :implementation-type) (string-downcase (implementation-type))) #-(and (or win32 windows mswindows mingw32) (not cygwin)) ((eql :uid) (princ-to-string (get-uid))))) (d (if (pathnamep x) r (ensure-directory-pathname r))) (s (if (and wildenp (not (pathnamep x))) (wilden d) d))) (when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super)))) (error "pathname ~S is not relative to ~S" s super)) (merge-pathnames* s super))) (defun* resolve-absolute-location-component (x wildenp) (let* ((r (etypecase x (pathname x) (string (ensure-directory-pathname x)) (cons (let ((car (resolve-absolute-location-component (car x) nil))) (if (null (cdr x)) car (let ((cdr (resolve-relative-location-component car (cdr x) wildenp))) (merge-pathnames* cdr car))))) ((eql :root) ;; special magic! we encode such paths as relative pathnames, ;; but it means "relative to the root of the source pathname's host and device". (return-from resolve-absolute-location-component (make-pathname :directory '(:relative)))) ((eql :home) (user-homedir)) ((eql :user-cache) (resolve-location *user-cache* nil)) ((eql :system-cache) (resolve-location *system-cache* nil)) ((eql :default-directory) (default-directory)))) (s (if (and wildenp (not (pathnamep x))) (wilden r) r))) (unless (absolute-pathname-p s) (error "Not an absolute pathname ~S" s)) s)) (defun* resolve-location (x &optional wildenp) (if (atom x) (resolve-absolute-location-component x wildenp) (loop :with path = (resolve-absolute-location-component (car x) nil) :for (component . morep) :on (cdr x) :do (setf path (resolve-relative-location-component path component (and wildenp (not morep)))) :finally (return path)))) (defun* location-designator-p (x) (flet ((componentp (c) (typep c '(or string pathname keyword)))) (or (typep x 'boolean) (componentp x) (and (consp x) (every #'componentp x))))) (defun* location-function-p (x) (and (consp x) (length=n-p x 2) (or (and (equal (first x) :function) (typep (second x) 'symbol)) (and (equal (first x) 'lambda) (cddr x) (length=n-p (second x) 2))))) (defun* validate-output-translations-directive (directive) (unless (or (member directive '(:inherit-configuration :ignore-inherited-configuration :enable-user-cache :disable-cache nil)) (and (consp directive) (or (and (length=n-p directive 2) (or (and (eq (first directive) :include) (typep (second directive) '(or string pathname null))) (and (location-designator-p (first directive)) (or (location-designator-p (second directive)) (location-function-p (second directive)))))) (and (length=n-p directive 1) (location-designator-p (first directive)))))) (error "Invalid directive ~S~%" directive)) directive) (defun* validate-output-translations-form (form) (validate-configuration-form form :output-translations 'validate-output-translations-directive "output translations")) (defun* validate-output-translations-file (file) (validate-configuration-file file 'validate-output-translations-form "output translations")) (defun* validate-output-translations-directory (directory) (validate-configuration-directory directory :output-translations 'validate-output-translations-directive)) (defun* parse-output-translations-string (string) (cond ((or (null string) (equal string "")) '(:output-translations :inherit-configuration)) ((not (stringp string)) (error "environment string isn't: ~S" string)) ((eql (char string 0) #\") (parse-output-translations-string (read-from-string string))) ((eql (char string 0) #\() (validate-output-translations-form (read-from-string string))) (t (loop :with inherit = nil :with directives = () :with start = 0 :with end = (length string) :with source = nil :for i = (or (position *inter-directory-separator* string :start start) end) :do (let ((s (subseq string start i))) (cond (source (push (list source (if (equal "" s) nil s)) directives) (setf source nil)) ((equal "" s) (when inherit (error "only one inherited configuration allowed: ~S" string)) (setf inherit t) (push :inherit-configuration directives)) (t (setf source s))) (setf start (1+ i)) (when (> start end) (when source (error "Uneven number of components in source to destination mapping ~S" string)) (unless inherit (push :ignore-inherited-configuration directives)) (return `(:output-translations ,@(nreverse directives))))))))) (defparameter *default-output-translations* '(environment-output-translations user-output-translations-pathname user-output-translations-directory-pathname system-output-translations-pathname system-output-translations-directory-pathname)) (defun* wrapping-output-translations () `(:output-translations ;; Some implementations have precompiled ASDF systems, ;; so we must disable translations for implementation paths. #+sbcl ,(let ((h (getenv "SBCL_HOME"))) (when (plusp (length h)) `(,h ()))) #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; not needed: no precompiled ASDF system #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ())) ; not needed: no precompiled ASDF system ;; All-import, here is where we want user stuff to be: :inherit-configuration ;; These are for convenience, and can be overridden by the user: #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*")) #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname)) ;; If we want to enable the user cache by default, here would be the place: :enable-user-cache)) (defparameter *output-translations-file* #p"asdf-output-translations.conf") (defparameter *output-translations-directory* #p"asdf-output-translations.conf.d/") (defun* user-output-translations-pathname () (in-user-configuration-directory *output-translations-file* )) (defun* system-output-translations-pathname () (in-system-configuration-directory *output-translations-file*)) (defun* user-output-translations-directory-pathname () (in-user-configuration-directory *output-translations-directory*)) (defun* system-output-translations-directory-pathname () (in-system-configuration-directory *output-translations-directory*)) (defun* environment-output-translations () (getenv "ASDF_OUTPUT_TRANSLATIONS")) (defgeneric* process-output-translations (spec &key inherit collect)) (declaim (ftype (function (t &key (:collect (or symbol function))) t) inherit-output-translations)) (declaim (ftype (function (t &key (:collect (or symbol function)) (:inherit list)) t) process-output-translations-directive)) (defmethod process-output-translations ((x symbol) &key (inherit *default-output-translations*) collect) (process-output-translations (funcall x) :inherit inherit :collect collect)) (defmethod process-output-translations ((pathname pathname) &key inherit collect) (cond ((directory-pathname-p pathname) (process-output-translations (validate-output-translations-directory pathname) :inherit inherit :collect collect)) ((probe-file pathname) (process-output-translations (validate-output-translations-file pathname) :inherit inherit :collect collect)) (t (inherit-output-translations inherit :collect collect)))) (defmethod process-output-translations ((string string) &key inherit collect) (process-output-translations (parse-output-translations-string string) :inherit inherit :collect collect)) (defmethod process-output-translations ((x null) &key inherit collect) (declare (ignorable x)) (inherit-output-translations inherit :collect collect)) (defmethod process-output-translations ((form cons) &key inherit collect) (dolist (directive (cdr (validate-output-translations-form form))) (process-output-translations-directive directive :inherit inherit :collect collect))) (defun* inherit-output-translations (inherit &key collect) (when inherit (process-output-translations (first inherit) :collect collect :inherit (rest inherit)))) (defun* process-output-translations-directive (directive &key inherit collect) (if (atom directive) (ecase directive ((:enable-user-cache) (process-output-translations-directive '(t :user-cache) :collect collect)) ((:disable-cache) (process-output-translations-directive '(t t) :collect collect)) ((:inherit-configuration) (inherit-output-translations inherit :collect collect)) ((:ignore-inherited-configuration nil) nil)) (let ((src (first directive)) (dst (second directive))) (if (eq src :include) (when dst (process-output-translations (pathname dst) :inherit nil :collect collect)) (when src (let ((trusrc (or (eql src t) (let ((loc (resolve-location src t))) (if (absolute-pathname-p loc) (truenamize loc) loc))))) (cond ((location-function-p dst) (funcall collect (list trusrc (if (symbolp (second dst)) (fdefinition (second dst)) (eval (second dst)))))) ((eq dst t) (funcall collect (list trusrc t))) (t (let* ((trudst (make-pathname :defaults (if dst (resolve-location dst t) trusrc))) (wilddst (make-pathname :name :wild :type :wild :version :wild :defaults trudst))) (funcall collect (list wilddst t)) (funcall collect (list trusrc trudst))))))))))) (defun* compute-output-translations (&optional parameter) "read the configuration, return it" (remove-duplicates (while-collecting (c) (inherit-output-translations `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c)) :test 'equal :from-end t)) (defun* initialize-output-translations (&optional parameter) "read the configuration, initialize the internal configuration variable, return the configuration" (setf (output-translations) (compute-output-translations parameter))) (defun* disable-output-translations () "Initialize output translations in a way that maps every file to itself, effectively disabling the output translation facility." (initialize-output-translations '(:output-translations :disable-cache :ignore-inherited-configuration))) ;; checks an initial variable to see whether the state is initialized ;; or cleared. In the former case, return current configuration; in ;; the latter, initialize. ASDF will call this function at the start ;; of (asdf:find-system). (defun* ensure-output-translations () (if (output-translations-initialized-p) (output-translations) (initialize-output-translations))) (defun* translate-pathname* (path absolute-source destination &optional root source) (declare (ignore source)) (cond ((functionp destination) (funcall destination path absolute-source)) ((eq destination t) path) ((not (pathnamep destination)) (error "invalid destination")) ((not (absolute-pathname-p destination)) (translate-pathname path absolute-source (merge-pathnames* destination root))) (root (translate-pathname (directorize-pathname-host-device path) absolute-source destination)) (t (translate-pathname path absolute-source destination)))) (defun* apply-output-translations (path) (etypecase path (logical-pathname path) ((or pathname string) (ensure-output-translations) (loop :with p = (truenamize path) :for (source destination) :in (car *output-translations*) :for root = (when (or (eq source t) (and (pathnamep source) (not (absolute-pathname-p source)))) (pathname-root p)) :for absolute-source = (cond ((eq source t) (wilden root)) (root (merge-pathnames* source root)) (t source)) :when (or (eq source t) (pathname-match-p p absolute-source)) :return (translate-pathname* p absolute-source destination root source) :finally (return p))))) (defmethod output-files :around (operation component) "Translate output files, unless asked not to" (declare (ignorable operation component)) (values (multiple-value-bind (files fixedp) (call-next-method) (if fixedp files (mapcar #'apply-output-translations files))) t)) (defun* compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys) (or output-file (apply-output-translations (apply 'compile-file-pathname (truenamize (lispize-pathname input-file)) keys)))) (defun* tmpize-pathname (x) (make-pathname :name (format nil "ASDF-TMP-~A" (pathname-name x)) :defaults x)) (defun* delete-file-if-exists (x) (when (and x (probe-file x)) (delete-file x))) (defun* compile-file* (input-file &rest keys &key &allow-other-keys) (let* ((output-file (apply 'compile-file-pathname* input-file keys)) (tmp-file (tmpize-pathname output-file)) (status :error)) (multiple-value-bind (output-truename warnings-p failure-p) (apply 'compile-file input-file :output-file tmp-file keys) (cond (failure-p (setf status *compile-file-failure-behaviour*)) (warnings-p (setf status *compile-file-warnings-behaviour*)) (t (setf status :success))) (ecase status ((:success :warn :ignore) (delete-file-if-exists output-file) (when output-truename (rename-file output-truename output-file) (setf output-truename output-file))) (:error (delete-file-if-exists output-truename) (setf output-truename nil))) (values output-truename warnings-p failure-p)))) #+abcl (defun* translate-jar-pathname (source wildcard) (declare (ignore wildcard)) (let* ((p (pathname (first (pathname-device source)))) (root (format nil "/___jar___file___root___/~@[~A/~]" (and (find :windows *features*) (pathname-device p))))) (apply-output-translations (merge-pathnames* (relativize-pathname-directory source) (merge-pathnames* (relativize-pathname-directory (ensure-directory-pathname p)) root))))) ;;;; ----------------------------------------------------------------- ;;;; Compatibility mode for ASDF-Binary-Locations (defun* enable-asdf-binary-locations-compatibility (&key (centralize-lisp-binaries nil) (default-toplevel-directory ;; Use ".cache/common-lisp" instead ??? (merge-pathnames* (make-pathname :directory '(:relative ".fasls")) (user-homedir))) (include-per-user-information nil) (map-all-source-files nil) (source-to-target-mappings nil)) (let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp"))) (wild-inferiors (make-pathname :directory '(:relative :wild-inferiors))) (mapped-files (make-pathname :name :wild :version :wild :type (if map-all-source-files :wild fasl-type))) (destination-directory (if centralize-lisp-binaries `(,default-toplevel-directory ,@(when include-per-user-information (cdr (pathname-directory (user-homedir)))) :implementation ,wild-inferiors) `(:root ,wild-inferiors :implementation)))) (initialize-output-translations `(:output-translations ,@source-to-target-mappings ((:root ,wild-inferiors ,mapped-files) (,@destination-directory ,mapped-files)) (t t) :ignore-inherited-configuration)))) ;;;; ----------------------------------------------------------------- ;;;; Windows shortcut support. Based on: ;;;; ;;;; Jesse Hager: The Windows Shortcut File Format. ;;;; http://www.wotsit.org/list.asp?fc=13 #+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp)) (progn (defparameter *link-initial-dword* 76) (defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70)) (defun* read-null-terminated-string (s) (with-output-to-string (out) (loop :for code = (read-byte s) :until (zerop code) :do (write-char (code-char code) out)))) (defun* read-little-endian (s &optional (bytes 4)) (loop :for i :from 0 :below bytes :sum (ash (read-byte s) (* 8 i)))) (defun* parse-file-location-info (s) (let ((start (file-position s)) (total-length (read-little-endian s)) (end-of-header (read-little-endian s)) (fli-flags (read-little-endian s)) (local-volume-offset (read-little-endian s)) (local-offset (read-little-endian s)) (network-volume-offset (read-little-endian s)) (remaining-offset (read-little-endian s))) (declare (ignore total-length end-of-header local-volume-offset)) (unless (zerop fli-flags) (cond ((logbitp 0 fli-flags) (file-position s (+ start local-offset))) ((logbitp 1 fli-flags) (file-position s (+ start network-volume-offset #x14)))) (concatenate 'string (read-null-terminated-string s) (progn (file-position s (+ start remaining-offset)) (read-null-terminated-string s)))))) (defun* parse-windows-shortcut (pathname) (with-open-file (s pathname :element-type '(unsigned-byte 8)) (handler-case (when (and (= (read-little-endian s) *link-initial-dword*) (let ((header (make-array (length *link-guid*)))) (read-sequence header s) (equalp header *link-guid*))) (let ((flags (read-little-endian s))) (file-position s 76) ;skip rest of header (when (logbitp 0 flags) ;; skip shell item id list (let ((length (read-little-endian s 2))) (file-position s (+ length (file-position s))))) (cond ((logbitp 1 flags) (parse-file-location-info s)) (t (when (logbitp 2 flags) ;; skip description string (let ((length (read-little-endian s 2))) (file-position s (+ length (file-position s))))) (when (logbitp 3 flags) ;; finally, our pathname (let* ((length (read-little-endian s 2)) (buffer (make-array length))) (read-sequence buffer s) (map 'string #'code-char buffer))))))) (end-of-file () nil))))) ;;;; ----------------------------------------------------------------- ;;;; Source Registry Configuration, by Francois-Rene Rideau ;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918 ;; Using ack 1.2 exclusions (defvar *default-source-registry-exclusions* '(".bzr" ".cdv" "~.dep" "~.dot" "~.nib" "~.plst" ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs" "_sgbak" "autom4te.cache" "cover_db" "_build" "debian")) ;; debian often build stuff under the debian directory... BAD. (defvar *source-registry-exclusions* *default-source-registry-exclusions*) (defvar *source-registry* () "Either NIL (for uninitialized), or a list of one element, said element itself being a list of directory pathnames where to look for .asd files") (defun* source-registry () (car *source-registry*)) (defun* (setf source-registry) (new-value) (setf *source-registry* (list new-value)) new-value) (defun* source-registry-initialized-p () (and *source-registry* t)) (defun* clear-source-registry () "Undoes any initialization of the source registry. You might want to call that before you dump an image that would be resumed with a different configuration, so the configuration would be re-read then." (setf *source-registry* '()) (values)) (defun* validate-source-registry-directive (directive) (unless (or (member directive '(:default-registry (:default-registry)) :test 'equal) (destructuring-bind (kw &rest rest) directive (case kw ((:include :directory :tree) (and (length=n-p rest 1) (typep (car rest) '(or pathname string null)))) ((:exclude :also-exclude) (every #'stringp rest)) (null rest)))) (error "Invalid directive ~S~%" directive)) directive) (defun* validate-source-registry-form (form) (validate-configuration-form form :source-registry 'validate-source-registry-directive "a source registry")) (defun* validate-source-registry-file (file) (validate-configuration-file file 'validate-source-registry-form "a source registry")) (defun* validate-source-registry-directory (directory) (validate-configuration-directory directory :source-registry 'validate-source-registry-directive)) (defun* parse-source-registry-string (string) (cond ((or (null string) (equal string "")) '(:source-registry :inherit-configuration)) ((not (stringp string)) (error "environment string isn't: ~S" string)) ((find (char string 0) "\"(") (validate-source-registry-form (read-from-string string))) (t (loop :with inherit = nil :with directives = () :with start = 0 :with end = (length string) :for pos = (position *inter-directory-separator* string :start start) :do (let ((s (subseq string start (or pos end)))) (cond ((equal "" s) ; empty element: inherit (when inherit (error "only one inherited configuration allowed: ~S" string)) (setf inherit t) (push ':inherit-configuration directives)) ((ends-with s "//") (push `(:tree ,(subseq s 0 (1- (length s)))) directives)) (t (push `(:directory ,s) directives))) (cond (pos (setf start (1+ pos))) (t (unless inherit (push '(:ignore-inherited-configuration) directives)) (return `(:source-registry ,@(nreverse directives)))))))))) (defun* register-asd-directory (directory &key recurse exclude collect) (if (not recurse) (funcall collect directory) (let* ((files (handler-case (directory (merge-pathnames* *wild-asd* directory) #+sbcl #+sbcl :resolve-symlinks nil #+clisp #+clisp :circle t) (error (c) (warn "Error while scanning system definitions under directory ~S:~%~A" directory c) nil))) (dirs (remove-duplicates (mapcar #'pathname-directory-pathname files) :test #'equal :from-end t))) (loop :for dir :in dirs :unless (loop :for x :in exclude :thereis (find x (pathname-directory dir) :test #'equal)) :do (funcall collect dir))))) (defparameter *default-source-registries* '(environment-source-registry user-source-registry user-source-registry-directory system-source-registry system-source-registry-directory default-source-registry)) (defparameter *source-registry-file* #p"source-registry.conf") (defparameter *source-registry-directory* #p"source-registry.conf.d/") (defun* wrapping-source-registry () `(:source-registry #+sbcl (:tree ,(getenv "SBCL_HOME")) :inherit-configuration #+cmu (:tree #p"modules:"))) (defun* default-source-registry () (flet ((try (x sub) (try-directory-subpath x sub :type :directory))) `(:source-registry #+sbcl (:directory ,(merge-pathnames* ".sbcl/systems/" (user-homedir))) (:directory ,(truenamize (directory-namestring *default-pathname-defaults*))) ,@(let* #+(or unix cygwin) ((datahome (or (getenv "XDG_DATA_HOME") (try (user-homedir) ".local/share/"))) (datadirs (or (getenv "XDG_DATA_DIRS") "/usr/local/share:/usr/share")) (dirs (cons datahome (split-string datadirs :separator ":")))) #+(and (or win32 windows mswindows mingw32) (not cygwin)) ((datahome (getenv "APPDATA")) (datadir #+lispworks (sys:get-folder-path :local-appdata) #-lispworks (try (getenv "ALLUSERSPROFILE") "Application Data")) (dirs (list datahome datadir))) #-(or unix win32 windows mswindows mingw32 cygwin) ((dirs ())) (loop :for dir :in dirs :collect `(:directory ,(try dir "common-lisp/systems/")) :collect `(:tree ,(try dir "common-lisp/source/")))) :inherit-configuration))) (defun* user-source-registry () (in-user-configuration-directory *source-registry-file*)) (defun* system-source-registry () (in-system-configuration-directory *source-registry-file*)) (defun* user-source-registry-directory () (in-user-configuration-directory *source-registry-directory*)) (defun* system-source-registry-directory () (in-system-configuration-directory *source-registry-directory*)) (defun* environment-source-registry () (getenv "CL_SOURCE_REGISTRY")) (defgeneric* process-source-registry (spec &key inherit register)) (declaim (ftype (function (t &key (:register (or symbol function))) t) inherit-source-registry)) (declaim (ftype (function (t &key (:register (or symbol function)) (:inherit list)) t) process-source-registry-directive)) (defmethod process-source-registry ((x symbol) &key inherit register) (process-source-registry (funcall x) :inherit inherit :register register)) (defmethod process-source-registry ((pathname pathname) &key inherit register) (cond ((directory-pathname-p pathname) (process-source-registry (validate-source-registry-directory pathname) :inherit inherit :register register)) ((probe-file pathname) (process-source-registry (validate-source-registry-file pathname) :inherit inherit :register register)) (t (inherit-source-registry inherit :register register)))) (defmethod process-source-registry ((string string) &key inherit register) (process-source-registry (parse-source-registry-string string) :inherit inherit :register register)) (defmethod process-source-registry ((x null) &key inherit register) (declare (ignorable x)) (inherit-source-registry inherit :register register)) (defmethod process-source-registry ((form cons) &key inherit register) (let ((*source-registry-exclusions* *default-source-registry-exclusions*)) (dolist (directive (cdr (validate-source-registry-form form))) (process-source-registry-directive directive :inherit inherit :register register)))) (defun* inherit-source-registry (inherit &key register) (when inherit (process-source-registry (first inherit) :register register :inherit (rest inherit)))) (defun* process-source-registry-directive (directive &key inherit register) (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive)) (ecase kw ((:include) (destructuring-bind (pathname) rest (process-source-registry (pathname pathname) :inherit nil :register register))) ((:directory) (destructuring-bind (pathname) rest (when pathname (funcall register (ensure-directory-pathname pathname))))) ((:tree) (destructuring-bind (pathname) rest (when pathname (funcall register (ensure-directory-pathname pathname) :recurse t :exclude *source-registry-exclusions*)))) ((:exclude) (setf *source-registry-exclusions* rest)) ((:also-exclude) (appendf *source-registry-exclusions* rest)) ((:default-registry) (inherit-source-registry '(default-source-registry) :register register)) ((:inherit-configuration) (inherit-source-registry inherit :register register)) ((:ignore-inherited-configuration) nil))) nil) (defun* flatten-source-registry (&optional parameter) (remove-duplicates (while-collecting (collect) (inherit-source-registry `(wrapping-source-registry ,parameter ,@*default-source-registries*) :register (lambda (directory &key recurse exclude) (collect (list directory :recurse recurse :exclude exclude))))) :test 'equal :from-end t)) ;; Will read the configuration and initialize all internal variables, ;; and return the new configuration. (defun* compute-source-registry (&optional parameter) (while-collecting (collect) (dolist (entry (flatten-source-registry parameter)) (destructuring-bind (directory &key recurse exclude) entry (register-asd-directory directory :recurse recurse :exclude exclude :collect #'collect))))) (defun* initialize-source-registry (&optional parameter) (setf (source-registry) (compute-source-registry parameter))) ;; Checks an initial variable to see whether the state is initialized ;; or cleared. In the former case, return current configuration; in ;; the latter, initialize. ASDF will call this function at the start ;; of (asdf:find-system) to make sure the source registry is initialized. ;; However, it will do so *without* a parameter, at which point it ;; will be too late to provide a parameter to this function, though ;; you may override the configuration explicitly by calling ;; initialize-source-registry directly with your parameter. (defun* ensure-source-registry (&optional parameter) (if (source-registry-initialized-p) (source-registry) (initialize-source-registry parameter))) (defun* sysdef-source-registry-search (system) (ensure-source-registry) (loop :with name = (coerce-name system) :for defaults :in (source-registry) :for file = (probe-asd name defaults) :when file :return file)) (defun* clear-configuration () (clear-source-registry) (clear-output-translations)) ;;;; ----------------------------------------------------------------- ;;;; Hook into REQUIRE for ABCL, ClozureCL, CMUCL, ECL and SBCL ;;;; (defun* module-provide-asdf (name) (handler-bind ((style-warning #'muffle-warning) (missing-component (constantly nil)) (error (lambda (e) (format *error-output* "ASDF could not load ~(~A~) because ~A.~%" name e)))) (let* ((*verbose-out* (make-broadcast-stream)) (system (find-system (string-downcase name) nil))) (when system (load-system system) t)))) #+(or abcl clisp clozure cmu ecl sbcl) (let ((x (and #+clisp (find-symbol "*MODULE-PROVIDER-FUNCTIONS*" :custom)))) (when x (eval `(pushnew 'module-provide-asdf #+abcl sys::*module-provider-functions* #+clisp ,x #+clozure ccl:*module-provider-functions* #+cmu ext:*module-provider-functions* #+ecl si:*module-provider-functions* #+sbcl sb-ext:*module-provider-functions*)))) ;;;; ------------------------------------------------------------------------- ;;;; Cleanups after hot-upgrade. ;;;; Things to do in case we're upgrading from a previous version of ASDF. ;;;; See https://bugs.launchpad.net/asdf/+bug/485687 ;;;; ;;;; TODO: debug why it's not enough to upgrade from ECL <= 9.11.1 (eval-when (:compile-toplevel :load-toplevel :execute) #+ecl ;; Support upgrade from before ECL went to 1.369 (when (fboundp 'compile-op-system-p) (defmethod compile-op-system-p ((op compile-op)) (getf :system-p (compile-op-flags op))) (defmethod initialize-instance :after ((op compile-op) &rest initargs &key system-p &allow-other-keys) (declare (ignorable initargs)) (when system-p (appendf (compile-op-flags op) (list :system-p system-p)))))) ;;;; ----------------------------------------------------------------- ;;;; Done! (when *load-verbose* (asdf-message ";; ASDF, version ~a~%" (asdf-version))) #+allegro (eval-when (:compile-toplevel :execute) (when (boundp 'excl:*warn-on-nested-reader-conditionals*) (setf excl:*warn-on-nested-reader-conditionals* *acl-warn-save*))) (pushnew :asdf *features*) (pushnew :asdf2 *features*) (provide :asdf) ;;; Local Variables: ;;; mode: lisp ;;; End: clfswm-20111015.git51b0a02/contrib/cd-player.lisp000066400000000000000000000057211164636077000211460ustar00rootroot00000000000000;;; -------------------------------------------------------------------------- ;;; CLFSWM - FullScreen Window Manager ;;; ;;; -------------------------------------------------------------------------- ;;; Documentation: Music Player Daemon (MPD) interface ;;; -------------------------------------------------------------------------- ;;; ;;; (C) 2011 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;; ;;; Documentation: Handle the CD player ;;; This code needs pcd (http://hocwp.free.fr/pcd.html). ;; If you want to use this file, just add this line in ;;; your configuration file: ;;; ;;; (load-contrib "cd-player.lisp") ;;; ;;; -------------------------------------------------------------------------- (in-package :clfswm) (format t "Loading CDPLAYER code... ") (defun cdplayer-menu () "Open the CDPLAYER menu" (open-menu (find-menu 'cdplayer-menu))) (defun cdplayer-play () "Start playing CD" (do-shell "pcd play")) (defun cdplayer-stop () "Stop playing CD" (do-shell "pcd stop")) (defun cdplayer-pause () "Toggle pause" (do-shell "pcd toggle")) (defun show-cdplayer-status () "Show the current CD status" (info-on-shell "CDPLAYER status:" "pcd info") (cdplayer-menu)) (defun show-cdplayer-playlist () "Show the current CD playlist" (info-on-shell "CDPLAYER:" "pcd more_info") (cdplayer-menu)) (defun cdplayer-next-track () "Play the next CD track" (do-shell "pcd next") (cdplayer-menu)) (defun cdplayer-previous-track () "Play the previous CD track" (do-shell "pcd previous") (cdplayer-menu)) (defun cdplayer-eject () "Eject CD" (do-shell "pcd eject")) (defun cdplayer-close () "Close CD" (do-shell "pcd close")) (unless (find-menu 'cdplayer-menu) (add-sub-menu 'help-menu "i" 'cdplayer-menu "CDPLAYER menu") (add-menu-key 'cdplayer-menu "y" 'cdplayer-play) (add-menu-key 'cdplayer-menu "k" 'cdplayer-stop) (add-menu-key 'cdplayer-menu "t" 'cdplayer-pause) (add-menu-key 'cdplayer-menu "s" 'show-cdplayer-status) (add-menu-key 'cdplayer-menu "l" 'show-cdplayer-playlist) (add-menu-key 'cdplayer-menu "n" 'cdplayer-next-track) (add-menu-key 'cdplayer-menu "p" 'cdplayer-previous-track) (add-menu-key 'cdplayer-menu "e" 'cdplayer-eject) (add-menu-key 'cdplayer-menu "c" 'cdplayer-close)) (format t "done~%") clfswm-20111015.git51b0a02/contrib/clfswm000077500000000000000000000145521164636077000176200ustar00rootroot00000000000000#!/bin/bash -e # # (C) 2008 Xavier Maillard # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # # # -------------------------------------------------------------------------- # Documentation: # # Original code and idea: http://stumpwm.antidesktop.net/cgi-bin/wiki/SetUp # # Installation: # Put this script wherever you want and just call it from your .xinitrc file # # The first time you will launch it, it will build the final # executable and then call it. To force a rebuild of your executable # (say you have updated something in the CLFSWM source tree), just # delete the image and restart your X session. # -------------------------------------------------------------------------- no_start=no lisp=clisp # +config+ lisp_bin='' # +config+ lisp_opt='' # +config+ dump_path="$XDG_CACHE_HOME/clfswm/" # +config+ clfswm_asd_path="$(pwd)" # +config+ asdf_path="$(pwd)/contrib" # +config+ tmp_dir=/tmp usage() { echo "$0 [options] -n, --no-start don't start CLFSWM after image dump -f, --force force image dump --rebuild same as -f, --force -l, --with-lisp use as the common lisp implementation [$lisp] -b, --lisp-bin use as the common lisp program [$lisp_bin] (default: same as with-lisp type) -o, --lisp-opt use as lisp option [$lisp_opt] -d, --dump-path path to the dump directory [$dump_path] --with-clfswm path to clfswm.asd file [$clfswm_asd_path] --with-asdf path to the asdf.lisp file [$asdf_path]" exit 0 } die() { echo >&2 "$@" exit 1 } build_clisp () { $lisp_bin $lisp_opt -m 8MB -E ISO-8859-1 -q -i "$asdf_path"/asdf.lisp -x "(load \"$clfswm_asd_path/clfswm.asd\") (asdf:oos 'asdf:load-op :clfswm) \ (EXT:SAVEINITMEM \"$dump_image\" :INIT-FUNCTION (lambda () (clfswm:main) (quit)) :EXECUTABLE t :norc t)" } build_sbcl() { $lisp_bin $lisp_opt --disable-debugger --eval "(require :asdf)" \ --eval "(require :sb-posix)" \ --eval "(load \"$clfswm_asd_path/clfswm.asd\")" \ --eval "(require :clfswm)" \ --eval "(save-lisp-and-die \"$dump_image\" :toplevel 'clfswm:main)" } build_cmucl() { $lisp_bin $lisp_opt -eval "(require :clx)" \ -eval "(load \"$asdf_path/asdf.lisp\")" \ -eval "(load \"$clfswm_asd_path/clfswm.asd\")" \ -eval "(asdf:oos 'asdf:load-op :clfswm)" \ -eval "(save-lisp \"$dump_image\" :init-function (lambda () (clfswm:main) (quit)))" } build_ccl() { $lisp_bin $lisp_opt --eval "(require :asdf)" \ --eval "(load \"$clfswm_asd_path/clfswm.asd\")" \ --eval "(asdf:oos 'asdf:load-op :clfswm)" \ --eval "(save-application \"$dump_image\" :toplevel-function (lambda () (clfswm:main) (quit)))" } build_ecl() { $lisp_bin $lisp_opt -eval "(require :asdf)" \ -eval "(load \"$clfswm_asd_path/clfswm.asd\")" \ -eval "(asdf:make-build :clfswm :type :program :monolithic t :move-here \".\" :prologue-code '(progn (require :asdf) (require :clx)))" \ -eval "(ext:quit 0)" mv ./clfswm-mono "$dump_image" echo "$dump_image" } while test $# != 0 do case "$1" in -n|--no-start) no_start=yes ;; -f|--force|--rebuild) force=yes ;; -d|--dump-path) shift dump_path="$1" ;; --with-clfswm) shift clfswm_asd_path="$1" ;; --with-asdf) shift asdf_path="$1" ;; -l|--with-lisp) shift case "$1" in '') usage;; clisp|sbcl|cmucl|ccl|ecl) lisp="$1" ;; esac ;; -b|--lisp-bin) shift lisp_bin="$1" ;; -o|--lisp-opt) shift lisp_opt="$1" ;; --) shift break ;; -h|--help) usage ;; *) ARGS="$ARGS $1" ;; esac shift done if [ "x$lisp_bin" == "x" ]; then lisp_bin=$lisp fi dump_image="$dump_path/clfswm-$(cksum $(type -p $lisp) | cut -d ' ' -f 1).core" if test yes = "$force" && test -e "$dump_image" then echo "Removing old image." rm -f "$dump_image" fi clfswm_asd="$clfswm_asd_path"/clfswm.asd if test -L "$clfswm_asd_path"; then clfswm_asd=$(readlink "$clfswm_asd") fi older_image=0 for i in "$(dirname $clfswm_asd)"/src/*.lisp; do test "$dump_image" -ot "$i" && older_image=1 done if test ! -e "$dump_image" || test $older_image -eq 1 then echo "Image is nonexistent or older than sources. Rebuilding clfswm." test -x $(type -p "$lisp") || die "$lisp can't be found." test -e "$clfswm_asd_path"/clfswm.asd || die "can't find clfswm.asd in $clfswm_asd_path" test -e "$asdf_path"/asdf.lisp || die "can't find asdf.lisp in $asdf_path" # Move clfswm sources to $tmp_dir if there is no write permission on $clfswm_asd_path if test ! -w "$clfswm_asd_path" ; then echo "* Note: No write access in sources ($clfswm_asd_path), -> copying in a writable directory ($tmp_dir/clfswm-tmp)" rm -rf "$tmp_dir"/clfswm-tmp mkdir "$tmp_dir"/clfswm-tmp cp -R "$clfswm_asd_path"/* "$tmp_dir"/clfswm-tmp clfswm_asd_path="$tmp_dir"/clfswm-tmp asdf_path="$tmp_dir"/clfswm-tmp/contrib fi mkdir -p "$dump_path" mkdir -p "$dump_path/contrib" eval build_"$lisp" rm -rf "$dump_path/contrib" cp -R "$clfswm_asd_path/contrib/" "$dump_path/" rm -rf $(find "$dump_path/" -name "*svn") rm -rf "$tmp_dir"/clfswm-tmp echo "CLFSWM image is: $dump_image" fi # Run the resulting image if test no = "$no_start" then cd "$dump_path" echo "Arguments: $* and $ARGS" case $lisp in clisp ) "$dump_image" -- $ARGS ;; sbcl ) exec $lisp_bin --core "$dump_image" $ARGS ;; cmucl ) exec $lisp_bin -core "$dump_image" $ARGS ;; ccl ) exec $lisp_bin -I "$dump_image" -- $ARGS ;; ecl ) "$dump_image" -eval "(progn (clfswm:main) (ext:quit 0))" $ARGS ;; *) echo "..." ;; esac else echo "As requested, we have just dumped the image." fi clfswm-20111015.git51b0a02/contrib/contrib-example.lisp000066400000000000000000000001051164636077000223460ustar00rootroot00000000000000(in-package :clfswm) (format t "My contribution code start here~%") clfswm-20111015.git51b0a02/contrib/keyb_fr.lisp000066400000000000000000000062551164636077000207120ustar00rootroot00000000000000;;; -------------------------------------------------------------------------- ;;; CLFSWM - FullScreen Window Manager ;;; ;;; -------------------------------------------------------------------------- ;;; Documentation: Define some keybindings for an azerty french keyboard ;;; -------------------------------------------------------------------------- ;;; ;;; (C) 2011 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;; ;;; Documentation: French keyboard layout. ;;; If you want to use this file, just add this line in ;;; your configuration file: ;;; ;;; (load-contrib "keyb_fr.lisp") ;;; ;;; -------------------------------------------------------------------------- (in-package :clfswm) (format t "Loading French Keyboard code... ") (defun fr-binding () ;; For an azery keyboard: ;; Main mode (undefine-main-multi-keys ("1" :mod-1) ("2" :mod-1) ("3" :mod-1) ("4" :mod-1) ("5" :mod-1) ("6" :mod-1) ("7" :mod-1) ("8" :mod-1) ("9" :mod-1) ("0" :mod-1)) (define-main-key ("twosuperior") 'banish-pointer) (define-main-key ("ampersand" :mod-1) 'bind-or-jump 1) (define-main-key ("eacute" :mod-1) 'bind-or-jump 2) (define-main-key ("quotedbl" :mod-1) 'bind-or-jump 3) (define-main-key ("quoteright" :mod-1) 'bind-or-jump 4) (define-main-key ("parenleft" :mod-1) 'bind-or-jump 5) (define-main-key ("minus" :mod-1) 'bind-or-jump 6) (define-main-key ("egrave" :mod-1) 'bind-or-jump 7) (define-main-key ("underscore" :mod-1) 'bind-or-jump 8) (define-main-key ("ccedilla" :mod-1) 'bind-or-jump 9) (define-main-key ("agrave" :mod-1) 'bind-or-jump 10) ;; Second mode (undefine-second-multi-keys ("1" :mod-1) ("2" :mod-1) ("3" :mod-1) ("4" :mod-1) ("5" :mod-1) ("6" :mod-1) ("7" :mod-1) ("8" :mod-1) ("9" :mod-1) ("0" :mod-1)) (define-second-key ("twosuperior") 'banish-pointer) (define-second-key ("ampersand" :mod-1) 'bind-or-jump 1) (define-second-key ("eacute" :mod-1) 'bind-or-jump 2) (define-second-key ("quotedbl" :mod-1) 'bind-or-jump 3) (define-second-key ("quoteright" :mod-1) 'bind-or-jump 4) (define-second-key ("parenleft" :mod-1) 'bind-or-jump 5) (define-second-key ("minus" :mod-1) 'bind-or-jump 6) (define-second-key ("egrave" :mod-1) 'bind-or-jump 7) (define-second-key ("underscore" :mod-1) 'bind-or-jump 8) (define-second-key ("ccedilla" :mod-1) 'bind-or-jump 9) (define-second-key ("agrave" :mod-1) 'bind-or-jump 10)) (unless (member 'fr-binding *binding-hook*) (add-hook *binding-hook* 'fr-binding)) (format t "done~%") clfswm-20111015.git51b0a02/contrib/mpd.lisp000066400000000000000000000062601164636077000200450ustar00rootroot00000000000000;;; -------------------------------------------------------------------------- ;;; CLFSWM - FullScreen Window Manager ;;; ;;; -------------------------------------------------------------------------- ;;; Documentation: Music Player Daemon (MPD) interface ;;; -------------------------------------------------------------------------- ;;; ;;; (C) 2011 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;; ;;; Documentation: If you want to use this file, just add this line in ;;; your configuration file: ;;; ;;; (load-contrib "mpd.lisp") ;;; ;;; -------------------------------------------------------------------------- (in-package :clfswm) (format t "Loading MPD code... ") (defun mpd-menu () "Open the Music Player Daemon (MPD) menu" (open-menu (find-menu 'mpd-menu))) (defun start-sonata () "Start sonata" (do-shell "exec sonata")) (defun start-gmpc () "Start gmpc" (do-shell "exec gmpc")) (defun show-mpd-info () "Show MPD informations" (info-on-shell "MPD informations:" "mpc") (mpd-menu)) (defun mpd-previous () "Play the previous song in the current playlist" (info-on-shell "MPD:" "mpc prev") (mpd-menu)) (defun mpd-next () "Play the next song in the current playlist" (info-on-shell "MPD:" "mpc next") (mpd-menu)) (defun mpd-toggle () "Toggles Play/Pause, plays if stopped" (do-shell "mpc toggle")) (defun mpd-play () "Start playing" (do-shell "mpc play")) (defun mpd-stop () "Stop the currently playing playlists" (do-shell "mpc stop")) (defun mpd-seek-+5% () "Seeks to +5%" (do-shell "mpc seek +5%") (mpd-menu)) (defun mpd-seek--5% () "Seeks to -5%" (do-shell "mpc seek -5%") (mpd-menu)) (defun show-mpd-playlist () "Show the current MPD playlist" (info-on-shell "Current MPD playlist:" "mpc playlist") (mpd-menu)) (unless (find-menu 'mpd-menu) (add-sub-menu 'help-menu "F2" 'mpd-menu "Music Player Daemon (MPD) menu") (add-menu-key 'mpd-menu "i" 'show-mpd-info) (add-menu-key 'mpd-menu "p" 'mpd-previous) (add-menu-key 'mpd-menu "n" 'mpd-next) (add-menu-key 'mpd-menu "t" 'mpd-toggle) (add-menu-key 'mpd-menu "y" 'mpd-play) (add-menu-key 'mpd-menu "k" 'mpd-stop) (add-menu-key 'mpd-menu "x" 'mpd-seek-+5%) (add-menu-key 'mpd-menu "w" 'mpd-seek--5%) (add-menu-key 'mpd-menu "l" 'show-mpd-playlist) (add-menu-key 'mpd-menu "s" 'start-sonata) (add-menu-key 'mpd-menu "g" 'start-gmpc)) (defun mpd-binding () (define-main-key ("F2" :alt) 'mpd-menu)) (add-hook *binding-hook* 'mpd-binding) (format t "done~%") clfswm-20111015.git51b0a02/contrib/osd.lisp000066400000000000000000000141531164636077000200520ustar00rootroot00000000000000;;; -------------------------------------------------------------------------- ;;; CLFSWM - FullScreen Window Manager ;;; ;;; -------------------------------------------------------------------------- ;;; Documentation: OSD (On Screen Display) for presentations. ;;; -------------------------------------------------------------------------- ;;; ;;; (C) 2011 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;; ;;; -------------------------------------------------------------------------- (in-package :clfswm) ;; Uncomment the line above if you want to use the old OSD method ;;(pushnew :DISPLAY-OSD *features*) #-DISPLAY-OSD (progn (defparameter *osd-window* nil) (defparameter *osd-gc* nil) (defparameter *osd-font* nil) (defparameter *osd-font-string* "-*-fixed-*-*-*-*-14-*-*-*-*-*-*-1")) ;;; A more complex example I use to record my desktop and show ;;; documentation associated to each key press. #+DISPLAY-OSD (defun display-doc (function code state) (let* ((modifiers (state->modifiers state)) (keysym (keysym->keysym-name (xlib:keycode->keysym *display* code 0)))) (do-shell "pkill osd_cat") (do-shell (format nil "( echo '~A~A' | osd_cat -d 3 -p bottom -c white -o -50 -f -*-fixed-*-*-*-*-14-*-*-*-*-*-*-1 ) &" (if keysym (format nil "~:(~{~A+~}~A~)" modifiers keysym) "Menu") (aif (documentation (first function) 'function) (format nil ": ~A" it) ""))))) #-DISPLAY-OSD (defun is-osd-window-p (win) (xlib:window-equal win *osd-window*)) #-DISPLAY-OSD (defun display-doc (function code state &optional button-p) (unless *osd-window* (setf *osd-window* (xlib:create-window :parent *root* :x 0 :y (- (xlib:drawable-height *root*) 25) :width (xlib:drawable-width *root*) :height 25 :background (get-color "black") :border-width 1 :border (get-color "black") :colormap (xlib:screen-default-colormap *screen*) :event-mask '(:exposure)) *osd-font* (xlib:open-font *display* *osd-font-string*) *osd-gc* (xlib:create-gcontext :drawable *osd-window* :foreground (get-color "white") :background (get-color "gray10") :font *osd-font* :line-style :solid)) (map-window *osd-window*)) (let* ((modifiers (state->modifiers state)) (keysym (keysym->keysym-name (xlib:keycode->keysym *display* code 0)))) (when (frame-p *current-child*) (push (list #'is-osd-window-p nil) *never-managed-window-list*)) (raise-window *osd-window*) (rotatef (xlib:gcontext-foreground *osd-gc*) (xlib:gcontext-background *osd-gc*)) (xlib:draw-rectangle *osd-window* *osd-gc* 0 0 (xlib:drawable-width *osd-window*) (xlib:drawable-height *osd-window*) t) (rotatef (xlib:gcontext-foreground *osd-gc*) (xlib:gcontext-background *osd-gc*)) (xlib:draw-glyphs *osd-window* *osd-gc* 20 15 (format nil "~A~A" (cond (button-p (format nil "~:(~{~A+~}Button-~A~)" modifiers code)) (keysym (format nil "~:(~{~A+~}~A~)" modifiers keysym)) (t "Menu")) (aif (documentation (first function) 'function) (format nil ": ~A" (substitute #\Space #\Newline it)) ""))) (xlib:display-finish-output *display*))) (fmakunbound 'funcall-key-from-code) (defun funcall-key-from-code (hash-table-key code state &rest args) (let ((function (find-key-from-code hash-table-key code state))) (when function (display-doc function code state) (apply (first function) (append args (second function))) t))) (fmakunbound 'funcall-button-from-code) (defun funcall-button-from-code (hash-table-key code state window root-x root-y &optional (action *fun-press*) args) (let ((state (modifiers->state (set-difference (state->modifiers state) '(:button-1 :button-2 :button-3 :button-4 :button-5))))) (multiple-value-bind (function foundp) (gethash (list code state) hash-table-key) (if (and foundp (funcall action function)) (progn (unless (equal code 'motion) (display-doc function code state t)) (apply (funcall action function) `(,window ,root-x ,root-y ,@(append args (third function)))) t) nil)))) (fmakunbound 'get-fullscreen-size) ;;; CONFIG - Screen size (defun get-fullscreen-size () "Return the size of root child (values rx ry rw rh) You can tweak this to what you want" (values -2 -2 (+ (xlib:screen-width *screen*) 2) (- (xlib:screen-height *screen*) 25))) (fmakunbound 'open-menu-do-action) ;;; Display menu functions (defun open-menu-do-action (action menu parent) (typecase action (menu (open-menu action (cons menu parent))) (null (awhen (first parent) (open-menu it (rest parent)))) (t (when (fboundp action) (display-doc (list action) 0 0) (funcall action))))) (fmakunbound 'bottom-left-placement) (defun bottom-left-placement (&optional (width 0) (height 0)) (declare (ignore width)) (values 0 (- (xlib:screen-height *screen*) height 26))) (fmakunbound 'bottom-middle-placement) (defun bottom-middle-placement (&optional (width 0) (height 0)) (values (truncate (/ (- (xlib:screen-width *screen*) width) 2)) (- (xlib:screen-height *screen*) height 26))) (fmakunbound 'bottom-right-placement) (defun bottom-right-placement (&optional (width 0) (height 0)) (values (- (xlib:screen-width *screen*) width 1) (- (xlib:screen-height *screen*) height 26))) clfswm-20111015.git51b0a02/contrib/reboot-halt.lisp000066400000000000000000000050151164636077000215020ustar00rootroot00000000000000;;; -------------------------------------------------------------------------- ;;; CLFSWM - FullScreen Window Manager ;;; ;;; -------------------------------------------------------------------------- ;;; Documentation: Reboot and halt menu ;;; -------------------------------------------------------------------------- ;;; ;;; (C) 2011 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;; ;;; Documentation: If you want to use this file, just add this line in ;;; your configuration file: ;;; ;;; (load-contrib "mpd.lisp") ;;; ;;; -------------------------------------------------------------------------- (in-package :clfswm) (format t "Loading Reboot/Halt code... ") (defun reboot-halt-menu () "Open the Reboot/Halt menu" (open-menu (find-menu 'reboot-halt-menu))) (defun do-with-terminal (command) (do-shell (format nil "xterm -e '~A'" command))) ;;(do-shell (format nil "xterm -e 'echo ~A; sleep 3'" command))) ;; test (defun do-nothing () "Do nothing" ()) (defun do-suspend () "Suspend the computer to RAM" (do-with-terminal "sudo pm-suspend")) (defun do-hibernate () "Suspend the computer to DISK" (do-with-terminal "sudo pm-hibernate")) (defun do-reboot () "Reboot the computer" (do-with-terminal "sudo reboot")) (defun do-halt () "Halt the computer" (do-with-terminal "sudo halt")) (unless (find-menu 'reboot-halt-menu) (add-sub-menu 'clfswm-menu "Pause" 'reboot-halt-menu "Suspend/Reboot/Halt menu") (add-menu-key 'reboot-halt-menu "-" 'do-nothing) (add-menu-key 'reboot-halt-menu "s" 'do-suspend) (add-menu-key 'reboot-halt-menu "d" 'do-hibernate) (add-menu-key 'reboot-halt-menu "r" 'do-reboot) (add-menu-key 'reboot-halt-menu "h" 'do-halt)) (defun reboot-halt-binding () (define-main-key ("Pause") 'reboot-halt-menu)) (add-hook *binding-hook* 'reboot-halt-binding) (format t "done~%") clfswm-20111015.git51b0a02/contrib/server/000077500000000000000000000000001164636077000176765ustar00rootroot00000000000000clfswm-20111015.git51b0a02/contrib/server/clfswm-client.asd000066400000000000000000000006021164636077000231340ustar00rootroot00000000000000;;;; -*- Mode: Lisp -*- ;;;; ASDF System Definition ;;; (in-package #:asdf) (defsystem clfswm-client :description "" :licence "GNU Lesser General Public License (LGPL)" :components ((:file "md5") (:file "net") (:file "crypt") (:file "key" :depends-on ("crypt")) (:file "clfswm-client" :depends-on ("md5" "net" "crypt" "key")))) clfswm-20111015.git51b0a02/contrib/server/clfswm-client.lisp000066400000000000000000000071021164636077000233360ustar00rootroot00000000000000;;; -------------------------------------------------------------------------- ;;; CLFSWM - FullScreen Window Manager ;;; ;;; -------------------------------------------------------------------------- ;;; Documentation: Client/server connection. ;;; The connection is crypted and you can only connect to the server with the ;;; same clfswm binary. ;;; -------------------------------------------------------------------------- ;;; ;;; (C) 2011 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;; ;;; -------------------------------------------------------------------------- ;;; Server protocole: ;;; Server -> Client: orig_key=a generated key crypted with *key* ;;; Client : build its new_key with orig_key+*key* ;;; Client -> Server: new_key+(md5 new_key) crypted with new_key ;;; Server -> Client: check if the keys match and then authenticate the client. ;;; Server <-> Client: All connections are crypted with new_key ;;; -------------------------------------------------------------------------- (in-package :common-lisp-user) (defpackage :clfswm-client (:use :common-lisp :crypt) (:export :start-client)) (in-package :clfswm-client) (defun uquit () #+(or clisp cmu) (ext:quit) #+sbcl (sb-ext:quit) #+ecl (si:quit) #+gcl (lisp:quit) #+lispworks (lw:quit) #+(or allegro-cl allegro-cl-trial) (excl:exit) #+ccl (ccl:quit)) ;;(defparameter *server-port* 33333) (defun print-output (sock &optional wait) (when (or wait (ignore-errors (listen sock))) (let ((line (ignore-errors (string-trim '(#\newline) (read-line sock nil nil))))) (when line (format t "~&~A" (decrypt line *key*)) (force-output))))) (defun quit-on-command (line sock) (when (member line '("quit" "close" "bye") :test #'string-equal) (loop for line = (read-line sock nil nil) while line do (format t "~&~A" (decrypt line *key*)) (force-output)) (terpri) (uquit))) (defun parse-args (sock args) (unless (string= args "") (multiple-value-bind (form pos) (read-from-string args) (let ((str (format nil "~A" form))) (format t "~A~% " str) (format sock "~A~%" (crypt str *key*)) (force-output sock) (print-output sock t) (quit-on-command str sock) (parse-args sock (subseq args pos)))))) (defun start-client (args &optional (url "127.0.0.1") (port clfswm::*server-port*)) (load-new-key) (let* ((sock (port:open-socket url port)) (key (string-trim '(#\Newline #\Space) (decrypt (read-line sock nil nil) *key*)))) (setf *key* (concatenate 'string key *key*)) (write-line (crypt (format nil "~A~A" *key* (md5:md5 *key*)) *key*) sock) (force-output sock) (print-output sock t) (dolist (a args) (parse-args sock a)) (loop (print-output sock) (when (listen) (let ((line (read-line))) (write-line (crypt line *key*) sock) (force-output sock) (quit-on-command line sock))) (sleep 0.01)))) clfswm-20111015.git51b0a02/contrib/server/crypt.lisp000066400000000000000000000116371164636077000217400ustar00rootroot00000000000000;;; -------------------------------------------------------------------------- ;;; CLFSWM - FullScreen Window Manager ;;; ;;; -------------------------------------------------------------------------- ;;; Documentation: Client/server connection. ;;; The connection is crypted and you can only connect to the server with the ;;; same clfswm binary. ;;; -------------------------------------------------------------------------- ;;; ;;; (C) 2011 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;; ;;; -------------------------------------------------------------------------- ;;; Server protocole: ;;; Server -> Client: orig_key=a generated key crypted with *key* ;;; Client : build its new_key with orig_key+*key* ;;; Client -> Server: new_key+(md5 new_key) crypted with new_key ;;; Server -> Client: check if the keys match and then authenticate the client. ;;; Server <-> Client: All connections are crypted with new_key ;;; -------------------------------------------------------------------------- (in-package :common-lisp-user) (defpackage :crypt (:use :common-lisp) (:export :crypt :decrypt :generate-key)) (in-package :crypt) (eval-when (:compile-toplevel :load-toplevel :execute) (defun mkstr (&rest args) (with-output-to-string (s) (dolist (a args) (princ a s)))) (defun symb (&rest args) (values (intern (apply #'mkstr args))))) (defmacro circ-loop (binding &body body) "Loop circularly over some sequences. binding is a list of (variable sequence). The loop is the same size of the first sequence. Each variable binding element is bound to each character in the sequence in the second element. See 'test-circ-loop for some usage examples." (labels ((let-body (prefix list) (loop for i from 0 for l in list collect `(,(symb prefix "-" i) (coerce ,(second l) 'list)))) (loop-var-name (l) (symb "LOOP-VAR-" (first l))) (do-body (prefix list) (cons (list (loop-var-name (first list)) (symb prefix "-" 0) `(cdr ,(loop-var-name (first list)))) (loop for i from 1 for l in (cdr list) collect (list (loop-var-name l) (symb prefix "-" i) `(or (cdr ,(loop-var-name l)) ,(symb prefix "-" i)))))) (stop-body (list) (list `(null ,(loop-var-name (first list))))) (symbol-body (list) (loop for l in list collect `(,(first l) (car ,(loop-var-name l)))))) (let ((prefix (gensym))) `(let (,@(let-body prefix binding)) (do ,(do-body prefix binding) ,(stop-body binding) (symbol-macrolet ,(symbol-body binding) ,@body)))))) (defun test-circ-loop () (print 'first-test) (circ-loop ((m "Ceci est un test. éàç^# 1234567890") (k "azerty") (p "test") (o "123")) (print (list m k p o))) (print 'second-test) (terpri) (circ-loop ((a #(1 2 3 4 5 6 7 8 9 10)) (b '(1 2 3)) (c "abcd")) (format t "(~A ~A ~A) " a b c))) (defun crypt-to-list (msg &optional (size 4)) (let ((len (length msg))) (when (zerop (mod len size)) (loop for i from 0 below (/ len size) collect (parse-integer (subseq msg (* i size) (* (1+ i) size)) :radix 16 :junk-allowed t))))) (defun crypt (msg key) (with-output-to-string (str) (circ-loop ((m msg) (k key)) (format str "~4,'0X" (logxor (char-code m) (char-code k)))))) (defun decrypt (msg key) (with-output-to-string (str) (circ-loop ((m (crypt-to-list msg 4)) (k key)) (princ (code-char (logxor m (char-code k))) str)))) (defun test () (let* ((key "11a3e229084349bc25d97e29393ced1d") (msg (format nil "~C Ceci est un test. éàç^# 1234567890" (code-char 100))) (crypt (crypt msg key)) (decrypt (decrypt crypt key))) (format t "msg: ~A~%Crypt: ~A~%Decrypt: ~A~%" msg crypt decrypt))) (let* ((dic (with-output-to-string (str) (dotimes (i 26) (princ (code-char (+ i (char-code #\a))) str) (princ (code-char (+ i (char-code #\A))) str)) (dotimes (i 10) (princ (code-char (+ i (char-code #\0))) str)))) (dic-size (length dic))) (defun generate-key (&optional (min-size 10) (max-size 30)) (let ((length (+ (random (- max-size min-size)) min-size))) (with-output-to-string (str) (dotimes (i length) (princ (aref dic (random dic-size)) str)))))) clfswm-20111015.git51b0a02/contrib/server/key.lisp000066400000000000000000000107611164636077000213640ustar00rootroot00000000000000;;; -------------------------------------------------------------------------- ;;; CLFSWM - FullScreen Window Manager ;;; ;;; -------------------------------------------------------------------------- ;;; Documentation: Client/server connection. ;;; The connection is crypted and you can only connect to the server with the ;;; same clfswm binary. ;;; -------------------------------------------------------------------------- ;;; ;;; (C) 2011 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;; ;;; -------------------------------------------------------------------------- ;;; Server protocole: ;;; Server -> Client: orig_key=a generated key crypted with *key* ;;; Client : build its new_key with orig_key+*key* ;;; Client -> Server: new_key+(md5 new_key) crypted with new_key ;;; Server -> Client: check if the keys match and then authenticate the client. ;;; Server <-> Client: All connections are crypted with new_key ;;; -------------------------------------------------------------------------- (in-package :crypt) (export '(load-new-key save-new-key *key*)) (defparameter *key-filename* "/tmp/.clfswm-server.key") (defparameter *key* "Automatically changed") (defparameter *initial-key-perms* "0600") (defparameter *final-key-perms* "0400") (defun ushell-sh (formatter &rest args) (labels ((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)))) (urun-prog (prog &rest opts &key args (wait t) &allow-other-keys) "Common interface to shell. Does not return anything useful." #+gcl (declare (ignore wait)) (setq opts (remove-plist opts :args :wait)) #+allegro (apply #'excl:run-shell-command (apply #'vector prog prog args) :wait wait opts) #+(and clisp lisp=cl) (apply #'ext:run-program prog :arguments args :wait wait opts) #+(and clisp (not lisp=cl)) (if wait (apply #'lisp:run-program prog :arguments args opts) (lisp:shell (format nil "~a~{ '~a'~} &" prog args))) #+cmu (apply #'ext:run-program prog args :wait wait :output *standard-output* opts) #+gcl (apply #'si:run-process prog args) #+liquid (apply #'lcl:run-program prog args) #+lispworks (apply #'sys::call-system-showing-output (format nil "~a~{ '~a'~}~@[ &~]" prog args (not wait)) opts) #+lucid (apply #'lcl:run-program prog :wait wait :arguments args opts) #+sbcl (apply #'sb-ext:run-program prog args :wait wait :output *standard-output* opts) #+ecl (apply #'ext:run-program prog args opts) #+ccl (apply #'ccl:run-program prog args opts) #-(or allegro clisp cmu gcl liquid lispworks lucid sbcl ccl ecl) (error "Error: urun-prog not implemented"))) (urun-prog "/bin/sh" :args (list "-c" (apply #'format nil formatter args))))) (defun save-new-key () (when (probe-file *key-filename*) (delete-file *key-filename*)) (with-open-file (stream *key-filename* :direction :output :if-exists :supersede :if-does-not-exist :create) (format stream "Nothing useful~%")) (ushell-sh "chmod ~A ~A" *initial-key-perms* *key-filename*) (setf *key* (generate-key)) (with-open-file (stream *key-filename* :direction :output :if-exists :supersede :if-does-not-exist :create) (format stream "~A~%" *key*)) (ushell-sh "chmod ~A ~A" *final-key-perms* *key-filename*)) (defun load-new-key () (if (probe-file *key-filename*) (with-open-file (stream *key-filename* :direction :input) (setf *key* (read-line stream nil nil))) (error "Key file ~S not found" *key-filename*))) clfswm-20111015.git51b0a02/contrib/server/load.lisp000066400000000000000000000036131164636077000215110ustar00rootroot00000000000000;;; -------------------------------------------------------------------------- ;;; CLFSWM - FullScreen Window Manager ;;; ;;; -------------------------------------------------------------------------- ;;; Documentation: CLFSWM Client ;;; -------------------------------------------------------------------------- ;;; ;;; (C) 2011 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;; ;;; -------------------------------------------------------------------------- (defparameter *base-dir* (directory-namestring *load-truename*)) (export '*base-dir*) #+CMU (setf ext:*gc-verbose* nil) #+SBCL (require :asdf) #+SBCL (require :sb-posix) #-ASDF (let ((asdf-file (make-pathname :host (pathname-host *base-dir*) :device (pathname-device *base-dir*) :directory (pathname-directory *base-dir*) :name "asdf" :type "lisp"))) (if (probe-file asdf-file) (load asdf-file) (load (make-pathname :host (pathname-host *base-dir*) :device (pathname-device *base-dir*) :directory (butlast (pathname-directory *base-dir*)) :name "asdf" :type "lisp")))) (push *base-dir* asdf:*central-registry*) (asdf:oos 'asdf:load-op :clfswm-client) (in-package :clfswm-client) (start-client nil) clfswm-20111015.git51b0a02/contrib/server/md5.lisp000066400000000000000000000777711164636077000212770ustar00rootroot00000000000000;;;; This file implements The MD5 Message-Digest Algorithm, as defined in ;;;; RFC 1321 by R. Rivest, published April 1992. ;;;; ;;;; It was written by Pierre R. Mai, with copious input from the ;;;; cmucl-help mailing-list hosted at cons.org, in November 2001 and ;;;; has been placed into the public domain. ;;;; ;;;; While the implementation should work on all conforming Common ;;;; Lisp implementations, it has only been optimized for CMU CL, ;;;; where it achieved comparable performance to the standard md5sum ;;;; utility (within a factor of 1.5 or less on iA32 and UltraSparc ;;;; hardware). ;;;; ;;;; Since the implementation makes heavy use of arithmetic on ;;;; (unsigned-byte 32) numbers, acceptable performance is likely only ;;;; on CL implementations that support unboxed arithmetic on such ;;;; numbers in some form. For other CL implementations a 16bit ;;;; implementation of MD5 is probably more suitable. ;;;; ;;;; The code implements correct operation for files of unbounded size ;;;; as is, at the cost of having to do a single generic integer ;;;; addition for each call to update-md5-state. If you call ;;;; update-md5-state frequently with little data, this can pose a ;;;; performance problem. If you can live with a size restriction of ;;;; 512 MB, then you can enable fast fixnum arithmetic by putting ;;;; :md5-small-length onto *features* prior to compiling this file. ;;;; ;;;; Testing code can be compiled by including :md5-testing on ;;;; *features* prior to compilation. In that case evaluating ;;;; (md5::test-rfc1321) will run all the test-cases present in ;;;; Appendix A.5 of RFC 1321 and report on the results. ;;;; Evaluating (md5::test-other) will run further test-cases ;;;; gathered by the author to cover regressions, etc. ;;;; ;;;; This software is "as is", and has no warranty of any kind. The ;;;; authors assume no responsibility for the consequences of any use ;;;; of this software. (defpackage #:md5 (:use #:cl) (:export ;; Low-Level types and functions #:md5-regs #:initial-md5-regs #:md5regs-digest #:update-md5-block #:fill-block #:fill-block-ub8 #:fill-block-char ;; Mid-Level types and functions #:md5-state #:md5-state-p #:make-md5-state #:update-md5-state #:finalize-md5-state ;; High-Level functions on sequences, streams and files #:md5sum-sequence #:md5sum-stream #:md5sum-file ;; Very High level functions #:md5)) (in-package #:md5) #+cmu (eval-when (:compile-toplevel) (defparameter *old-expansion-limit* ext:*inline-expansion-limit*) (setq ext:*inline-expansion-limit* (max ext:*inline-expansion-limit* 1000))) #+cmu (eval-when (:compile-toplevel :execute) (defparameter *old-features* *features*) (pushnew (c:backend-byte-order c:*target-backend*) *features*)) ;;; Section 2: Basic Datatypes #-lispworks (eval-when (:compile-toplevel :load-toplevel :execute) (deftype ub32 () "Corresponds to the 32bit quantity word of the MD5 Spec" `(unsigned-byte 32))) #+lispworks (deftype ub32 () "Corresponds to the 32bit quantity word of the MD5 Spec" `(unsigned-byte 32)) (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro assemble-ub32 (a b c d) "Assemble an ub32 value from the given (unsigned-byte 8) values, where a is the intended low-order byte and d the high-order byte." `(the ub32 (logior (ash ,d 24) (ash ,c 16) (ash ,b 8) ,a)))) ;;; Section 3.4: Auxilliary functions (declaim (inline f g h i) (ftype (function (ub32 ub32 ub32) ub32) f g h i)) (defun f (x y z) (declare (type ub32 x y z) (optimize (speed 3) (safety 0) (space 0) (debug 0))) #+cmu (kernel:32bit-logical-or (kernel:32bit-logical-and x y) (kernel:32bit-logical-andc1 x z)) #-cmu (logior (logand x y) (logandc1 x z))) (defun g (x y z) (declare (type ub32 x y z) (optimize (speed 3) (safety 0) (space 0) (debug 0))) #+cmu (kernel:32bit-logical-or (kernel:32bit-logical-and x z) (kernel:32bit-logical-andc2 y z)) #-cmu (logior (logand x z) (logandc2 y z))) (defun h (x y z) (declare (type ub32 x y z) (optimize (speed 3) (safety 0) (space 0) (debug 0))) #+cmu (kernel:32bit-logical-xor x (kernel:32bit-logical-xor y z)) #-cmu (logxor x y z)) (defun i (x y z) (declare (type ub32 x y z) (optimize (speed 3) (safety 0) (space 0) (debug 0))) #+cmu (kernel:32bit-logical-xor y (kernel:32bit-logical-orc2 x z)) #-cmu (ldb (byte 32 0) (logxor y (logorc2 x z)))) (declaim (inline mod32+) (ftype (function (ub32 ub32) ub32) mod32+)) (defun mod32+ (a b) (declare (type ub32 a b) (optimize (speed 3) (safety 0) (space 0) (debug 0))) (ldb (byte 32 0) (+ a b))) #+cmu (define-compiler-macro mod32+ (a b) `(ext:truly-the ub32 (+ ,a ,b))) (declaim (inline rol32) (ftype (function (ub32 (unsigned-byte 5)) ub32) rol32)) (defun rol32 (a s) (declare (type ub32 a) (type (unsigned-byte 5) s) (optimize (speed 3) (safety 0) (space 0) (debug 0))) #+cmu (kernel:32bit-logical-or #+little-endian (kernel:shift-towards-end a s) #+big-endian (kernel:shift-towards-start a s) (ash a (- s 32))) #-cmu (logior (ldb (byte 32 0) (ash a s)) (ash a (- s 32)))) ;;; Section 3.4: Table T (eval-when (:compile-toplevel :load-toplevel :execute) (defparameter *t* (make-array 64 :element-type 'ub32 :initial-contents (loop for i from 1 to 64 collect (truncate (* 4294967296 (abs (sin (float i 0.0d0))))))))) ;;; Section 3.4: Helper Macro for single round definitions (defmacro with-md5-round ((op block) &rest clauses) (loop for (a b c d k s i) in clauses collect `(setq ,a (mod32+ ,b (rol32 (mod32+ (mod32+ ,a (,op ,b ,c ,d)) (mod32+ (aref ,block ,k) ,(aref *t* (1- i)))) ,s))) into result finally (return `(progn ,@result)))) ;;; Section 3.3: (Initial) MD5 Working Set (deftype md5-regs () "The working state of the MD5 algorithm, which contains the 4 32-bit registers A, B, C and D." `(simple-array (unsigned-byte 32) (4))) (defmacro md5-regs-a (regs) `(aref ,regs 0)) (defmacro md5-regs-b (regs) `(aref ,regs 1)) (defmacro md5-regs-c (regs) `(aref ,regs 2)) (defmacro md5-regs-d (regs) `(aref ,regs 3)) (defconstant +md5-magic-a+ (assemble-ub32 #x01 #x23 #x45 #x67) "Initial value of Register A of the MD5 working state.") (defconstant +md5-magic-b+ (assemble-ub32 #x89 #xab #xcd #xef) "Initial value of Register B of the MD5 working state.") (defconstant +md5-magic-c+ (assemble-ub32 #xfe #xdc #xba #x98) "Initial value of Register C of the MD5 working state.") (defconstant +md5-magic-d+ (assemble-ub32 #x76 #x54 #x32 #x10) "Initial value of Register D of the MD5 working state.") (declaim (inline initial-md5-regs)) (defun initial-md5-regs () "Create the initial working state of an MD5 run." (declare (optimize (speed 3) (safety 0) (space 0) (debug 0))) (let ((regs (make-array 4 :element-type '(unsigned-byte 32)))) (declare (type md5-regs regs)) (setf (md5-regs-a regs) +md5-magic-a+ (md5-regs-b regs) +md5-magic-b+ (md5-regs-c regs) +md5-magic-c+ (md5-regs-d regs) +md5-magic-d+) regs)) ;;; Section 3.4: Operation on 16-Word Blocks (defun update-md5-block (regs block) "This is the core part of the MD5 algorithm. It takes a complete 16 word block of input, and updates the working state in A, B, C, and D accordingly." (declare (type md5-regs regs) (type (simple-array ub32 (16)) block) (optimize (speed 3) (safety 0) (space 0) (debug 0))) (let ((A (md5-regs-a regs)) (B (md5-regs-b regs)) (C (md5-regs-c regs)) (D (md5-regs-d regs))) (declare (type ub32 A B C D)) ;; Round 1 (with-md5-round (f block) (A B C D 0 7 1)(D A B C 1 12 2)(C D A B 2 17 3)(B C D A 3 22 4) (A B C D 4 7 5)(D A B C 5 12 6)(C D A B 6 17 7)(B C D A 7 22 8) (A B C D 8 7 9)(D A B C 9 12 10)(C D A B 10 17 11)(B C D A 11 22 12) (A B C D 12 7 13)(D A B C 13 12 14)(C D A B 14 17 15)(B C D A 15 22 16)) ;; Round 2 (with-md5-round (g block) (A B C D 1 5 17)(D A B C 6 9 18)(C D A B 11 14 19)(B C D A 0 20 20) (A B C D 5 5 21)(D A B C 10 9 22)(C D A B 15 14 23)(B C D A 4 20 24) (A B C D 9 5 25)(D A B C 14 9 26)(C D A B 3 14 27)(B C D A 8 20 28) (A B C D 13 5 29)(D A B C 2 9 30)(C D A B 7 14 31)(B C D A 12 20 32)) ;; Round 3 (with-md5-round (h block) (A B C D 5 4 33)(D A B C 8 11 34)(C D A B 11 16 35)(B C D A 14 23 36) (A B C D 1 4 37)(D A B C 4 11 38)(C D A B 7 16 39)(B C D A 10 23 40) (A B C D 13 4 41)(D A B C 0 11 42)(C D A B 3 16 43)(B C D A 6 23 44) (A B C D 9 4 45)(D A B C 12 11 46)(C D A B 15 16 47)(B C D A 2 23 48)) ;; Round 4 (with-md5-round (i block) (A B C D 0 6 49)(D A B C 7 10 50)(C D A B 14 15 51)(B C D A 5 21 52) (A B C D 12 6 53)(D A B C 3 10 54)(C D A B 10 15 55)(B C D A 1 21 56) (A B C D 8 6 57)(D A B C 15 10 58)(C D A B 6 15 59)(B C D A 13 21 60) (A B C D 4 6 61)(D A B C 11 10 62)(C D A B 2 15 63)(B C D A 9 21 64)) ;; Update and return (setf (md5-regs-a regs) (mod32+ (md5-regs-a regs) A) (md5-regs-b regs) (mod32+ (md5-regs-b regs) B) (md5-regs-c regs) (mod32+ (md5-regs-c regs) C) (md5-regs-d regs) (mod32+ (md5-regs-d regs) D)) regs)) ;;; Section 3.4: Converting 8bit-vectors into 16-Word Blocks (declaim (inline fill-block fill-block-ub8 fill-block-char)) (defun fill-block-ub8 (block buffer offset) "Convert a complete 64 (unsigned-byte 8) input vector segment starting from offset into the given 16 word MD5 block." (declare (type (integer 0 #.(- most-positive-fixnum 64)) offset) (type (simple-array ub32 (16)) block) (type (simple-array (unsigned-byte 8) (*)) buffer) (optimize (speed 3) (safety 0) (space 0) (debug 0))) ;; #+(and :cmu :little-endian) ;; (kernel:bit-bash-copy ;; There is a problem with this specific code (PBrochard) ;; buffer (+ (* vm:vector-data-offset vm:word-bits) (* offset vm:byte-bits)) ;; block (* vm:vector-data-offset vm:word-bits) ;; (* 64 vm:byte-bits)) ;; #-(and :cmu :little-endian) (loop for i of-type (integer 0 16) from 0 for j of-type (integer 0 #.most-positive-fixnum) from offset to (+ offset 63) by 4 do (setf (aref block i) (assemble-ub32 (aref buffer j) (aref buffer (+ j 1)) (aref buffer (+ j 2)) (aref buffer (+ j 3)))))) (defun fill-block-char (block buffer offset) "Convert a complete 64 character input string segment starting from offset into the given 16 word MD5 block." (declare (type (integer 0 #.(- most-positive-fixnum 64)) offset) (type (simple-array ub32 (16)) block) (type simple-string buffer) (optimize (speed 3) (safety 0) (space 0) (debug 0))) ;; #+(and :cmu :little-endian) ;; (kernel:bit-bash-copy ;; There is a problem with this specific code (PBrochard) ;; buffer (+ (* vm:vector-data-offset vm:word-bits) (* offset vm:byte-bits)) ;; block (* vm:vector-data-offset vm:word-bits) ;; (* 64 vm:byte-bits)) ;; #-(and :cmu :little-endian) (loop for i of-type (integer 0 16) from 0 for j of-type (integer 0 #.most-positive-fixnum) from offset to (+ offset 63) by 4 do (setf (aref block i) (assemble-ub32 (char-code (schar buffer j)) (char-code (schar buffer (+ j 1))) (char-code (schar buffer (+ j 2))) (char-code (schar buffer (+ j 3))))))) (defun fill-block (block buffer offset) "Convert a complete 64 byte input vector segment into the given 16 word MD5 block. This currently works on (unsigned-byte 8) and character simple-arrays, via the functions `fill-block-ub8' and `fill-block-char' respectively." (declare (type (integer 0 #.(- most-positive-fixnum 64)) offset) (type (simple-array ub32 (16)) block) (type (simple-array * (*)) buffer) (optimize (speed 3) (safety 0) (space 0) (debug 0))) (etypecase buffer ((simple-array (unsigned-byte 8) (*)) (fill-block-ub8 block buffer offset)) (simple-string (fill-block-char block buffer offset)))) ;;; Section 3.5: Message Digest Output (declaim (inline md5regs-digest)) (defun md5regs-digest (regs) "Create the final 16 byte message-digest from the MD5 working state in regs. Returns a (simple-array (unsigned-byte 8) (16))." (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)) (type md5-regs regs)) (let ((result (make-array 16 :element-type '(unsigned-byte 8)))) (declare (type (simple-array (unsigned-byte 8) (16)) result)) (macrolet ((frob (reg offset) (let ((var (gensym))) `(let ((,var ,reg)) (declare (type ub32 ,var)) (setf (aref result ,offset) (ldb (byte 8 0) ,var) (aref result ,(+ offset 1)) (ldb (byte 8 8) ,var) (aref result ,(+ offset 2)) (ldb (byte 8 16) ,var) (aref result ,(+ offset 3)) (ldb (byte 8 24) ,var)))))) (frob (md5-regs-a regs) 0) (frob (md5-regs-b regs) 4) (frob (md5-regs-c regs) 8) (frob (md5-regs-d regs) 12)) result)) ;;; Mid-Level Drivers (defstruct (md5-state (:constructor make-md5-state ()) (:copier)) (regs (initial-md5-regs) :type md5-regs :read-only t) (amount 0 :type #-md5-small-length (integer 0 *) #+md5-small-length (unsigned-byte 29)) (block (make-array 16 :element-type '(unsigned-byte 32)) :read-only t :type (simple-array (unsigned-byte 32) (16))) (buffer (make-array 64 :element-type '(unsigned-byte 8)) :read-only t :type (simple-array (unsigned-byte 8) (64))) (buffer-index 0 :type (integer 0 63)) (finalized-p nil)) (declaim (inline copy-to-buffer)) (defun copy-to-buffer (from from-offset count buffer buffer-offset) "Copy a partial segment from input vector from starting at from-offset and copying count elements into the 64 byte buffer starting at buffer-offset." (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)) (type (unsigned-byte 29) from-offset) (type (integer 0 63) count buffer-offset) (type (simple-array * (*)) from) (type (simple-array (unsigned-byte 8) (64)) buffer)) ;; #+cmu ;; (kernel:bit-bash-copy ;; There is a problem with this specific code (PBrochard) ;; from (+ (* vm:vector-data-offset vm:word-bits) (* from-offset vm:byte-bits)) ;; buffer (+ (* vm:vector-data-offset vm:word-bits) ;; (* buffer-offset vm:byte-bits)) ;; (* count vm:byte-bits)) ;; #-cmu (etypecase from (simple-string (loop for buffer-index of-type (integer 0 64) from buffer-offset for from-index of-type fixnum from from-offset below (+ from-offset count) do (setf (aref buffer buffer-index) (char-code (schar (the simple-string from) from-index))))) ((simple-array (unsigned-byte 8) (*)) (loop for buffer-index of-type (integer 0 64) from buffer-offset for from-index of-type fixnum from from-offset below (+ from-offset count) do (setf (aref buffer buffer-index) (aref (the (simple-array (unsigned-byte 8) (*)) from) from-index)))))) (defun update-md5-state (state sequence &key (start 0) (end (length sequence))) "Update the given md5-state from sequence, which is either a simple-string or a simple-array with element-type (unsigned-byte 8), bounded by start and end, which must be numeric bounding-indices." (declare (type md5-state state) (type (simple-array * (*)) sequence) (type fixnum start end) (optimize (speed 3) #+cmu (safety 0) (space 0) (debug 0)) #+cmu (ext:optimize-interface (safety 1) (debug 1))) (let ((regs (md5-state-regs state)) (block (md5-state-block state)) (buffer (md5-state-buffer state))) (declare (type md5-regs regs) (type (simple-array (unsigned-byte 32) (16)) block) (type (simple-array (unsigned-byte 8) (64)) buffer)) ;; Handle old rest (unless (zerop (md5-state-buffer-index state)) (let* ((buffer-index (md5-state-buffer-index state)) (remainder (- 64 buffer-index)) (length (- end start)) (amount (min remainder length))) (declare (type (integer 0 63) buffer-index remainder amount) (type fixnum length)) (copy-to-buffer sequence start amount buffer buffer-index) (setf (md5-state-amount state) #-md5-small-length (+ (md5-state-amount state) amount) #+md5-small-length (the (unsigned-byte 29) (+ (md5-state-amount state) amount))) (setq start (the fixnum (+ start amount))) (if (< length remainder) (setf (md5-state-buffer-index state) (the (integer 0 63) (+ buffer-index amount))) (progn (fill-block-ub8 block buffer 0) (update-md5-block regs block) (setf (md5-state-buffer-index state) 0))))) ;; Leave when nothing to do (when (>= start end) (return-from update-md5-state state)) ;; Handle main-part and new-rest (etypecase sequence ((simple-array (unsigned-byte 8) (*)) (locally (declare (type (simple-array (unsigned-byte 8) (*)) sequence)) (loop for offset of-type (unsigned-byte 29) from start below end by 64 until (< (- end offset) 64) do (fill-block-ub8 block sequence offset) (update-md5-block regs block) finally (let ((amount (- end offset))) (unless (zerop amount) (copy-to-buffer sequence offset amount buffer 0)) (setf (md5-state-buffer-index state) amount))))) (simple-string (locally (declare (type simple-string sequence)) (loop for offset of-type (unsigned-byte 29) from start below end by 64 until (< (- end offset) 64) do (fill-block-char block sequence offset) (update-md5-block regs block) finally (let ((amount (- end offset))) (unless (zerop amount) (copy-to-buffer sequence offset amount buffer 0)) (setf (md5-state-buffer-index state) amount)))))) (setf (md5-state-amount state) #-md5-small-length (+ (md5-state-amount state) (the fixnum (- end start))) #+md5-small-length (the (unsigned-byte 29) (+ (md5-state-amount state) (the fixnum (- end start))))) state)) (defun finalize-md5-state (state) "If the given md5-state has not already been finalized, finalize it, by processing any remaining input in its buffer, with suitable padding and appended bit-length, as specified by the MD5 standard. The resulting MD5 message-digest is returned as an array of sixteen (unsigned-byte 8) values. Calling `update-md5-state' after a call to `finalize-md5-state' results in unspecified behaviour." (declare (type md5-state state) (optimize (speed 3) #+cmu (safety 0) (space 0) (debug 0)) #+cmu (ext:optimize-interface (safety 1) (debug 1))) (or (md5-state-finalized-p state) (let ((regs (md5-state-regs state)) (block (md5-state-block state)) (buffer (md5-state-buffer state)) (buffer-index (md5-state-buffer-index state)) (total-length (* 8 (md5-state-amount state)))) (declare (type md5-regs regs) (type (integer 0 63) buffer-index) (type (simple-array ub32 (16)) block) (type (simple-array (unsigned-byte 8) (*)) buffer)) ;; Add mandatory bit 1 padding (setf (aref buffer buffer-index) #x80) ;; Fill with 0 bit padding (loop for index of-type (integer 0 64) from (1+ buffer-index) below 64 do (setf (aref buffer index) #x00)) (fill-block-ub8 block buffer 0) ;; Flush block first if length wouldn't fit (when (>= buffer-index 56) (update-md5-block regs block) ;; Create new fully 0 padded block (loop for index of-type (integer 0 16) from 0 below 16 do (setf (aref block index) #x00000000))) ;; Add 64bit message bit length (setf (aref block 14) (ldb (byte 32 0) total-length)) #-md5-small-length (setf (aref block 15) (ldb (byte 32 32) total-length)) ;; Flush last block (update-md5-block regs block) ;; Done, remember digest for later calls (setf (md5-state-finalized-p state) (md5regs-digest regs))))) ;;; High-Level Drivers (defun md5sum-sequence (sequence &key (start 0) end) "Calculate the MD5 message-digest of data in sequence. On CMU CL this works for all sequences whose element-type is supported by the underlying MD5 routines, on other implementations it only works for 1d simple-arrays with such element types." (declare (optimize (speed 3) (space 0) (debug 0)) (type vector sequence) (type fixnum start)) (let ((state (make-md5-state))) (declare (type md5-state state)) #+cmu (lisp::with-array-data ((data sequence) (real-start start) (real-end end)) (update-md5-state state data :start real-start :end real-end)) #-cmu (let ((real-end (or end (length sequence)))) (declare (type fixnum real-end)) (update-md5-state state sequence :start start :end real-end)) (finalize-md5-state state))) (eval-when (:compile-toplevel :load-toplevel :execute) (defconstant +buffer-size+ (* 128 1024) "Size of internal buffer to use for md5sum-stream and md5sum-file operations. This should be a multiple of 64, the MD5 block size.")) (deftype buffer-index () `(integer 0 ,+buffer-size+)) (defun md5sum-stream (stream) "Calculate an MD5 message-digest of the contents of stream. Its element-type has to be either (unsigned-byte 8) or character." (declare (optimize (speed 3) (space 0) (debug 0))) (let ((state (make-md5-state))) (declare (type md5-state state)) (cond ((equal (stream-element-type stream) '(unsigned-byte 8)) (let ((buffer (make-array +buffer-size+ :element-type '(unsigned-byte 8)))) (declare (type (simple-array (unsigned-byte 8) (#.+buffer-size+)) buffer)) (loop for bytes of-type buffer-index = (read-sequence buffer stream) do (update-md5-state state buffer :end bytes) until (< bytes +buffer-size+) finally (return (finalize-md5-state state))))) ((equal (stream-element-type stream) 'character) (let ((buffer (make-string +buffer-size+))) (declare (type (simple-string #.+buffer-size+) buffer)) (loop for bytes of-type buffer-index = (read-sequence buffer stream) do (update-md5-state state buffer :end bytes) until (< bytes +buffer-size+) finally (return (finalize-md5-state state))))) (t (error "Unsupported stream element-type ~S for stream ~S." (stream-element-type stream) stream))))) (defun md5sum-file (pathname) "Calculate the MD5 message-digest of the file specified by pathname." (declare (optimize (speed 3) (space 0) (debug 0))) (with-open-file (stream pathname :element-type '(unsigned-byte 8)) (md5sum-stream stream))) (defun md5-string (md5-digest) (format nil "~(~{~2,'0X~}~)" (map 'list #'identity md5-digest))) (defun md5 (sequence) (md5-string (md5sum-sequence sequence))) #+md5-testing (defconstant +rfc1321-testsuite+ '(("" . "d41d8cd98f00b204e9800998ecf8427e") ("a" ."0cc175b9c0f1b6a831c399e269772661") ("abc" . "900150983cd24fb0d6963f7d28e17f72") ("message digest" . "f96b697d7cb7938d525a2f31aaf161d0") ("abcdefghijklmnopqrstuvwxyz" . "c3fcd3d76192e4007dfb496cca67e13b") ("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" . "d174ab98d277d9f5a5611c2c9f419d9f") ("12345678901234567890123456789012345678901234567890123456789012345678901234567890" . "57edf4a22be3c955ac49da2e2107b67a")) "AList of test input strings and stringified message-digests according to the test suite in Appendix A.5 of RFC 1321") #+md5-testing (defconstant +other-testsuite+ '(;; From padding bug report by Edi Weitz ("1631901HERR BUCHHEISTERCITROEN NORD1043360796beckenbauer" . "d734945e5930bb28859ccd13c830358b") ;; Test padding for strings from 0 to 69*8 bits in size. ("" . "d41d8cd98f00b204e9800998ecf8427e") ("a" . "0cc175b9c0f1b6a831c399e269772661") ("aa" . "4124bc0a9335c27f086f24ba207a4912") ("aaa" . "47bce5c74f589f4867dbd57e9ca9f808") ("aaaa" . "74b87337454200d4d33f80c4663dc5e5") ("aaaaa" . "594f803b380a41396ed63dca39503542") ("aaaaaa" . "0b4e7a0e5fe84ad35fb5f95b9ceeac79") ("aaaaaaa" . "5d793fc5b00a2348c3fb9ab59e5ca98a") ("aaaaaaaa" . "3dbe00a167653a1aaee01d93e77e730e") ("aaaaaaaaa" . "552e6a97297c53e592208cf97fbb3b60") ("aaaaaaaaaa" . "e09c80c42fda55f9d992e59ca6b3307d") ("aaaaaaaaaaa" . "d57f21e6a273781dbf8b7657940f3b03") ("aaaaaaaaaaaa" . "45e4812014d83dde5666ebdf5a8ed1ed") ("aaaaaaaaaaaaa" . "c162de19c4c3731ca3428769d0cd593d") ("aaaaaaaaaaaaaa" . "451599a5f9afa91a0f2097040a796f3d") ("aaaaaaaaaaaaaaa" . "12f9cf6998d52dbe773b06f848bb3608") ("aaaaaaaaaaaaaaaa" . "23ca472302f49b3ea5592b146a312da0") ("aaaaaaaaaaaaaaaaa" . "88e42e96cc71151b6e1938a1699b0a27") ("aaaaaaaaaaaaaaaaaa" . "2c60c24e7087e18e45055a33f9a5be91") ("aaaaaaaaaaaaaaaaaaa" . "639d76897485360b3147e66e0a8a3d6c") ("aaaaaaaaaaaaaaaaaaaa" . "22d42eb002cefa81e9ad604ea57bc01d") ("aaaaaaaaaaaaaaaaaaaaa" . "bd049f221af82804c5a2826809337c9b") ("aaaaaaaaaaaaaaaaaaaaaa" . "ff49cfac3968dbce26ebe7d4823e58bd") ("aaaaaaaaaaaaaaaaaaaaaaa" . "d95dbfee231e34cccb8c04444412ed7d") ("aaaaaaaaaaaaaaaaaaaaaaaa" . "40edae4bad0e5bf6d6c2dc5615a86afb") ("aaaaaaaaaaaaaaaaaaaaaaaaa" . "a5a8bfa3962f49330227955e24a2e67c") ("aaaaaaaaaaaaaaaaaaaaaaaaaa" . "ae791f19bdf77357ff10bb6b0e97e121") ("aaaaaaaaaaaaaaaaaaaaaaaaaaa" . "aaab9c59a88bf0bdfcb170546c5459d6") ("aaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "b0f0545856af1a340acdedce23c54b97") ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "f7ce3d7d44f3342107d884bfa90c966a") ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "59e794d45697b360e18ba972bada0123") ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "3b0845db57c200be6052466f87b2198a") ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "5eca9bd3eb07c006cd43ae48dfde7fd3") ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "b4f13cb081e412f44e99742cb128a1a5") ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "4c660346451b8cf91ef50f4634458d41") ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "11db24dc3f6c2145701db08625dd6d76") ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "80dad3aad8584778352c68ab06250327") ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "1227fe415e79db47285cb2689c93963f") ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "8e084f489f1bdf08c39f98ff6447ce6d") ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "08b2f2b0864bac1ba1585043362cbec9") ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "4697843037d962f62a5a429e611e0f5f") ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "10c4da18575c092b486f8ab96c01c02f") ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "af205d729450b663f48b11d839a1c8df") ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "0d3f91798fac6ee279ec2485b25f1124") ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "4c3c7c067634daec9716a80ea886d123") ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "d1e358e6e3b707282cdd06e919f7e08c") ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "8c6ded4f0af86e0a7e301f8a716c4363") ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "4c2d8bcb02d982d7cb77f649c0a2dea8") ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "bdb662f765cd310f2a547cab1cfecef6") ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "08ff5f7301d30200ab89169f6afdb7af") ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "6eb6a030bcce166534b95bc2ab45d9cf") ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "1bb77918e5695c944be02c16ae29b25e") ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "b6fe77c19f0f0f4946c761d62585bfea") ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "e9e7e260dce84ffa6e0e7eb5fd9d37fc") ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "eced9e0b81ef2bba605cbc5e2e76a1d0") ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "ef1772b6dff9a122358552954ad0df65") ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "3b0c8ac703f828b04c6c197006d17218") ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "652b906d60af96844ebd21b674f35e93") ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "dc2f2f2462a0d72358b2f99389458606") ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "762fc2665994b217c52c3c2eb7d9f406") ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "cc7ed669cf88f201c3297c6a91e1d18d") ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "cced11f7bbbffea2f718903216643648") ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "24612f0ce2c9d2cf2b022ef1e027a54f") ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "b06521f39153d618550606be297466d5") ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "014842d480b571495a4a0363793f7367") ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "c743a45e0d2e6a95cb859adae0248435") ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "def5d97e01e1219fb2fc8da6c4d6ba2f") ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "92cb737f8687ccb93022fdb411a77cca") ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "a0d1395c7fb36247bfe2d49376d9d133") ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "ab75504250558b788f99d1ebd219abf2")) "AList of test input strings and stringified message-digests according to my additional test suite") #+md5-testing (defun test-with-testsuite (testsuite) (loop for count from 1 for (source . md5-string) in testsuite for md5-digest = (md5sum-sequence source) for md5-result-string = (md5-string md5-digest) do (format *trace-output* "~2&Test-Case ~D:~% Input: ~S~% Required: ~A~% Returned: ~A~%" count source md5-string md5-result-string) when (string= md5-string md5-result-string) do (format *trace-output* " OK~%") else count 1 into failed and do (format *trace-output* " FAILED~%") finally (format *trace-output* "~2&~[All ~D test cases succeeded~:;~:*~D of ~D test cases failed~].~%" failed (1- count)) (return (zerop failed)))) #+md5-testing (defun test-rfc1321 () (test-with-testsuite +rfc1321-testsuite+)) #+md5-testing (defun test-other () (test-with-testsuite +other-testsuite+)) #+cmu (eval-when (:compile-toplevel :execute) (setq *features* *old-features*)) #+cmu (eval-when (:compile-toplevel) (setq ext:*inline-expansion-limit* *old-expansion-limit*)) clfswm-20111015.git51b0a02/contrib/server/net.lisp000066400000000000000000001011131164636077000213520ustar00rootroot00000000000000;;; Network Access ;;; ;;; Copyright (C) 1999-2008 by Sam Steingold ;;; This is open-source software. ;;; GNU Lesser General Public License (LGPL) is applicable: ;;; No warranty; you may copy/modify/redistribute under the same ;;; conditions with the source code. ;;; See ;;; for details and the precise copyright document. ;;; ;;; $Id: net.lisp,v 1.64 2008/10/20 19:54:38 sds Exp $ ;;; $Source: /cvsroot-fuse/clocc/clocc/src/port/net.lisp,v $ (in-package :cl-user) (eval-when (:compile-toplevel :load-toplevel :execute) ;;(require "ext.lisp") ;; `getenv' ;;(require "sys.lisp") #+(or cmu scl) (require :simple-streams) ; for `set-socket-stream-format' #+cormanlisp (require :winsock) #+lispworks (require "comm") #+(and sbcl (not (or db-sockets net.sbcl.sockets))) (progn (require :sb-bsd-sockets) (pushnew :sb-bsd-sockets *features*))) (defpackage :port (:use :common-lisp) (:export :resolve-host-ipaddr :ipaddr-to-dotted :dotted-to-ipaddr :ipaddr-closure :hostent :hostent-name :hostent-aliases :hostent-addr-list :hostent-addr-type :socket :open-socket :socket-host/port :socket-string :socket-server :set-socket-stream-format :socket-accept :open-socket-server :socket-server-close :socket-server-host/port :socket-service-port :servent-name :servent-aliases :servent-port :servent-proto :servent-p :servent :network :timeout :login :net-path)) (in-package :port) (define-condition code (error) ((proc :reader code-proc :initarg :proc :initform nil) (mesg :type (or null simple-string) :reader code-mesg :initarg :mesg :initform nil) (args :type list :reader code-args :initarg :args :initform nil)) (:documentation "An error in the user code.") (:report (lambda (cc out) (declare (stream out)) (format out "[~s]~@[ ~?~]" (code-proc cc) (code-mesg cc) (code-args cc))))) (define-condition case-error (code) ((mesg :type simple-string :reader code-mesg :initform "`~s' evaluated to `~s', not one of [~@{`~s'~^ ~}]")) (:documentation "An error in a case statement. This carries the function name which makes the error message more useful.")) (define-condition not-implemented (code) ((mesg :type simple-string :reader code-mesg :initform "not implemented for ~a [~a]") (args :type list :reader code-args :initform (list (lisp-implementation-type) (lisp-implementation-version)))) (:documentation "Your implementation does not support this functionality.")) (defmacro with-gensyms ((title &rest names) &body body) "Bind symbols in NAMES to gensyms. TITLE is a string - `gensym' prefix. Inspired by Paul Graham, , p. 145." `(let (,@(mapcar (lambda (sy) `(,sy (gensym ,(concatenate 'string title (symbol-name sy) "-")))) names)) ,@body)) (defmacro defconst (name type init doc) "Define a typed constant." `(progn (declaim (type ,type ,name)) ;; since constant redefinition must be the same under EQL, there ;; can be no constants other than symbols, numbers and characters ;; see ANSI CL spec 3.1.2.1.1.3 "Constant Variables" (,(if (subtypep type '(or symbol number character)) 'defconstant 'defvar) ,name (the ,type ,init) ,doc))) (defconst +eof+ cons (list '+eof+) "*The end-of-file object. To be passed as the third arg to `read' and checked against using `eq'.") (defun string-tokens (string &key (start 0) end max ((:package *package*) (find-package :keyword))) "Read from STRING repeatedly, starting with START, up to MAX tokens. Return the list of objects read and the final index in STRING. Binds `*package*' to the KEYWORD package (or argument), so that the bare symbols are read as keywords." (declare (type (or null fixnum) max) (type fixnum start)) (if max (do ((beg start) obj res (num 0 (1+ num))) ((or (= max num) (and end (>= beg end))) (values (nreverse res) beg)) (declare (fixnum beg num)) (setf (values obj beg) (read-from-string string nil +eof+ :start beg :end end)) (if (eq obj +eof+) (return (values (nreverse res) beg)) (push obj res))) (with-input-from-string (st string :start start :end end) (loop :for obj = (read st nil st) :until (eq obj st) :collect obj)))) (defmacro compose (&rest functions) "Macro: compose functions or macros of 1 argument into a lambda. E.g., (compose abs (dl-val zz) 'key) ==> (lambda (yy) (abs (funcall (dl-val zz) (funcall key yy))))" (labels ((rec (xx yy) (let ((rr (list (car xx) (if (cdr xx) (rec (cdr xx) yy) yy)))) (if (consp (car xx)) (cons 'funcall (if (eq (caar xx) 'quote) (cons (cadar xx) (cdr rr)) rr)) rr)))) (with-gensyms ("COMPOSE-" arg) `(lambda (,arg) ,(rec functions arg))))) ;;; ;;; {{{ name resolution ;;; (declaim (ftype (function ((unsigned-byte 32)) (values simple-string)) ipaddr-to-dotted)) (defun ipaddr-to-dotted (ipaddr) "Number --> string." (declare (type (unsigned-byte 32) ipaddr)) #+allegro (socket:ipaddr-to-dotted ipaddr) #+(or openmcl ccl) (ccl:ipaddr-to-dotted ipaddr) #+(and sbcl net.sbcl.sockets) (net.sbcl.sockets:ipaddr-to-dot-string ipaddr) #-(or allegro openmcl ccl (and sbcl net.sbcl.sockets)) (format nil "~d.~d.~d.~d" (logand #xff (ash ipaddr -24)) (logand #xff (ash ipaddr -16)) (logand #xff (ash ipaddr -8)) (logand #xff ipaddr))) (declaim (ftype (function (string) (values (unsigned-byte 32))) dotted-to-ipaddr)) (defun dotted-to-ipaddr (dotted) "String --> number." (declare (string dotted)) #+allegro (socket:dotted-to-ipaddr dotted) #+(or openmcl ccl) (ccl:dotted-to-ipaddr dotted) #+(and sbcl net.sbcl.sockets) (net.sbcl.sockets:dot-string-to-ipaddr dotted) #-(or allegro openmcl ccl (and sbcl net.sbcl.sockets)) (let ((ll (string-tokens (substitute #\Space #\. dotted)))) (+ (ash (first ll) 24) (ash (second ll) 16) (ash (third ll) 8) (fourth ll)))) ;#+(and sbcl (or db-sockets sb-bsd-sockets)) ;(declaim (ftype (function (vector) (values (unsigned-byte 32))) ; vector-to-ipaddr)) #+(and sbcl (or db-sockets sb-bsd-sockets)) (defun vector-to-ipaddr (vector) (+ (ash (aref vector 0) 24) (ash (aref vector 1) 16) (ash (aref vector 2) 8) (aref vector 3))) ;#+(and sbcl (or db-sockets sb-bsd-sockets)) ;(declaim (ftype (function (vector) (values (unsigned-byte 32))) ; ipaddr-to-vector)) #+(and sbcl (or db-sockets sb-bsd-sockets)) (defun ipaddr-to-vector (ipaddr) (vector (ldb (byte 8 24) ipaddr) (ldb (byte 8 16) ipaddr) (ldb (byte 8 8) ipaddr) (ldb (byte 8 0) ipaddr))) (defstruct hostent "see gethostbyname(3) for details" (name "" :type simple-string) ; canonical name of host (aliases nil :type list) ; alias list (addr-list nil :type list) ; list of addresses (addr-type 2 :type fixnum)) ; host address type (defun resolve-host-ipaddr (host) "Call gethostbyname(3) or gethostbyaddr(3)." #+allegro (let* ((ipaddr (etypecase host (string (if (every (lambda (ch) (or (char= ch #\.) (digit-char-p ch))) host) (socket:dotted-to-ipaddr host) (socket:lookup-hostname host))) (integer host))) (name (socket:ipaddr-to-hostname ipaddr))) (make-hostent :name name :addr-list (list (socket:ipaddr-to-dotted ipaddr)))) #+(and clisp syscalls) (let ((he (posix:resolve-host-ipaddr host))) (make-hostent :name (posix::hostent-name he) :aliases (posix::hostent-aliases he) :addr-list (posix::hostent-addr-list he) :addr-type (posix::hostent-addrtype he))) #+(or cmu scl) (let ((he (ext:lookup-host-entry host))) (make-hostent :name (ext:host-entry-name he) :aliases (ext:host-entry-aliases he) :addr-list (mapcar #'ipaddr-to-dotted (ext:host-entry-addr-list he)) :addr-type (ext::host-entry-addr-type he))) #+gcl (make-hostent :name (or (si:hostid-to-hostname host) host) :addr-list (list (si:hostname-to-hostid host))) #+lispworks (multiple-value-bind (name addr aliases) (comm:get-host-entry host :fields '(:name :address :aliases)) (make-hostent :name name :addr-list (list (ipaddr-to-dotted addr)) :aliases aliases)) #+(or openmcl ccl) (let* ((ipaddr (etypecase host (string (if (every (lambda (ch) (or (char= ch #\.) (digit-char-p ch))) host) (dotted-to-ipaddr host) (ccl:lookup-hostname host))) (integer host))) (name (ccl:ipaddr-to-hostname ipaddr))) (make-hostent :name name :addr-list (list (ccl:lookup-hostname ipaddr)))) #+(and sbcl sb-bsd-sockets) (let ((he (sb-bsd-sockets:get-host-by-name host))) (make-hostent :name (sb-bsd-sockets:host-ent-name he) :addr-list (loop for ipaddr in (sb-bsd-sockets:host-ent-addresses he) collect (format nil "~{~a~^.~}" (loop for octect being the elements of ipaddr collect octect))))) #+(and sbcl db-sockets) (let* ((ipaddr (etypecase host (string (if (every (lambda (ch) (or (char= ch #\.) (digit-char-p ch))) host) (dotted-to-ipaddr host) (let ((hostent (sockets:get-host-by-name host))) (when hostent (vector-to-ipaddr (sockets::host-ent-address hostent)))))) (integer host))) (name (when ipaddr (let ((hostent (sockets:get-host-by-address (ipaddr-to-vector ipaddr)))) (when (and hostent (sockets::host-ent-aliases hostent)) (first (sockets::host-ent-aliases hostent))))))) (make-hostent :name name :addr-list (list ipaddr))) #+(and sbcl net.sbcl.sockets) (let ((he (net.sbcl.sockets:lookup-host-entry host))) (make-hostent :name (net.sbcl.sockets:host-entry-name he) :aliases (net.sbcl.sockets:host-entry-aliases he) :addr-list (mapcar #'ipaddr-to-dotted (net.sbcl.sockets:host-entry-addr-list he)) :addr-type (net.sbcl.sockets::host-entry-addr-type he))) #-(or allegro (and clisp syscalls) cmu gcl lispworks openmcl ccl (and sbcl (or db-sockets net.sbcl.sockets sb-bsd-sockets)) scl) (error 'not-implemented :proc (list 'resolve-host-ipaddr host))) (defun ipaddr-closure (address) "Resolve all addresses and names associated with the argument." (let ((a2he (make-hash-table :test 'equalp)) (he2a (make-hash-table :test 'equalp))) (labels ((handle (s) (unless (gethash s a2he) (let ((he (resolve-host-ipaddr s))) (setf (gethash s a2he) he) (push s (gethash he he2a)) (handle (hostent-name he)) (mapc #'handle (hostent-aliases he)) (mapc #'handle (hostent-addr-list he)))))) (handle address)) (values he2a a2he))) ;;; ;;; }}}{{{ sockets ;;; (deftype socket () #+abcl 'to-way-stream #+allegro 'excl::socket-stream #+clisp 'stream #+(or cmu scl) 'stream ; '(or stream:socket-simple-stream sys:fd-stream) #+gcl 'stream #+lispworks 'comm:socket-stream #+(or openmcl ccl) 'ccl::socket #+(and sbcl (or db-sockets sb-bsd-sockets)) 'sb-sys:fd-stream #+(and sbcl net.sbcl.sockets) 'net.sbcl.sockets:stream-socket #-(or abcl allegro clisp cmu gcl lispworks openmcl ccl (and sbcl (or db-sockets net.sbcl.sockets sb-bsd-sockets)) scl) 'stream) (defun open-socket (host port &optional bin) "Open a socket connection to HOST at PORT." (declare (type (or integer string) host) (fixnum port) #+(or cmu scl) (ignore bin)) (let ((host (etypecase host (string host) (integer (hostent-name (resolve-host-ipaddr host)))))) #+abcl (ext:get-socket-stream (sys:make-socket host port) :element-type (if bin '(unsigned-byte 8) 'character)) #+allegro (socket:make-socket :remote-host host :remote-port port :format (if bin :binary :text)) #+clisp (#+lisp=cl ext:socket-connect #-lisp=cl lisp:socket-connect port host :element-type (if bin '(unsigned-byte 8) 'character)) #+(or cmu scl) (make-instance 'stream:socket-simple-stream :direction :io :remote-host host :remote-port port) #+gcl (si:socket port :host host) #+lispworks (comm:open-tcp-stream host port :direction :io :element-type (if bin 'unsigned-byte 'base-char)) #+(or mcl ccl) (ccl:make-socket :remote-host host :remote-port port :format (if bin :binary :text)) #+(and sbcl db-sockets) (let ((socket (make-instance 'sockets:inet-socket :type :stream :protocol :tcp))) (sockets:socket-connect socket (sockets::host-ent-address (sockets:get-host-by-name host)) port) (sockets:socket-make-stream socket :input t :output t :buffering (if bin :none :line) :element-type (if bin '(unsigned-byte 8) 'character))) #+(and sbcl net.sbcl.sockets) (net.sbcl.sockets:make-socket (if bin 'net.sbcl.sockets:binary-stream-socket 'net.sbcl.sockets:character-stream-socket) :port port :host host) #+(and sbcl sb-bsd-sockets) (let ((socket (make-instance 'sb-bsd-sockets:inet-socket :type :stream :protocol :tcp))) (sb-bsd-sockets:socket-connect socket (sb-bsd-sockets::host-ent-address (sb-bsd-sockets:get-host-by-name host)) port) (sb-bsd-sockets:socket-make-stream socket :input t :output t :buffering (if bin :none :line) :element-type (if bin '(unsigned-byte 8) 'character))) #-(or abcl allegro clisp cmu gcl lispworks mcl ccl (and sbcl (or net.sbcl.sockets db-sockets sb-bsd-sockets)) scl) (error 'not-implemented :proc (list 'open-socket host port bin)))) (defun set-socket-stream-format (socket format) "switch between binary and text output" #+clisp (setf (stream-element-type socket) format) #+(or acl cmu lispworks scl) (declare (ignore socket format)) ; bivalent streams #-(or acl clisp cmu lispworks scl) (error 'not-implemented :proc (list 'set-socket-stream-format socket format))) #+(and sbcl sb-bsd-sockets) (defun funcall-on-sock (function sock) "Apply function (getsockname/getpeername) on socket, return host/port as two values" (let ((sockaddr (sockint::allocate-sockaddr-in))) (funcall function (sb-sys:fd-stream-fd sock) sockaddr sockint::size-of-sockaddr-in) (let ((host (coerce (loop :for i :from 0 :below 4 :collect (sb-alien:deref (sockint::sockaddr-in-addr sockaddr) i)) '(vector (unsigned-byte 8) 4))) (port (+ (* 256 (sb-alien:deref (sockint::sockaddr-in-port sockaddr) 0)) (sb-alien:deref (sockint::sockaddr-in-port sockaddr) 1)))) (sockint::free-sockaddr-in sockaddr) (values host port)))) (defun socket-host/port (sock) "Return the remote and local host&port, as 4 values." (declare (type socket sock)) #+allegro (values (socket:ipaddr-to-dotted (socket:remote-host sock)) (socket:remote-port sock) (socket:ipaddr-to-dotted (socket:local-host sock)) (socket:local-port sock)) #+clisp (flet ((ip (ho) (subseq ho 0 (position #\Space ho :test #'char=)))) (multiple-value-bind (ho1 po1) (#+lisp=cl ext:socket-stream-peer #-lisp=cl lisp:socket-stream-peer sock) (multiple-value-bind (ho2 po2) (#+lisp=cl ext:socket-stream-local #-lisp=cl lisp:socket-stream-local sock) (values (ip ho1) po1 (ip ho2) po2)))) #+(or cmu scl) (let ((fd (sys:fd-stream-fd sock))) (multiple-value-bind (ho1 po1) (ext:get-peer-host-and-port fd) (multiple-value-bind (ho2 po2) (ext:get-socket-host-and-port fd) (values (ipaddr-to-dotted ho1) po1 (ipaddr-to-dotted ho2) po2)))) #+gcl (let ((peer (si:getpeername sock)) (loc (si:getsockname sock))) (values (car peer) (caddr peer) (car loc) (caddr loc))) #+lispworks (multiple-value-bind (ho1 po1) (comm:socket-stream-peer-address sock) (multiple-value-bind (ho2 po2) (comm:socket-stream-address sock) (values (ipaddr-to-dotted ho1) po1 (ipaddr-to-dotted ho2) po2))) #+(or mcl ccl) (values (ccl:ipaddr-to-dotted (ccl:remote-host sock)) (ccl:remote-port sock) (ccl:ipaddr-to-dotted (ccl:local-host sock)) (ccl:local-port sock)) #+(and sbcl db-sockets) (let ((sock (sb-sys:fd-stream-fd sock))) (multiple-value-bind (remote remote-port) (sockets:socket-peername sock) (multiple-value-bind (local local-port) (sockets:socket-name sock) (values (ipaddr-to-dotted (vector-to-ipaddr remote)) remote-port (ipaddr-to-dotted (vector-to-ipaddr local)) local-port)))) #+(and sbcl net.sbcl.sockets) (net.sbcl.sockets:socket-host-port sock) #+(and sbcl sb-bsd-sockets) (multiple-value-bind (remote remote-port) (funcall-on-sock #'sockint::getpeername sock) (multiple-value-bind (local local-port) (funcall-on-sock #'sockint::getsockname sock) (values (ipaddr-to-dotted (vector-to-ipaddr remote)) remote-port (ipaddr-to-dotted (vector-to-ipaddr local)) local-port))) #-(or allegro clisp cmu gcl lispworks mcl ccl (and sbcl (or net.sbcl.sockets db-sockets sb-bsd-sockets)) scl) (error 'not-implemented :proc (list 'socket-host/port sock))) (defun socket-string (sock) "Print the socket local&peer host&port to a string." (declare (type socket sock)) (with-output-to-string (stream) (print-unreadable-object (sock stream :type t :identity t) (multiple-value-bind (ho1 po1 ho2 po2) (socket-host/port sock) (format stream "[local: ~a:~d] [peer: ~s:~d]" ho2 po2 ho1 po1))))) ;;; ;;; }}}{{{ socket-servers ;;; #+lispworks (defstruct socket-server proc mbox port) #-lispworks (deftype socket-server () #+abcl 'ext:javaobject #+allegro 'acl-socket::socket-stream-internet-passive #+(and clisp lisp=cl) 'ext:socket-server #+(and clisp (not lisp=cl)) 'lisp:socket-server #+(or cmu scl) 'integer #+gcl 'si:socket-stream #+(or mcl ccl) 'ccl::listener-socket #+(and sbcl db-sockets) 'sb-sys:fd-stream #+(and sbcl net.sbcl.sockets) 'net.sbcl.sockets:passive-socket #+(and sbcl sb-bsd-sockets) 'sb-bsd-sockets:inet-socket #-(or abcl allegro clisp cmu gcl mcl ccl (and sbcl (or net.sbcl.sockets db-sockets)) scl) t) (defun open-socket-server (&optional port) "Open a `generic' socket server." (declare (type (or null integer #-sbcl socket) port)) #+abcl (ext:make-server-socket port) #+allegro (socket:make-socket :connect :passive :local-port (when (integerp port) port)) #+clisp (#+lisp=cl ext:socket-server #-lisp=cl lisp:socket-server port) #+(or cmu scl) (ext:create-inet-listener (or port 0) :stream :reuse-address t) #+gcl (si:make-socket-pair port) ; FIXME #+lispworks (let ((mbox (mp:make-mailbox :size 1))) (make-socket-server :mbox mbox :port port :proc (comm:start-up-server :function (lambda (sock) (mp:mailbox-send mbox sock)) :service port))) #+(or mcl ccl) (ccl:make-socket :connect :passive :type :stream :reuse-address t :local-port (or port 0)) #+(and sbcl db-sockets) (let ((socket (make-instance 'sockets:inet-socket :type :stream :protocol :tcp))) (sockets:socket-bind socket (vector 0 0 0 0) (or port 0))) #+(and sbcl net.sbcl.sockets) (net.sbcl.sockets:make-socket 'net.sbcl.sockets:passive-socket :port port) #+(and sbcl sb-bsd-sockets) (let ((sock (make-instance 'sb-bsd-sockets:inet-socket :type :stream :protocol :tcp))) (setf (sb-bsd-sockets:sockopt-reuse-address sock) t) (sb-bsd-sockets:socket-bind sock (vector 0 0 0 0) (or port 0)) (sb-bsd-sockets:socket-listen sock 15) sock) #-(or abcl allegro clisp cmu gcl lispworks mcl ccl (and sbcl (or net.sbcl.sockets db-sockets sb-bsd-sockets)) scl) (error 'not-implemented :proc (list 'open-socket-server port))) (defun socket-accept (serv &key bin wait) "Accept a connection on a socket server (passive socket). Keyword arguments are: BIN - create a binary stream; WAIT - wait for the connection this many seconds (the default is NIL - wait forever). Returns a socket stream or NIL." (declare (type socket-server serv) #+(or (and allegro (version>= 6)) openmcl ccl) (ignore bin)) #+abcl (ext:get-socket-stream (ext:socket-accept serv) :element-type (if bin '(unsigned-byte 8) 'character)) #+allegro (let* ((fmt (if bin :binary :text)) #+allegro-v5.0 (excl:*default-external-format* fmt) (sock (if wait (if (plusp wait) (mp:with-timeout (wait) (socket:accept-connection serv :wait t)) (socket:accept-connection serv :wait nil)) (socket:accept-connection serv :wait t)))) (when sock ;; From: John Foderaro ;; Date: Sun, 12 Nov 2000 16:58:28 -0800 ;; in ACL6 and later, all sockets are bivalent (both ;; text and binary) and thus there's no need to convert ;; between the element types. #+allegro-v5.0 (unless (eq (socket:socket-format sock) fmt) (warn "~s: ACL5 cannot modify socket format" 'socket-accept)) #+allegro-v4.3 (socket:set-socket-format sock fmt) sock)) #+clisp (multiple-value-bind (sec usec) (floor (or wait 0)) (when (#+lisp=cl ext:socket-wait #-lisp=cl lisp:socket-wait serv (and wait sec) (round usec 1d-6)) (#+lisp=cl ext:socket-accept #-lisp=cl lisp:socket-accept serv :element-type (if bin '(unsigned-byte 8) 'character)))) #+(or cmu scl) (when (sys:wait-until-fd-usable serv :input wait) (sys:make-fd-stream (ext:accept-tcp-connection serv) :buffering (if bin :full :line) :input t :output t :element-type (if bin '(unsigned-byte 8) 'character))) #+gcl (si:accept-socket-connection serv bin wait) ; FIXME #+lispworks (make-instance 'comm:socket-stream :direction :io :socket (mp:mailbox-read (socket-server-mbox serv)) :element-type (if bin 'unsigned-byte 'base-char)) ;; For ccl, as wait is a boolean, the time to wait is ignored. #+(or mcl ccl) (ccl:accept-connection serv :wait (not wait)) #+(and sbcl db-sockets) (let ((new-connection (sockets:socket-accept serv))) ;; who needs WAIT and BIN anyway :-S new-connection) #+(and sbcl net.sbcl.sockets) (net.sbcl.sockets:accept-connection serv (if bin 'net.sbcl.sockets:binary-stream-socket 'net.sbcl.sockets:character-stream-socket) :wait wait) #+(and sbcl sb-bsd-sockets) (progn (setf (sb-bsd-sockets:non-blocking-mode serv) wait) (let ((s (sb-bsd-sockets:socket-accept serv))) (if s (sb-bsd-sockets:socket-make-stream s :input t :output t :element-type (if bin '(unsigned-byte 8) 'character) :buffering (if bin :full :line)) (sleep wait)))) #-(or abcl allegro clisp cmu gcl lispworks mcl ccl (and sbcl (or net.sbcl.sockets db-sockets sb-bsd-sockets)) scl) (error 'not-implemented :proc (list 'socket-accept serv bin))) (defun socket-server-close (server) "Close the server." (declare (type socket-server server)) #+abcl (ext:server-socket-close server) #+allegro (close server) #+clisp (#+lisp=cl ext:socket-server-close #-lisp=cl lisp:socket-server-close server) #+(or cmu scl) (unix:unix-close server) #+gcl (close server) #+lispworks (mp:process-kill (socket-server-proc server)) #+(or openmcl ccl) (close server) #+(and sbcl db-sockets) (sockets:socket-close server) #+(and sbcl net.sbcl.sockets) (close server) #+(and sbcl sb-bsd-sockets) (sb-bsd-sockets:socket-close server) #-(or abcl allegro clisp cmu gcl lispworks openmcl ccl (and sbcl (or net.sbcl.sockets db-sockets sb-bsd-sockets)) scl) (error 'not-implemented :proc (list 'socket-server-close server))) (defun socket-server-host/port (server) "Return the local host&port on which the server is running, as 2 values." (declare (type socket-server server)) #+allegro (values (socket:ipaddr-to-dotted (socket:local-host server)) (socket:local-port server)) #+(and clisp lisp=cl) (values (ext:socket-server-host server) (ext:socket-server-port server)) #+(and clisp (not lisp=cl)) (values (lisp:socket-server-host server) (lisp:socket-server-port server)) #+(or cmu scl) (values (ipaddr-to-dotted (car (ext:host-entry-addr-list (ext:lookup-host-entry "localhost")))) (nth-value 1 (ext:get-socket-host-and-port server))) #+gcl (let ((sock (si:getsockname server))) (values (car sock) (caddr sock))) #+lispworks (values (ipaddr-to-dotted (comm:get-host-entry "localhost" :fields '(:address))) (socket-server-port server)) #+(or openmcl ccl) (values (ccl:ipaddr-to-dotted (ccl:local-host server)) (ccl:local-port server)) #+(and sbcl db-sockets) (multiple-value-bind (addr port) (sockets:socket-name server) (values (vector-to-ipaddr addr) port)) #+(and sbcl net.sbcl.sockets) (net.sbcl.sockets:passive-socket-host-port server) #+(and sbcl sb-bsd-sockets) (multiple-value-bind (addr port) (sb-bsd-sockets:socket-name server) (values (ipaddr-to-dotted (vector-to-ipaddr addr)) port)) #-(or allegro clisp cmu gcl lispworks openmcl ccl (and sbcl (or net.sbcl.sockets db-sockets sb-bsd-sockets)) scl) (error 'not-implemented :proc (list 'socket-server-host/port server))) ;;; ;;; }}}{{{ for CLX ;;; (defun wait-for-stream (stream &optional timeout) "Sleep until there is input on the STREAM, or for TIMEOUT seconds, whichever comes first. If there was a timeout, return NIL." #+clisp (multiple-value-bind (sec usec) (floor (or timeout 0)) (#+lisp=cl ext:socket-status #-lisp=cl lisp:socket-status stream (and timeout sec) (round usec 1d-6))) #+(or cmu scl) (#+mp mp:process-wait-until-fd-usable #-mp sys:wait-until-fd-usable (system:fd-stream-fd stream) :input timeout) #+(or openmcl ccl) (ccl:make-socket :type :stream :address-family :file :connect :active :format :text ;;(if bin :binary :text) :remote-filename #P"");;path) #+(and sbcl net.sbcl.sockets) (net.sbcl.sockets:wait-for-input-data stream timeout) #+(and sbcl db-sockets) (sb-sys:wait-until-fd-usable (sb-sys:fd-stream-fd stream) :input timeout) #-(or clisp cmu (and sbcl (or net.sbcl.sockets db-sockets)) scl) (error 'not-implemented :proc (list 'wait-for-stream stream timeout))) (defun open-unix-socket (path &key (kind :stream) bin) "Opens a unix socket. Path is the location. Kind can be :stream or :datagram." (declare (simple-string path) #-(or cmu sbcl) (ignore kind)) #+allegro (socket:make-socket :type :stream :address-family :file :connect :active :remote-filename path) #+cmu (sys:make-fd-stream (ext:connect-to-unix-socket path kind) :input t :output t :element-type (if bin '(unsigned-byte 8) 'character)) #+(and sbcl net.sbcl.sockets) (net.sbcl.sockets:make-socket 'net.sbcl.sockets:unix-stream-socket :buffering :full :path path :type kind) #+(and sbcl db-sockets) (let ((socket (make-instance 'sockets:unix-socket :type :stream))) (sockets:socket-connect socket path) (sockets:socket-make-stream socket :input t :output t :buffering :none :element-type '(unsigned-byte 8))) #-(or allegro cmu (and sbcl (or net.sbcl.sockets db-sockets))) (open path :element-type (if bin '(unsigned-byte 8) 'character) :direction :io)) ;;; ;;; }}}{{{ conditions ;;; (defun report-network-condition (cc out) (declare (stream out)) (format out "[~s] ~s:~d~@[ ~?~]" (net-proc cc) (net-host cc) (net-port cc) (net-mesg cc) (net-args cc))) (define-condition network (error) ((proc :type symbol :reader net-proc :initarg :proc :initform nil) (host :type simple-string :reader net-host :initarg :host :initform "") (port :type (unsigned-byte 16) :reader net-port :initarg :port :initform 0) (mesg :type (or null simple-string) :reader net-mesg :initarg :mesg :initform nil) (args :type list :reader net-args :initarg :args :initform nil)) (:report report-network-condition)) (define-condition timeout (network) ((time :type (real 0) :reader timeout-time :initarg :time :initform 0)) (:report (lambda (cc out) (declare (stream out)) (report-network-condition cc out) (when (plusp (timeout-time cc)) (format out " [timeout ~a sec]" (timeout-time cc)))))) (define-condition login (network) ()) (define-condition net-path (network) ()) ;;; ;;; }}}{{{ `socket-service-port' ;;; (defstruct servent "see getservbyname(3) for details" (name "" :type simple-string) ; official name of service (aliases nil :type list) ; alias list (port -1 :type fixnum) ; port service resides at (proto :tcp :type symbol)) ; protocol to use (defun socket-service-port (&optional service (protocol "tcp")) "Return the SERVENT structure corresponding to the SERVICE. When SERVICE is NIL, return the list of all services." (with-open-file (fl #+unix "/etc/services" #+(or win32 mswindows) (concatenate 'string (getenv "windir") "/system32/drivers/etc/services") :direction :input) (loop :with name :and aliases :and port :and prot :and tokens :for st = (read-line fl nil nil) :until (null st) :unless (or (zerop (length st)) (char= #\# (schar st 0))) :do (setq tokens (string-tokens (nsubstitute #\Space #\/ (subseq st 0 (position #\# st)))) name (string-downcase (string (first tokens))) aliases (mapcar (compose string-downcase string) (cdddr tokens)) port (second tokens) prot (third tokens)) :and :if service :when (and (string-equal protocol prot) (or (string-equal service name) (member service aliases :test #'string-equal))) :return (make-servent :name name :aliases aliases :port port :proto prot) :end :else :collect (make-servent :name name :aliases aliases :port port :proto prot) :end :end :finally (when service (error "~s: service ~s is not found for protocol ~s" 'socket-service-port service protocol))))) ;;; }}} (provide :port-net) ;;; file net.lisp ends here clfswm-20111015.git51b0a02/contrib/server/server.lisp000066400000000000000000000234771164636077000221120ustar00rootroot00000000000000;;; -------------------------------------------------------------------------- ;;; CLFSWM - FullScreen Window Manager ;;; ;;; -------------------------------------------------------------------------- ;;; Documentation: Client/server connection. ;;; The connection is crypted and you can only connect to the server with the ;;; same clfswm binary. ;;; -------------------------------------------------------------------------- ;;; ;;; (C) 2011 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;; ;;; -------------------------------------------------------------------------- ;;; Server protocole: ;;; Server -> Client: orig_key=a generated key crypted with *key* ;;; Client : build its new_key with orig_key+*key* ;;; Client -> Server: new_key+(md5 new_key) crypted with new_key ;;; Server -> Client: check if the keys match and then authenticate the client. ;;; Server <-> Client: All connections are crypted with new_key ;;; -------------------------------------------------------------------------- (in-package :clfswm) (defparameter *server-port* 33333) (format t "Loading the clfswm server code... ") (pushnew (truename (merge-pathnames "server/" *contrib-dir*)) asdf:*central-registry*) (dbg asdf:*central-registry*) (asdf:oos 'asdf:load-op :clfswm-client) (in-package :clfswm) (use-package :crypt) (defstruct server-socket stream auth form key) (defparameter *server-socket* nil) (defparameter *server-allowed-host* '("127.0.0.1")) (defparameter *server-wait-timeout* 0.001d0) (defparameter *server-connection* nil) (defparameter *server-commands* '("bye" "close" "quit" "info" "clear" "ls[d][v|f] [pattern]")) (defun server-show-prompt (sock) ;;(send-to-client sock nil (format nil "~A> " (package-name *package*)))) (format (server-socket-stream sock) "~A~%" (crypt (format nil"~A> " (package-name *package*)) (server-socket-key sock))) (force-output (server-socket-stream sock))) (defun send-to-client (sock show-prompt-p &rest msg) (dolist (m (if (consp (car msg)) (car msg) msg)) (format (server-socket-stream sock) "~A~%" (crypt m (server-socket-key sock))) (force-output (server-socket-stream sock))) (when show-prompt-p (server-show-prompt sock))) ;;(defun server-show-prompt (sock) ;; (send-to-client sock nil (format nil "~A> " (package-name *package*)))) (defun read-from-client (sock) (decrypt (read-line (server-socket-stream sock) nil nil) (server-socket-key sock))) (defun server-remove-connection (sock) (send-to-client sock nil "Connection closed by server") (multiple-value-bind (local-host local-port remote-host remote-port) (port:socket-host/port (server-socket-stream sock)) (declare (ignore local-host local-port)) (format t "~&Connection from ~A:~A closed.~%" remote-host remote-port)) (close (server-socket-stream sock)) (setf *server-connection* (remove sock *server-connection*))) (defun server-show-info (sock) (send-to-client sock t (format nil "~A" *server-connection*))) (defun server-clear-connection () (dolist (sock *server-connection*) (handler-case (send-to-client sock t "Server clear connection in progress.") (error () (server-remove-connection sock))))) (defun server-show-help (sock) (send-to-client sock t (format nil "Availables commandes: ~{~S~^, ~}" *server-commands*))) (defun server-ls (sock line ls-word var-p fun-p &optional show-doc) (let* ((pattern (string-trim '(#\space #\tab) (subseq (string-trim '(#\space #\tab) line) (length ls-word)))) (all-search (string= pattern ""))) (with-all-internal-symbols (symbol :clfswm) (when (or all-search (symbol-search pattern symbol)) (cond ((and var-p (boundp symbol)) (send-to-client sock nil (format nil "~A (variable) ~A" symbol (if show-doc (format nil "~& ~A~& => ~A" (documentation symbol 'variable) (symbol-value symbol)) "")))) ((and fun-p (fboundp symbol)) (send-to-client sock nil (format nil "~A (function) ~A" symbol (if show-doc (documentation symbol 'function) ""))))))) (send-to-client sock t "Done."))) (defun server-is-allowed-host (stream) (multiple-value-bind (local-host local-port remote-host remote-port) (port:socket-host/port stream) (declare (ignore local-host local-port)) (and (member remote-host *server-allowed-host* :test #'string-equal) (equal remote-port *server-port*)))) (defun server-handle-new-connection () (handler-case (let ((stream (and *server-socket* (port:socket-accept *server-socket* :wait *server-wait-timeout*)))) (when stream (if (server-is-allowed-host stream) (multiple-value-bind (local-host local-port remote-host remote-port) (port:socket-host/port stream) (declare (ignore local-host local-port)) (format t "~&New connection from ~A:~A " remote-host remote-port) (let ((new-sock (make-server-socket :stream stream :auth nil :form "" :key *key*)) (key (generate-key))) (push new-sock *server-connection*) (send-to-client new-sock nil key) (setf (server-socket-key new-sock) (concatenate 'string key *key*)))) (close stream)))) (error (c) (format t "Connection rejected: ~A~%" c) (force-output)))) (defun server-line-is (line &rest strings) (dolist (str strings) (when (string-equal line str) (return-from server-line-is t))) nil) (defun server-complet-from (sock) (ignore-errors (when (listen (server-socket-stream sock)) (let ((line (read-from-client sock))) (cond ((server-line-is line "help") (server-show-help sock)) ((server-line-is line "bye" "close" "quit") (server-remove-connection sock)) ((server-line-is line "info") (server-show-info sock)) ((server-line-is line "clear") (server-clear-connection)) ((first-position "lsdv" line) (server-ls sock line "lsdv" t nil t)) ((first-position "lsdf" line) (server-ls sock line "lsdf" nil t t)) ((first-position "lsd" line) (server-ls sock line "lsd" t t t)) ((first-position "lsv" line) (server-ls sock line "lsv" t nil nil)) ((first-position "lsf" line) (server-ls sock line "lsf" nil t nil)) ((first-position "ls" line) (server-ls sock line "ls" t t nil)) (t (setf (server-socket-form sock) (format nil "~A~A~%" (server-socket-form sock) line)))))))) (defun server-eval-form (sock) (let* ((result nil) (printed-result (with-output-to-string (*standard-output*) (setf result (handler-case (loop for i in (multiple-value-list (eval (read-from-string (server-socket-form sock)))) collect (format nil "~S" i)) (error (condition) (format nil "~A" condition))))))) (send-to-client sock nil (ensure-list printed-result)) (send-to-client sock t (ensure-list result)) (setf (server-socket-form sock) ""))) (defun server-handle-form (sock) (server-complet-from sock) (if (server-socket-key sock) (when (ignore-errors (read-from-string (server-socket-form sock))) (server-eval-form sock)) (server-show-prompt sock))) (defun server-handle-auth (sock) (loop for line = (read-from-client sock) while line do (if (string= line (format nil "~A~A" (server-socket-key sock) (md5:md5 (server-socket-key sock)))) (progn (setf (server-socket-auth sock) t) (setf (server-socket-form sock) (format nil "~S" "You are now authenticated!")) (server-handle-form sock) (format t "Connection accepted~%") (return-from server-handle-auth nil)) (progn (format t "Connection closed~%") (close (server-socket-stream sock)))))) (defun server-handle-connection (sock) (handler-case (when (listen (server-socket-stream sock)) (if (server-socket-auth sock) (server-handle-form sock) (server-handle-auth sock))) (error (c) (format t "*** Error: ~A~%" c) (force-output) (close (server-socket-stream sock)) (setf *server-connection* (remove sock *server-connection*))))) (defun handle-server () (server-handle-new-connection) (dolist (sock *server-connection*) (server-handle-connection sock))) (defun start-server (&optional port) (when port (setf *server-port* port)) (setf *server-socket* (port:open-socket-server *server-port*)) (add-hook *loop-hook* 'handle-server) (format t "*** Server is started on port ~A and is accepting connection only from [~{~A~^, ~}].~2%" *server-port* *server-allowed-host*) (save-new-key)) (format t "done. You can now start a clfswm server with the command (start-server &optional port). Only [~{~A~^, ~}] ~A allowed to login on the server. The connection is crypted. You can start the client with the '--client' command line option.~%" *server-allowed-host* (if (or (null *server-allowed-host*) (= (length *server-allowed-host*) 1)) "is" "are")) (defun server-parse-cmdline () (let ((args (get-command-line-words))) (when (member "--client" args :test #'string-equal) (clfswm-client:start-client (remove "--client" args :test #'string-equal)) (uquit)))) (defun is-started-as-client-p () (member "--client" (get-command-line-words) :test #'string-equal)) (add-hook *main-entrance-hook* 'server-parse-cmdline) clfswm-20111015.git51b0a02/contrib/server/test.lisp000077500000000000000000000006431164636077000215540ustar00rootroot00000000000000(in-package :clfswm) (leave-frame) (select-previous-level) (let ((frame (create-frame \:name \"Test root\" \:x 0.05 \:y 0.05))) (add-frame frame *current-child*) (add-frame (create-frame \:name \"Test 1\" \:x 0.3 \:y 0 \:w 0.7 \:h 1) frame) (add-frame (create-frame \:name \"Test 2\" \:x 0 \:y 0 \:w 0.3 \:h 1) frame) (setf *current-child* (first (frame-child frame)))) (show-all-children *current-root*) clfswm-20111015.git51b0a02/contrib/volume-mode.lisp000066400000000000000000000245531164636077000215230ustar00rootroot00000000000000;;; -------------------------------------------------------------------------- ;;; CLFSWM - FullScreen Window Manager ;;; ;;; -------------------------------------------------------------------------- ;;; Documentation: Volume mode ;;; -------------------------------------------------------------------------- ;;; ;;; (C) 2011 Desmond O. Chang ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;; ;;; Documentation: A volume mode. ;;; If you want to use this file, just add this line in ;;; your configuration file: ;;; ;;; (load-contrib "volume-mode.lisp") ;;; And with the alsa mixer: ;;; (load-contrib "amixer.lisp") ;;; ;;; This mode is inspired by the emms volume package. When you change the ;;; volume in main mode or second mode, clfswm will enter volume mode and ;;; set a timer to leave this mode. Changing volume in volume mode will ;;; reset the timer. You can also leave volume mode manually by return, ;;; escape or control-g. ;;; ;;; Special variable *VOLUME-MODE-TIMEOUT* controls the timeout in ;;; seconds. If it's positive, volume mode will exit when timeout occurs; ;;; if it's 0, volume mode will exit right now; if it's negative, volume ;;; will not exit even if timeout occurs. Default timeout is 3 seconds. ;;; ;;; Volume mode uses three special variables to control the mixer: ;;; *VOLUME-MUTE-FUNCTION*, *VOLUME-LOWER-FUNCTION* and ;;; *VOLUME-RAISE-FUNCTION*. Their values are functions which must accept ;;; no arguments and return two values indicating the mixer state. The ;;; first value is the volume ratio whose type must be (real 0 1). If the ;;; mixer is mute, the second value should be true, otherwise it should be ;;; false. If volume controller cannot get the mixer state, it must ;;; return NIL. ;;; ;;; Volume mode shows a mute sign, a percentage and a ratio bar on the ;;; screen. A plus sign '+' means it's unmute and a minus sign '-' means ;;; it's mute now. If volume mode doesn't know the mixer state, a message ;;; "unknown" will be shown. ;;; ;;; contrib/amixer.lisp shows how to use volume mode with alsa. ;;; ;;; -------------------------------------------------------------------------- (in-package :clfswm) (format t "Loading Volume mode code... ") (defparameter *volume-keys* nil) (defconfig *volume-mode-placement* 'bottom-middle-placement 'Placement "Volume mode window placement") (defvar *volume-window* nil) (defvar *volume-font* nil) (defvar *volume-gc* nil) (defvar *in-volume-mode* nil) (defvar *leave-volume-mode* nil) (defvar *volume-ratio* nil) (defvar *volume-mute* nil) (defvar *volume-mode-timeout* 3 "Volume mode timeout in seconds: > 0 means volume mode will exit when timeout occurs; = 0 means exit right now; < 0 means exit manually.") ;;; CONFIG - Volume mode (defconfig *volume-font-string* *default-font-string* 'Volume-mode "Volume string window font string") (defconfig *volume-background* "black" 'Volume-mode "Volume string window background color") (defconfig *volume-foreground* "green" 'Volume-mode "Volume string window foreground color") (defconfig *volume-border* "red" 'Volume-mode "Volume string window border color") (defconfig *volume-width* 400 'Volume-mode "Volume mode window width") (defconfig *volume-height* 15 'Volume-mode "Volume mode window height") (defconfig *volume-text-limit* 30 'Volume-mode "Maximum text limit in the volume window") (defconfig *volume-external-mixer-cmd* "/usr/bin/gnome-alsamixer" 'Volume-mode "Command to start an external mixer program") (define-init-hash-table-key *volume-keys* "Volume mode keys") (define-define-key "volume" *volume-keys*) (add-hook *binding-hook* 'init-*volume-keys*) (defun set-default-volume-keys () (define-volume-key ("XF86AudioMute") 'volume-mute) (define-volume-key ("XF86AudioLowerVolume") 'volume-lower) (define-volume-key ("XF86AudioRaiseVolume") 'volume-raise) (define-volume-key (#\/) 'volume-mute) (define-volume-key (#\,) 'volume-lower) (define-volume-key (#\.) 'volume-raise) (define-volume-key ("m") 'volume-mute) (define-volume-key ("l") 'volume-lower) (define-volume-key ("r") 'volume-raise) (define-volume-key ("Down") 'volume-lower) (define-volume-key ("Up") 'volume-raise) (define-volume-key ("Left") 'volume-lower) (define-volume-key ("Right") 'volume-raise) (define-volume-key ("PageUp") 'volume-lower) (define-volume-key ("PageDown") 'volume-raise) (define-volume-key ("Return") 'leave-volume-mode) (define-volume-key ("Escape") 'leave-volume-mode) (define-volume-key ("g" :control) 'leave-volume-mode) (define-volume-key ("e") 'run-external-volume-mixer) ;;; Main mode (define-main-key ("XF86AudioMute") 'volume-mute) (define-main-key ("XF86AudioLowerVolume") 'volume-lower) (define-main-key ("XF86AudioRaiseVolume") 'volume-raise) ;;; Second mode (define-second-key ("XF86AudioMute") 'volume-mute) (define-second-key ("XF86AudioLowerVolume") 'volume-lower) (define-second-key ("XF86AudioRaiseVolume") 'volume-raise)) (add-hook *binding-hook* 'set-default-volume-keys) (defun volume-mode-window-message (width) (if *volume-ratio* (let* ((mute (if *volume-mute* #\- #\+)) (percentage (round (* 100 *volume-ratio*))) (n (round (* width *volume-ratio*)))) (format nil "[~A] ~3@A% ~A~A" mute percentage (repeat-chars n #\#) (repeat-chars (- width n) #\.))) "unknown")) (defun draw-volume-mode-window () (raise-window *volume-window*) (clear-pixmap-buffer *volume-window* *volume-gc*) (let* ((text (limit-length (volume-mode-window-message 20) *volume-text-limit*)) (len (length text))) (xlib:draw-glyphs *pixmap-buffer* *volume-gc* (truncate (/ (- *volume-width* (* (xlib:max-char-width *volume-font*) len)) 2)) (truncate (/ (+ *volume-height* (- (xlib:font-ascent *volume-font*) (xlib:font-descent *volume-font*))) 2)) text)) (copy-pixmap-buffer *volume-window* *volume-gc*)) (defun leave-volume-mode () "Leave the volume mode" (throw 'exit-volume-loop nil)) (defun update-volume-mode () (draw-volume-mode-window) (cond ((plusp *volume-mode-timeout*) (erase-timer :volume-mode-timer) (with-timer (*volume-mode-timeout* :volume-mode-timer) (setf *leave-volume-mode* t))) ((zerop *volume-mode-timeout*) (erase-timer :volume-mode-timer) (setf *leave-volume-mode* t)) ((minusp *volume-mode-timeout*) (erase-timer :volume-mode-timer)))) (defun volume-enter-function () (with-placement (*volume-mode-placement* x y *volume-width* *volume-height*) (setf *volume-font* (xlib:open-font *display* *volume-font-string*) *volume-window* (xlib:create-window :parent *root* :x x :y y :width *volume-width* :height *volume-height* :background (get-color *volume-background*) :border-width 1 :border (get-color *volume-border*) :colormap (xlib:screen-default-colormap *screen*) :event-mask '(:exposure :key-press)) *volume-gc* (xlib:create-gcontext :drawable *volume-window* :foreground (get-color *volume-foreground*) :background (get-color *volume-background*) :font *volume-font* :line-style :solid)) (map-window *volume-window*)) (setf *in-volume-mode* t *leave-volume-mode* nil) (update-volume-mode)) (defun volume-loop-function () (when *leave-volume-mode* (leave-volume-mode))) (defun volume-leave-function () (when *volume-gc* (xlib:free-gcontext *volume-gc*)) (when *volume-window* (xlib:destroy-window *volume-window*)) (when *volume-font* (xlib:close-font *volume-font*)) (xlib:display-finish-output *display*) (erase-timer :volume-mode-timer) (setf *volume-window* nil *volume-gc* nil *volume-font* nil *in-volume-mode* nil *leave-volume-mode* nil)) (define-handler volume-mode :key-press (code state) (funcall-key-from-code *volume-keys* code state)) (defun volume-mode () (let ((grab-keyboard-p (xgrab-keyboard-p)) (grab-pointer-p (xgrab-pointer-p))) (xgrab-pointer *root* 92 93) (unless grab-keyboard-p (ungrab-main-keys) (xgrab-keyboard *root*)) (generic-mode 'volume-mode 'exit-volume-loop :enter-function 'volume-enter-function :loop-function 'volume-loop-function :leave-function 'volume-leave-function :original-mode '(main-mode)) (unless grab-keyboard-p (xungrab-keyboard) (grab-main-keys)) (if grab-pointer-p (xgrab-pointer *root* 66 67) (xungrab-pointer)))) (defun volume-set (fn) (when fn (setf (values *volume-ratio* *volume-mute*) (funcall fn)) (if *in-volume-mode* (update-volume-mode) (volume-mode)))) (defvar *volume-mute-function* nil) (defvar *volume-lower-function* nil) (defvar *volume-raise-function* nil) (defun volume-mute () "Toggle mute." (volume-set *volume-mute-function*)) (defun volume-lower () "Lower volume." (volume-set *volume-lower-function*)) (defun volume-raise () "Raise volume." (volume-set *volume-raise-function*)) (defun run-external-volume-mixer () "Start an external volume mixer" (do-shell *volume-external-mixer-cmd*)) (format t "done~%") clfswm-20111015.git51b0a02/contrib/xmms.lisp000066400000000000000000000050631164636077000202510ustar00rootroot00000000000000;;; -------------------------------------------------------------------------- ;;; CLFSWM - FullScreen Window Manager ;;; ;;; -------------------------------------------------------------------------- ;;; Documentation: Music Player Daemon (MPD) interface ;;; -------------------------------------------------------------------------- ;;; ;;; (C) 2011 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;; ;;; Documentation: Handle the XMMS player ;;; This code needs xmmsctrl. ;; If you want to use this file, just add this line in ;;; your configuration file: ;;; ;;; (load-contrib "xmms.lisp") ;;; ;;; -------------------------------------------------------------------------- (in-package :clfswm) (format t "Loading XMMS code... ") (defun xmms-menu () "Open the XMMS menu" (open-menu (find-menu 'xmms-menu))) (defun launch-xmms () "Lanch XMMS" (do-shell "xmmsctrl launch")) (defun show-xmms-status () "Show the current xmms status" (info-on-shell "XMMS status:" "xmmsctrl cur")) (defun show-xmms-playlist () "Show the current xmms playlist" (info-on-shell "XMMS Playlist:" "xmmsctrl playlist")) (defun xmms-next-track () "Play the next XMMS track" (do-shell "xmmsctrl next") (show-xmms-status) (xmms-menu)) (defun xmms-previous-track () "Play the previous XMMS track" (do-shell "xmmsctrl previous") (show-xmms-status) (xmms-menu)) (defun xmms-load-file () "open xmms \"Load file(s)\" dialog window." (do-shell "xmmsctrl eject")) (unless (find-menu 'xmms-menu) (add-sub-menu 'help-menu "x" 'xmms-menu "XMMS menu") (add-menu-key 'xmms-menu "r" 'launch-xmms) (add-menu-key 'xmms-menu "s" 'show-xmms-status) (add-menu-key 'xmms-menu "l" 'show-xmms-playlist) (add-menu-key 'xmms-menu "n" 'xmms-next-track) (add-menu-key 'xmms-menu "p" 'xmms-previous-track) (add-menu-key 'xmms-menu "e" 'xmms-load-file)) (format t "done~%") clfswm-20111015.git51b0a02/doc/000077500000000000000000000000001164636077000154755ustar00rootroot00000000000000clfswm-20111015.git51b0a02/doc/README000066400000000000000000000000051164636077000163500ustar00rootroot00000000000000TODO clfswm-20111015.git51b0a02/doc/corner.html000066400000000000000000000147151164636077000176630ustar00rootroot00000000000000 CLFSWM Corners

CLFSWM Corners

Here are the actions associated to screen corners in CLFSWM:

*corner-main-mode-left-button*

Top-Left: Open the main menu
Top-Right: Present a virtual keyboard
Bottom-Right: Present all windows in the current frame (An expose like)
Bottom-Left: ---

*corner-main-mode-middle-button*

Top-Left: Open the help and info window
Top-Right: Close or kill the current window (ask before doing anything)
Bottom-Right: ---
Bottom-Left: ---

*corner-main-mode-right-button*

Top-Left: Hide/Unhide a terminal
Top-Right: Close or kill the current window (ask before doing anything)
Bottom-Right: Present all windows in all frames (An expose like)
Bottom-Left: ---

*corner-second-mode-left-button*

Top-Left: ---
Top-Right: ---
Bottom-Right: Present all windows in the current frame (An expose like)
Bottom-Left: ---

*corner-second-mode-middle-button*

Top-Left: Open the help and info window
Top-Right: ---
Bottom-Right: ---
Bottom-Left: ---

*corner-second-mode-right-button*

Top-Left: ---
Top-Right: ---
Bottom-Right: Present all windows in all frames (An expose like)
Bottom-Left: ---

This documentation was produced with the CLFSWM auto-doc functions. To reproduce it, use the produce-corner-doc-html-in-file or the produce-all-docs function from the Lisp REPL.

Something like this:
LISP> (in-package :clfswm)
CLFSWM> (produce-corner-doc-html-in-file "my-corner.html")
or
CLFSWM> (produce-all-docs)

clfswm-20111015.git51b0a02/doc/corner.txt000066400000000000000000000026341164636077000175330ustar00rootroot00000000000000Here are the actions associated to screen corners in CLFSWM: *Corner-Main-Mode-Left-Button*: Top-Left: Open the main menu Top-Right: Present a virtual keyboard Bottom-Right: Present all windows in the current frame (An expose like) Bottom-Left: --- *Corner-Main-Mode-Middle-Button*: Top-Left: Open the help and info window Top-Right: Close or kill the current window (ask before doing anything) Bottom-Right: --- Bottom-Left: --- *Corner-Main-Mode-Right-Button*: Top-Left: Hide/Unhide a terminal Top-Right: Close or kill the current window (ask before doing anything) Bottom-Right: Present all windows in all frames (An expose like) Bottom-Left: --- *Corner-Second-Mode-Left-Button*: Top-Left: --- Top-Right: --- Bottom-Right: Present all windows in the current frame (An expose like) Bottom-Left: --- *Corner-Second-Mode-Middle-Button*: Top-Left: Open the help and info window Top-Right: --- Bottom-Right: --- Bottom-Left: --- *Corner-Second-Mode-Right-Button*: Top-Left: --- Top-Right: --- Bottom-Right: Present all windows in all frames (An expose like) Bottom-Left: --- This documentation was produced with the CLFSWM auto-doc functions. To reproduce it, use the produce-corner-doc-in-file or the produce-all-docs function from the Lisp REPL. Something like this: LISP> (in-package :clfswm) CLFSWM> (produce-corner-doc-in-file "my-corner.txt") or CLFSWM> (produce-all-docs) clfswm-20111015.git51b0a02/doc/dot-clfswmrc000066400000000000000000000157261164636077000200370ustar00rootroot00000000000000;;; -*- lisp -*- ;;; ;;; CLFSWM configuration file example ;;; ;;; Send me your configuration file at pbrochard _at_ common-lisp -dot- net ;;; if you want to share it with others. (in-package :clfswm) ;;;; Uncomment the line above if you need default modifiers (or not) ;;(with-capslock) ;;(with-numlock) ;;(without-capslock) ;;(without-numlock) ;;;; Uncomment the line above if you want to enable the notify event compression. ;;;; This variable may be useful to speed up some slow version of CLX ;;;; It is particulary useful with CLISP/MIT-CLX. ;; (setf *have-to-compress-notify* t) ;;; Color configuration example ;;; ;;; See in package.lisp or config.lisp for all variables ;;(setf *color-unselected* "Blue") ;;; How to change the default fullscreen size ;;(defun get-fullscreen-size () ;; "Return the size of root child (values rx ry rw rh) ;;You can tweak this to what you want" ;; (values -2 -2 (+ (xlib:screen-width *screen*) 2) (- (xlib:screen-height *screen*) 20))) ;;; Contributed code example ;;; See in the clfswm/contrib directory to find some contributed code ;;; and se load-contrib to load them. For example: ;;(load-contrib "contrib-example.lisp") ;;(load-contrib "mpd.lisp") ;;(load-contrib "keyb_fr.lisp") ;;(load-contrib "xmms.lisp") ;;(load-contrib "cd-player.lisp") ;;(load-contrib "reboot-halt.lisp") ;;;; Client/server connection - the connection is crypted and you can only ;;;; connect to the server with the same clfswm binary. ;;(load-contrib "server/server.lisp") ;;(unless (is-started-as-client-p) ;; (start-server)) ;;; Binding example: Undefine Control-F1 and define Control-F5 as a ;;; new binding in main mode ;;; ;;; See bindings.lisp, bindings-second-mode.lisp for all default bindings definitions. ;; ;;(defun $start-emacs () ;; "Run or raise emacs" ;; (setf *second-mode-leave-function* ;; (lambda () ;; (run-or-raise (lambda (win) (string-equal "emacs" ;; (xlib:get-wm-class win))) ;; (lambda () (do-shell "cd $HOME && exec emacsclient -c"))))) ;; (leave-second-mode)) ;; ;;(defun $start-conkeror () ;; "Run or raise conkeror" ;; (setf *second-mode-leave-function* ;; (lambda () ;; (run-or-raise (lambda (win) (string-equal "Navigator" ;; (xlib:get-wm-class win))) ;; (lambda () (do-shell "cd $HOME && exec conkeror"))))) ;; (leave-second-mode)) ;; ;;(defun binding-example () ;; (undefine-main-key ("F1" :mod-1)) ;; (define-main-key ("F5" :mod-1) 'help-on-clfswm) ;; (define-second-key ("e") '$start-emacs) ;; (define-second-key ("c") '$start-conkeror) ;; ;; Binding example for apwal ;; (define-second-key (#\Space) ;; (defun tpm-apwal () ;; "Run Apwal" ;; (do-shell "exec apwal") ;; (show-all-windows-in-workspace (current-workspace)) ;; (throw 'exit-second-loop nil)))) ;; ;;(add-hook *binding-hook* 'binding-example) ;;; Set up an UZBL frame where all uzbl windows will be absorbed. ;;; ;;(defun set-uzbl-frame-nw-hook (&optional (frame *current-child*)) ;; "Open the window in the UZBL frame if it match uzbl absorb-nw-test" ;; (when (frame-p frame) ;; (setf (frame-nw-hook frame) 'absorb-window-nw-hook ;; (frame-data-slot frame :nw-absorb-test) (nw-absorb-test-class "uzbl-core")))) ;; ;;#-:uzbl-menu-added ;;(add-menu-key 'frame-nw-hook-menu "z" 'set-uzbl-frame-nw-hook) ;; ;;(pushnew :uzbl-menu-added *features*) ;; ;; ;;(defun init-uzbl-frame () ;; (let ((frame (first (frame-child *root-frame*)))) ;; (setf (frame-data-slot frame :tile-size) 0.7) ;; (setf *current-root* frame ;; *current-child* frame) ;; (bind-on-slot 0) ;; (let ((uzbl-frame (create-frame :name "Uzbl" :x 0.01 :y 0.01 :w 0.98 :h 0.98))) ;; (add-frame uzbl-frame frame) ;; (set-uzbl-frame-nw-hook uzbl-frame)))) ;; ;;(unless (member 'init-uzbl-frame *init-hook*) ;; (add-hook *init-hook* 'init-uzbl-frame)) ;;; End UZBL setup. ;;; A more complex example I use to record my desktop and show ;;; documentation associated to each key press. ;;;See contrib/osd.lisp ;;(load-contrib "osd.lisp") ;;;;; -- Doc example end -- ;;;;; Init hook examples: ;;(defun my-init-hook-1 () ;; (dbg 'my-init-hook) ;; ;;(add-frame (create-frame :name "Default" :layout #'tile-left-layout :data (list '(:tile-size 0.6))) *root-frame*) ;; (add-frame (create-frame :name "The Gimp" :x 0.6 :y 0 :w 0.3 :h 0.2) *root-frame*) ;; (add-frame (create-frame :name "Net" :x 0.52 :y 0.3 :w 0.4 :h 0.3) *root-frame*) ;; (add-frame (create-frame :x 0.4 :y 0 :w 0.2 :h 0.3) (first (frame-child *root-frame*))) ;; (add-frame (create-frame :x 0.6 :y 0.4 :w 0.4 :h 0.2) (first (frame-child *root-frame*))) ;; (add-frame (create-frame :x 0.4 :y 0.7 :w 0.2 :h 0.3) (first (frame-child *root-frame*))) ;; (let ((frame (create-frame :name "The Qiv" :x 0 :y 0.4 :w 0.4 :h 0.2))) ;; (add-frame frame (first (frame-child *root-frame*))) ;; (add-frame (create-frame) frame)) ;; (add-frame (create-frame :x 0.1 :y 0.55 :w 0.8 :h 0.43) *root-frame*) ;; (add-frame (create-frame :x 0.2 :y 0.1 :w 0.6 :h 0.4) (first (frame-child *root-frame*))) ;; (add-frame (create-frame :x 0.3 :y 0.55 :w 0.4 :h 0.3) (first (frame-child *root-frame*))) ;; (add-frame (create-frame :x 0.1 :y 0.1 :w 0.3 :h 0.6) (first (frame-child (first (frame-child *root-frame*))))) ;; (setf *current-child* (first (frame-child *current-root*))) ;; (setf (frame-layout *current-child*) #'tile-layout)) ;; ;;(defun my-init-hook-2 () ;; (dbg 'my-init-hook) ;; (add-frame (create-frame :name "Default" :layout #'tile-left-layout :data (list '(:tile-size 0.6))) *root-frame*) ;; (setf *current-child* (first (frame-child *current-root*))) ;; (setf (frame-layout *current-child*) #'tile-layout)) ;; ;; ;;(defun my-init-hook-3 () ;; (dbg 'my-init-hook) ;; (add-frame (create-frame :name "plop" :x 0.1 :y 0.4 :w 0.7 :h 0.3) *root-frame*) ;; (add-frame (create-frame :name "Default" :layout nil :x 0.1 :y 0.5 :w 0.8 :h 0.5) ;; *root-frame*) ;; (setf *current-child* (first (frame-child *current-root*))) ;; (setf (frame-layout *root-frame*) nil)) ;; ;; ;; ;;(defun my-init-hook-4 () ;; (let ((frame (add-frame (create-frame :name "Default" ;; :layout #'tile-left-layout ;; :x 0.05 :y 0.05 :w 0.9 :h 0.9) ;; *root-frame*))) ;; (setf *current-child* frame))) ;; ;; ;;;;; Use this hook and prevent yourself to create a new frame to emulate ;;;;; the MS Windows desktop style :) ;;(defun my-init-hook-ms-windows-style () ;; (setf (frame-managed-type *root-frame*) nil)) ;; ;; ;;;;; Here is another example useful with the ROX filer: Only the ;;;;; root frame fullscreen with some space on the left for icons. ;;(defun my-init-hook-rox-filer () ;; (setf (frame-layout *root-frame*) #'tile-left-space-layout ;; (frame-data-slot *root-frame* :tile-size) 0.9)) ;; ;; ;; ;; ;;(setf *init-hook* '(my-init-hook-4)) ;; <- choose one in 1 to 4, ;;;; my-init-hook-ms-windows-style ;;;; my-init-hook-rox-filer ;;;;(setf *init-hook* nil) ;;;;; Init hook end clfswm-20111015.git51b0a02/doc/keys.html000066400000000000000000002234401164636077000173430ustar00rootroot00000000000000 CLFSWM Keys

CLFSWM Keys

Note: Mod-1 is the Meta or Alt key

Main mode keys

Modifiers Key/Button Function
Mod-1 F1 Open the help and info window
Mod-1 Control Shift Home Exit clfswm
Mod-1 Right Select the next brother
Mod-1 Left Select the previous brother
Mod-1 Down Select the previous level in frame
Mod-1 Up Select the next level in frame
Mod-1 Control Left Select spatially the nearest brother of the current child in the left direction
Mod-1 Control Right Select spatially the nearest brother of the current child in the right direction
Mod-1 Control Up Select spatially the nearest brother of the current child in the up direction
Mod-1 Control Down Select spatially the nearest brother of the current child in the down direction
Mod-1 Tab Select the next child
Mod-1 Shift Tab Select the previous child
Mod-1 Control Tab Select the next subchild
Mod-1 Return Enter in the selected frame - ie make it the root frame
Mod-1 Shift Return Leave the selected frame - ie make its parent the root frame
Mod-5 Return Maximize/Unmaximize the current frame in its parent frame
Mod-1 Page_up Select the previous child in the current frame
Mod-1 Page_down Select the next child in the current frame
Mod-1 Control Page_up Lower the child in the current frame
Mod-1 Control Page_down Raise the child in the current frame
Mod-1 Home Switch to the root frame
Mod-1 Shift Home Switch and select the root frame
Mod-1 F10 Switch between two layouts
Control Shift F10 Present all windows in all frames (An expose like)
F10 Present all windows in the current child (An expose like)
Control F10 Present all windows in the current frame (An expose like)
Control L2 Hide/Unhide a terminal
Shift L2 Show all frames info windows until a key is release
Mod-1 Shift L2 Show all frames info windows
Mod-1 B Move the pointer to the lower right corner of the screen
Control Escape Close or kill the current window (ask before doing anything)
Mod-1 T Switch to editing mode (second mode)
Control Less Switch to editing mode (second mode)
Mod-1 1 Bind or jump to a slot (a frame or a window)
Mod-1 2 Bind or jump to a slot (a frame or a window)
Mod-1 3 Bind or jump to a slot (a frame or a window)
Mod-1 4 Bind or jump to a slot (a frame or a window)
Mod-1 5 Bind or jump to a slot (a frame or a window)
Mod-1 6 Bind or jump to a slot (a frame or a window)
Mod-1 7 Bind or jump to a slot (a frame or a window)
Mod-1 8 Bind or jump to a slot (a frame or a window)
Mod-1 9 Bind or jump to a slot (a frame or a window)
Mod-1 0 Bind or jump to a slot (a frame or a window)

Mouse buttons actions in main mode

Modifiers Key/Button Function
1 Move and focus the current frame or focus the current window parent. Or do actions on corners
2 Do actions on corners
3 Resize and focus the current frame or focus the current window parent. Or do actions on corners
Mod-1 1 Move and focus the current child - Create a new frame on the root window
Mod-1 3 Resize and focus the current child - Create a new frame on the root window
Mod-1 Shift 1 Move (constrained by other frames) and focus the current child - Create a new frame on the root window
Mod-1 Shift 3 Resize (constrained by other frames) and focus the current child - Create a new frame on the root window
Mod-1 Control 1 Move the child under the mouse cursor to another frame
4 Select the next level in frame
5 Select the previous level in frame
Mod-1 4 Enter in the selected frame - ie make it the root frame
Mod-1 5 Leave the selected frame - ie make its parent the root frame

Second mode keys

Modifiers Key/Button Function
Mod-1 F1 Open the help and info window
M Open the main menu
Less Open the main menu
Control Less Open the main menu
F Open the frame menu
W Open the window menu
N Open the action by name menu
U Open the action by number menu
P Open the frame pack menu
L Open the frame fill menu
R Open the frame resize menu
X Update layout managed children position
Control G Stop all pending actions
Q Close focus window: Delete the focus window in all frames and workspaces
K Close or kill the current window (ask before doing anything)
I Identify a key
Colon Eval a lisp form from the query input
Exclam Run a program from the query input
Return Leave second mode
Escape Leave second mode
T Tile the current frame
Mod-1 Control Shift Home Exit clfswm
Mod-1 Right Select the next brother
Mod-1 Left Select the previous brother
Mod-1 Down Select the previous level in frame
Mod-1 Up Select the next level in frame
Mod-1 Control Left Select spatially the nearest brother of the current child in the left direction
Mod-1 Control Right Select spatially the nearest brother of the current child in the right direction
Mod-1 Control Up Select spatially the nearest brother of the current child in the up direction
Mod-1 Control Down Select spatially the nearest brother of the current child in the down direction
Right Speed move mouse to right
Left Speed move mouse to left
Down Speed move mouse to down
Up Speed move mouse to up
Control Left Undo last speed mouse move
Control Up Revert to the first speed move mouse
Control Down Reset speed mouse coordinates
Mod-1 Tab Select the next child
Mod-1 Shift Tab Select the previous child
Mod-1 Control Tab Select the next subchild
Tab Store the current child and switch to the previous one
Mod-1 Return Enter in the selected frame - ie make it the root frame
Mod-1 Shift Return Leave the selected frame - ie make its parent the root frame
Mod-5 Return Maximize/Unmaximize the current frame in its parent frame
Mod-1 Page_up Lower the child in the current frame
Mod-1 Page_down Raise the child in the current frame
Mod-1 Home Switch to the root frame
Mod-1 Shift Home Switch and select the root frame
Menu Show/Hide the root frame
Mod-1 B Move the pointer to the lower right corner of the screen
O Open the next window in a new frame in the parent frame
Control O Open the next window in a new frame in the root frame
A Add a default frame in the current frame
Control A Add a frame in the parent frame (and reorganize parent frame)
Plus Increase the tile layout size
Minus Decrease the tile layout size
Control Plus Increase slowly the tile layout size
Control Minus Decrease slowly the tile layout size
Control Escape Close or kill the current window (ask before doing anything)
Control X Cut the current child to the selection
Mod-1 Control X Clear the current selection
Control C Copy the current child to the selection
Control V Paste the selection in the current frame
Control Shift V Paste the selection in the current frame - Do not clear the selection after paste
Control Delete Remove the current child from its parent frame
Delete Delete the current child and its children in all frames
C start an xterm
E start emacs
Control E start an emacs for another user
H start an xclock
Mod-1 F10 Switch between two layouts
Control Shift F10 Present all windows in all frames (An expose like)
F10 Present all windows in the current child (An expose like)
Control F10 Present all windows in the current frame (An expose like)
Shift L2 Show all frames info windows until a key is release
Mod-1 Shift L2 Show all frames info windows
Mod-1 1 Bind or jump to a slot (a frame or a window)
Mod-1 2 Bind or jump to a slot (a frame or a window)
Mod-1 3 Bind or jump to a slot (a frame or a window)
Mod-1 4 Bind or jump to a slot (a frame or a window)
Mod-1 5 Bind or jump to a slot (a frame or a window)
Mod-1 6 Bind or jump to a slot (a frame or a window)
Mod-1 7 Bind or jump to a slot (a frame or a window)
Mod-1 8 Bind or jump to a slot (a frame or a window)
Mod-1 9 Bind or jump to a slot (a frame or a window)
Mod-1 0 Bind or jump to a slot (a frame or a window)

Mouse buttons actions in second mode

Modifiers Key/Button Function
1 Move and focus the current child - Create a new frame on the root window. Or do corners actions
2 Do actions on corners
3 Resize and focus the current child - Create a new frame on the root window. Or do corners actions
Mod-1 1 Move and focus the current child - Create a new frame on the root window
Mod-1 3 Resize and focus the current child - Create a new frame on the root window
Mod-1 Shift 1 Move (constrained by other frames) and focus the current child - Create a new frame on the root window
Mod-1 Shift 3 Resize (constrained by other frames) and focus the current child - Create a new frame on the root window
Mod-1 Control 1 Move the child under the mouse cursor to another frame
4 Select the next level in frame
5 Select the previous level in frame
Mod-1 4 Enter in the selected frame - ie make it the root frame
Mod-1 5 Leave the selected frame - ie make its parent the root frame

Info mode keys

Modifiers Key/Button Function
Q Leave the info mode
Return Leave the info mode and valid the selected item
Space Leave the info mode and valid the selected item
Escape Leave the info mode
Control G Leave the info mode
Twosuperior Move the pointer to the lower right corner of the screen
Down Move one line down
Up Move one line up
Left Move one char left
Right Move one char right
Home Move to first line
End Move to last line
Page_down Move ten lines down
Page_up Move ten lines up

Mouse buttons actions in info mode

Modifiers Key/Button Function
1
2 Leave the info mode
3 Leave the info mode
4 Move one line up
5 Move one line down
Motion

Circulate mode keys

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

Expose windows mode keys

Modifiers Key/Button Function
A Select child 'a' (0)
B Select child 'b' (1)
C Select child 'c' (2)
D Select child 'd' (3)
E Select child 'e' (4)
F Select child 'f' (5)
G Select child 'g' (6)
H Select child 'h' (7)
I Select child 'i' (8)
J Select child 'j' (9)
K Select child 'k' (10)
L Select child 'l' (11)
M Select child 'm' (12)
N Select child 'n' (13)
O Select child 'o' (14)
P Select child 'p' (15)
Q Select child 'q' (16)
R Select child 'r' (17)
S Select child 's' (18)
T Select child 't' (19)
U Select child 'u' (20)
V Select child 'v' (21)
W Select child 'w' (22)
X Select child 'x' (23)
Y Select child 'y' (24)
Z Select child 'z' (25)
0 Select child '0' (26)
1 Select child '1' (27)
2 Select child '2' (28)
3 Select child '3' (29)
4 Select child '4' (30)
5 Select child '5' (31)
6 Select child '6' (32)
7 Select child '7' (33)
8 Select child '8' (34)
9 Select child '9' (35)
A Select child 'A' (36)
B Select child 'B' (37)
C Select child 'C' (38)
D Select child 'D' (39)
E Select child 'E' (40)
F Select child 'F' (41)
G Select child 'G' (42)
H Select child 'H' (43)
I Select child 'I' (44)
J Select child 'J' (45)
K Select child 'K' (46)
L Select child 'L' (47)
M Select child 'M' (48)
N Select child 'N' (49)
O Select child 'O' (50)
P Select child 'P' (51)
Q Select child 'Q' (52)
R Select child 'R' (53)
S Select child 'S' (54)
T Select child 'T' (55)
U Select child 'U' (56)
V Select child 'V' (57)
W Select child 'W' (58)
X Select child 'X' (59)
Y Select child 'Y' (60)
Z Select child 'Z' (61)
Escape Leave the expose mode
Control G Leave the expose mode
Mod-1 Escape Leave the expose mode
Mod-1 Control G Leave the expose mode
Return Valid the expose mode
Space Valid the expose mode
Tab Valid the expose mode
Right Speed move mouse to right
Left Speed move mouse to left
Down Speed move mouse to down
Up Speed move mouse to up
Control Left Undo last speed mouse move
Control Up Revert to the first speed move mouse
Control Down Reset speed mouse coordinates

Mouse buttons actions in expose windows mode

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

This documentation was produced with the CLFSWM auto-doc functions. To reproduce it, use the produce-doc-html-in-file or the produce-all-docs function from the Lisp REPL.

Something like this:
LISP> (in-package :clfswm)
CLFSWM> (produce-doc-html-in-file "my-keys.html")
or
CLFSWM> (produce-all-docs)

clfswm-20111015.git51b0a02/doc/keys.txt000066400000000000000000000476451164636077000172310ustar00rootroot00000000000000 * CLFSWM Keys * ----------- Note: Mod-1 is the Meta or Alt key Main mode keys: -------------- Mod-1 F1 Open the help and info window Mod-1 Control Shift Home Exit clfswm Mod-1 Right Select the next brother Mod-1 Left Select the previous brother Mod-1 Down Select the previous level in frame Mod-1 Up Select the next level in frame Mod-1 Control Left Select spatially the nearest brother of the current child in the left direction Mod-1 Control Right Select spatially the nearest brother of the current child in the right direction Mod-1 Control Up Select spatially the nearest brother of the current child in the up direction Mod-1 Control Down Select spatially the nearest brother of the current child in the down direction Mod-1 Tab Select the next child Mod-1 Shift Tab Select the previous child Mod-1 Control Tab Select the next subchild Mod-1 Return Enter in the selected frame - ie make it the root frame Mod-1 Shift Return Leave the selected frame - ie make its parent the root frame Mod-5 Return Maximize/Unmaximize the current frame in its parent frame Mod-1 Page_up Select the previous child in the current frame Mod-1 Page_down Select the next child in the current frame Mod-1 Control Page_up Lower the child in the current frame Mod-1 Control Page_down Raise the child in the current frame Mod-1 Home Switch to the root frame Mod-1 Shift Home Switch and select the root frame Mod-1 F10 Switch between two layouts Control Shift F10 Present all windows in all frames (An expose like) F10 Present all windows in the current child (An expose like) Control F10 Present all windows in the current frame (An expose like) Control L2 Hide/Unhide a terminal Shift L2 Show all frames info windows until a key is release Mod-1 Shift L2 Show all frames info windows Mod-1 B Move the pointer to the lower right corner of the screen Control Escape Close or kill the current window (ask before doing anything) Mod-1 T Switch to editing mode (second mode) Control Less Switch to editing mode (second mode) Mod-1 1 Bind or jump to a slot (a frame or a window) Mod-1 2 Bind or jump to a slot (a frame or a window) Mod-1 3 Bind or jump to a slot (a frame or a window) Mod-1 4 Bind or jump to a slot (a frame or a window) Mod-1 5 Bind or jump to a slot (a frame or a window) Mod-1 6 Bind or jump to a slot (a frame or a window) Mod-1 7 Bind or jump to a slot (a frame or a window) Mod-1 8 Bind or jump to a slot (a frame or a window) Mod-1 9 Bind or jump to a slot (a frame or a window) Mod-1 0 Bind or jump to a slot (a frame or a window) Mouse buttons actions in main mode: ---------------------------------- 1 Move and focus the current frame or focus the current window parent. Or do actions on corners 2 Do actions on corners 3 Resize and focus the current frame or focus the current window parent. Or do actions on corners Mod-1 1 Move and focus the current child - Create a new frame on the root window Mod-1 3 Resize and focus the current child - Create a new frame on the root window Mod-1 Shift 1 Move (constrained by other frames) and focus the current child - Create a new frame on the root window Mod-1 Shift 3 Resize (constrained by other frames) and focus the current child - Create a new frame on the root window Mod-1 Control 1 Move the child under the mouse cursor to another frame 4 Select the next level in frame 5 Select the previous level in frame Mod-1 4 Enter in the selected frame - ie make it the root frame Mod-1 5 Leave the selected frame - ie make its parent the root frame Second mode keys: ---------------- Mod-1 F1 Open the help and info window M Open the main menu Less Open the main menu Control Less Open the main menu F Open the frame menu W Open the window menu N Open the action by name menu U Open the action by number menu P Open the frame pack menu L Open the frame fill menu R Open the frame resize menu X Update layout managed children position Control G Stop all pending actions Q Close focus window: Delete the focus window in all frames and workspaces K Close or kill the current window (ask before doing anything) I Identify a key Colon Eval a lisp form from the query input Exclam Run a program from the query input Return Leave second mode Escape Leave second mode T Tile the current frame Mod-1 Control Shift Home Exit clfswm Mod-1 Right Select the next brother Mod-1 Left Select the previous brother Mod-1 Down Select the previous level in frame Mod-1 Up Select the next level in frame Mod-1 Control Left Select spatially the nearest brother of the current child in the left direction Mod-1 Control Right Select spatially the nearest brother of the current child in the right direction Mod-1 Control Up Select spatially the nearest brother of the current child in the up direction Mod-1 Control Down Select spatially the nearest brother of the current child in the down direction Right Speed move mouse to right Left Speed move mouse to left Down Speed move mouse to down Up Speed move mouse to up Control Left Undo last speed mouse move Control Up Revert to the first speed move mouse Control Down Reset speed mouse coordinates Mod-1 Tab Select the next child Mod-1 Shift Tab Select the previous child Mod-1 Control Tab Select the next subchild Tab Store the current child and switch to the previous one Mod-1 Return Enter in the selected frame - ie make it the root frame Mod-1 Shift Return Leave the selected frame - ie make its parent the root frame Mod-5 Return Maximize/Unmaximize the current frame in its parent frame Mod-1 Page_up Lower the child in the current frame Mod-1 Page_down Raise the child in the current frame Mod-1 Home Switch to the root frame Mod-1 Shift Home Switch and select the root frame Menu Show/Hide the root frame Mod-1 B Move the pointer to the lower right corner of the screen O Open the next window in a new frame in the parent frame Control O Open the next window in a new frame in the root frame A Add a default frame in the current frame Control A Add a frame in the parent frame (and reorganize parent frame) Plus Increase the tile layout size Minus Decrease the tile layout size Control Plus Increase slowly the tile layout size Control Minus Decrease slowly the tile layout size Control Escape Close or kill the current window (ask before doing anything) Control X Cut the current child to the selection Mod-1 Control X Clear the current selection Control C Copy the current child to the selection Control V Paste the selection in the current frame Control Shift V Paste the selection in the current frame - Do not clear the selection after paste Control Delete Remove the current child from its parent frame Delete Delete the current child and its children in all frames C start an xterm E start emacs Control E start an emacs for another user H start an xclock Mod-1 F10 Switch between two layouts Control Shift F10 Present all windows in all frames (An expose like) F10 Present all windows in the current child (An expose like) Control F10 Present all windows in the current frame (An expose like) Shift L2 Show all frames info windows until a key is release Mod-1 Shift L2 Show all frames info windows Mod-1 1 Bind or jump to a slot (a frame or a window) Mod-1 2 Bind or jump to a slot (a frame or a window) Mod-1 3 Bind or jump to a slot (a frame or a window) Mod-1 4 Bind or jump to a slot (a frame or a window) Mod-1 5 Bind or jump to a slot (a frame or a window) Mod-1 6 Bind or jump to a slot (a frame or a window) Mod-1 7 Bind or jump to a slot (a frame or a window) Mod-1 8 Bind or jump to a slot (a frame or a window) Mod-1 9 Bind or jump to a slot (a frame or a window) Mod-1 0 Bind or jump to a slot (a frame or a window) Mouse buttons actions in second mode: ------------------------------------ 1 Move and focus the current child - Create a new frame on the root window. Or do corners actions 2 Do actions on corners 3 Resize and focus the current child - Create a new frame on the root window. Or do corners actions Mod-1 1 Move and focus the current child - Create a new frame on the root window Mod-1 3 Resize and focus the current child - Create a new frame on the root window Mod-1 Shift 1 Move (constrained by other frames) and focus the current child - Create a new frame on the root window Mod-1 Shift 3 Resize (constrained by other frames) and focus the current child - Create a new frame on the root window Mod-1 Control 1 Move the child under the mouse cursor to another frame 4 Select the next level in frame 5 Select the previous level in frame Mod-1 4 Enter in the selected frame - ie make it the root frame Mod-1 5 Leave the selected frame - ie make its parent the root frame Info mode keys: -------------- Q Leave the info mode Return Leave the info mode and valid the selected item Space Leave the info mode and valid the selected item Escape Leave the info mode Control G Leave the info mode Twosuperior Move the pointer to the lower right corner of the screen Down Move one line down Up Move one line up Left Move one char left Right Move one char right Home Move to first line End Move to last line Page_down Move ten lines down Page_up Move ten lines up Mouse buttons actions in info mode: ---------------------------------- 1 NIL 2 Leave the info mode 3 Leave the info mode 4 Move one line up 5 Move one line down Motion NIL Circulate mode keys: ------------------- Escape Leave the circulate mode Control G Leave the circulate mode Mod-1 Escape Leave the circulate mode Mod-1 Control G Leave the circulate mode Mod-1 Tab Select the next child Mod-1 Control Tab Select the next subchild Mod-1 Shift Tab Select the previous child Mod-1 Shift Iso_left_tab Select the previous child Mod-1 Right Select the next brother Mod-1 Left Select the previous borther Expose windows mode keys: ------------------------ A Select child 'a' (0) B Select child 'b' (1) C Select child 'c' (2) D Select child 'd' (3) E Select child 'e' (4) F Select child 'f' (5) G Select child 'g' (6) H Select child 'h' (7) I Select child 'i' (8) J Select child 'j' (9) K Select child 'k' (10) L Select child 'l' (11) M Select child 'm' (12) N Select child 'n' (13) O Select child 'o' (14) P Select child 'p' (15) Q Select child 'q' (16) R Select child 'r' (17) S Select child 's' (18) T Select child 't' (19) U Select child 'u' (20) V Select child 'v' (21) W Select child 'w' (22) X Select child 'x' (23) Y Select child 'y' (24) Z Select child 'z' (25) 0 Select child '0' (26) 1 Select child '1' (27) 2 Select child '2' (28) 3 Select child '3' (29) 4 Select child '4' (30) 5 Select child '5' (31) 6 Select child '6' (32) 7 Select child '7' (33) 8 Select child '8' (34) 9 Select child '9' (35) A Select child 'A' (36) B Select child 'B' (37) C Select child 'C' (38) D Select child 'D' (39) E Select child 'E' (40) F Select child 'F' (41) G Select child 'G' (42) H Select child 'H' (43) I Select child 'I' (44) J Select child 'J' (45) K Select child 'K' (46) L Select child 'L' (47) M Select child 'M' (48) N Select child 'N' (49) O Select child 'O' (50) P Select child 'P' (51) Q Select child 'Q' (52) R Select child 'R' (53) S Select child 'S' (54) T Select child 'T' (55) U Select child 'U' (56) V Select child 'V' (57) W Select child 'W' (58) X Select child 'X' (59) Y Select child 'Y' (60) Z Select child 'Z' (61) Escape Leave the expose mode Control G Leave the expose mode Mod-1 Escape Leave the expose mode Mod-1 Control G Leave the expose mode Return Valid the expose mode Space Valid the expose mode Tab Valid the expose mode Right Speed move mouse to right Left Speed move mouse to left Down Speed move mouse to down Up Speed move mouse to up Control Left Undo last speed mouse move Control Up Revert to the first speed move mouse Control Down Reset speed mouse coordinates Mouse buttons actions in expose windows mode: -------------------------------------------- 1 Valid the expose mode 2 Leave the expose mode 3 Leave the expose mode This documentation was produced with the CLFSWM auto-doc functions. To reproduce it, use the produce-doc-in-file or the produce-all-docs function from the Lisp REPL. Something like this: LISP> (in-package :clfswm) CLFSWM> (produce-doc-in-file "my-keys.txt") or CLFSWM> (produce-all-docs) clfswm-20111015.git51b0a02/doc/menu.html000066400000000000000000001671351164636077000173440ustar00rootroot00000000000000 CLFSWM Menu

CLFSWM Menu

Here is the map of the CLFSWM menu: (By default it is bound on second-mode + m)

Main

F1: < Help menu >

d: < Standard menu >

c: < Child menu >

f: < Frame menu >

w: < Window menu >

s: < Selection menu >

n: < Action by name menu >

u: < Action by number menu >

y: < Utility menu >

o: < Configuration menu >

m: < CLFSWM menu >

Help-Menu

a: Show the first aid kit key binding

h: Show all key binding

b: Show the main mode binding

s: Show the second mode key binding

r: Show the circulate mode key binding

e: Show the expose window mode key binding

c: Help on clfswm corner

g: Show all configurable variables

d: Show the current time and date

p: Show current processes sorted by CPU usage

m: Show current processes sorted by memory usage

v: Show the current CLFSWM version

Standard-Menu

a: < TEXTEDITOR >

b: < FILEMANAGER >

c: < WEBBROWSER >

d: < AUDIOVIDEO >

e: < AUDIO >

f: < VIDEO >

g: < DEVELOPMENT >

h: < EDUCATION >

i: < GAME >

j: < GRAPHICS >

k: < NETWORK >

l: < OFFICE >

m: < SETTINGS >

n: < SYSTEM >

o: < UTILITY >

p: < TERMINALEMULATOR >

q: < ARCHLINUX >

r: < SCREENSAVER >

Texteditor

a: Emacs Text Editor - Edit text

b: gVim - GTK2 enhanced vim text editor

c: Kate

d: Snippets datafile editor

e: KWrite

f: Mousepad - Simple text editor

g: PDF Editor

h: Xfw - A simple text editor for Xfe

Filemanager

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

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

c: Dolphin

d: Krusader

e: File Manager - Configure the Thunar file manager

f: ROX Filer - ROX Filer

g: Worker - File manager for X.

h: Xfe - A lightweight file manager for X Window

Webbrowser

a: Arora - Browse the World Wide Web

b: Chromium - Access the Internet

c: Conkeror - Conkeror is a Mozilla-based web browser whose design is inspired by GNU Emacs

d: Epiphany - Browse the web

e: Firefox

f: IcedTea Web Start - IcedTea Application Launcher

g: Konqueror

h: rekonq

i: Links

j: Midori - Lightweight web browser

k: Opera - A fast and secure web browser and Internet suite

Audiovideo

a: AcidRip DVD Ripper - DVD Ripper

b: Ardour - Multitrack hard disk recorder

c: Ario - Client application to mpd

d: Audacity - Record and edit audio files

e: Beep Media Player - Play music

f: Brasero - Create and copy CDs and DVDs

g: Cinelerra - Video Editor

h: dvd::rip - DVD Ripper and Encoder - Backup and compression utility for DVDs

i: Freevo - Home theatre

j: Camelot - Gmerlin webcam application

k: Gmerlin KBD - Configure the Gmerlin keyboard daemon

l: Gmerlin player - Multiformat mediaplayer

m: Gmerlin recorder - Audio/video recorder

n: Gmerlin transcoder - Gmerlin multimedia transcoder

o: Gmerlin visualizer - Run visualization plugins

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

q: Sound Recorder - Record sound clips

r: Grip - CD player/ripper

s: gtk-recordMyDesktop - Frontend for recordMyDesktop

t: Hydrogen Drum Machine - Create drum sequences

u: Dragon Player

v: JuK

w: K3b - Disk writing program

x: Kdenlive - Nonlinear video editor for KDE

y: KMix

z: KsCD

0: Mixxx - A digital DJ interface

1: MPlayer Media Player - Play movies and songs

2: Open Movie Editor - Video Editor

3: OpenShot Video Editor - Create and edit videos and movies

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

5: qt-recordMyDesktop - Frontend for recordMyDesktop

6: QT V4L2 test Utility - Allow testing Video4Linux devices

7: Rhythmbox - Play and organize your music collection

8: Rhythmbox - Play and organize your music collection

9: SMPlayer - A great MPlayer front-end

A: Enqueue in SMPlayer

B: Sonata - An elegant GTK+ MPD client

C: Audio CD Extractor - Copy music from your CDs

D: Movie Player - Play movies and songs

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

F: XBMC Media Center - Manage and view your media

G: Mixer - Audio mixer for the Xfce Desktop Environment

H: XMMS - X Multimedia System

I: zynaddsubfx - An opensource software synthesizer

Audio

a: Ardour - Multitrack hard disk recorder

b: Ario - Client application to mpd

c: Audacity - Record and edit audio files

d: Gmerlin plugin configurator - Configure gmerlin plugins

e: Sound Recorder - Record sound clips

f: Hydrogen Drum Machine - Create drum sequences

g: KMix

h: Mixxx - A digital DJ interface

i: MPlayer Media Player - Play movies and songs

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

k: Audio CD Extractor - Copy music from your CDs

l: Mixer - Audio mixer for the Xfce Desktop Environment

Video

a: Ardour - Multitrack hard disk recorder

b: dvd::rip - DVD Ripper and Encoder - Backup and compression utility for DVDs

c: MPlayer Media Player - Play movies and songs

d: OpenShot Video Editor - Create and edit videos and movies

e: SMPlayer - A great MPlayer front-end

f: Enqueue in SMPlayer

g: Movie Player - Play movies and songs

h: XBMC Media Center - Manage and view your media

Development

a: CMake - Cross-platform buildsystem

b: Qt Assistant - Shows Qt documentation and examples

c: Data Display Debugger - Graphical debugger frontend

d: Qt Designer - Design GUIs for Qt applications

e: DrRacket - DrRacket is an interactive, integrated, graphical programming environment for the Racket programming languages.

f: EAGLE Light Edition

g: Eeschema - Design a printed circuit board.

h: Emacs Text Editor - Edit text

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

j: Java Monitoring and Management Console

k: Java VisualVM

l: OpenJDK Monitoring & Management Console - Monitor and manage OpenJDK applications

m: Akonadi Console - Akonadi Management and Debugging Console

n: Cervisia

o: KAppTemplate

p: KBugBuster

q: KCachegrind - Visualization of Performance Profiling Data

r: KDE Source Builder - Builds the KDE Platform and associated software from its source code. A command-line only program.

s: KImageMapEditor

t: KLinkStatus

u: Kompare

v: KUIViewer

w: Lokalize

x: Umbrello

y: KiCad - Design a printed circuit board.

z: Qt Linguist - Add translations to Qt applications

0: OpenJDK Policy Tool - Manage OpenJDK policy files

Education

a: Avogadro - Advanced molecular editor

b: Circle and Ruler - Geometry program

c: DrGeo

d: DrRacket - DrRacket is an interactive, integrated, graphical programming environment for the Racket programming languages.

e: GeoGebra - Create interactive mathematical constructions and applets.

f: geometria

g: Blinken - A memory enhancement game

h: Cantor

i: KAlgebra - Math Expression Solver and Plotter

j: KAlgebra Mobile - Pocket Math Expression Solver and Plotter

k: Kalzium - KDE Periodic Table of Elements

l: Kanagram - KDE Letter Order Game

m: KBruch - Practice exercises with fractions

n: KGeography - A Geography Learning Program

o: KHangMan - KDE Hangman Game

p: Kig - Explore Geometric Constructions

q: Kiten - Japanese Reference and Study Tool

r: KLettres - a KDE program to learn the alphabet

s: KmPlot - Function Plotter

t: KStars - Desktop Planetarium

u: KTouch

v: KTurtle

w: KWordQuiz - A flashcard and vocabulary learning program

x: Marble

y: Parley

z: Rocs - Graph Theory Tool for Professors and Students.

0: Step - Simulate physics experiments

1: Oregano electrical engineering tool - Schematic capture and simulation of electronic circuits

2: QtOctave - GUI for GNU Octave

3: VYM - View Your Mind

4: wxMaxima - Perform symbolic and numeric calculations using Maxima

5: Xcas Computer Algebra System - The swiss knife for mathematics

Game

a: 0 A.D. Editor

b: 0 A.D.

c: AssaultCube

d: Astromenace - Space shooter

e: Blobby Volley 2

f: Bloboats - A boat racing game reminiscent of Elasto Mania and X-Moto

g: BomberClone - Atomic Bomberman clone

h: Chromium B.S.U. - Scrolling space shooter

i: DreamChess

j: DROD - Simple puzzle game.

k: eBoard

l: Einstein - Einstein puzzle

m: Extreme Tux Racer - Open source racing game featuring Tux the Linux Penguin.

n: Flobopuyo - A remake of the famous PuyoPuyo

o: Foobillard - A 3D billiards game using OpenGL

p: Frasse - Frasse and the Peas of Kejick adventure game

q: Frogatto - Old-school 2D platformer

r: gbrainy - Play games that challenge your logic, verbal, calculation and memory abilities

s: GGoban - Play go and review game records

t: glChess

u: GLTron - Lightcycle game with a nice 3D perspective.

v: Hedgewars - Worms style game

w: Hex-a-Hop - Hexagonal Tile-based Puzzle Game

x: KGoldrunner - A game of action and puzzle-solving

y: AMOR

z: Blinken - A memory enhancement game

0: Bomber

1: Bovo

2: Granatier

3: Kanagram - KDE Letter Order Game

4: Kapman - Eat pills escaping ghosts

5: KAtomic

6: Naval Battle

7: KBlackBox

8: KBlocks

9: KBounce

A: KBreakOut

B: KSnake

C: KDiamond

D: KFourInLine

E: KHangMan - KDE Hangman Game

F: Kigo

G: Killbots

H: Kiriki

I: KJumpingCube

J: Klickety

K: Kolor Lines

L: KMahjongg

M: KMines

N: KNetWalk

O: Knights

P: Kolf

Q: Kollision - A simple ball dodging game

R: Konquest

S: KPatience

T: KReversi

U: SameGame

V: Shisen-Sho

W: KsirK

X: KsirK Skin Editor

Y: KSpaceDuel

Z: KSquares

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

|: KSnakeDuel

|: Potato Guy

|: Kubrick

|: LSkat

|: Palapeli

|: KoboDeluxe - An excellent 2D Shootem-up game.

|: Maniadrive - An arcade car game on acrobatic tracks, with a quick and nervous gameplay

|: mechtower(failsafe)

|: mechtower

|: Numpty Physics

|: OpenArena - A Quake3-based FPS Game

|: OpenTTD

|: Pacdefence - Tower defence game.

|: PainTown - Paintown is an open source fighting game in the same genre as Streets of Rage and Teenage Mutant Ninja Turtles.

|: pouetChess - Play a game of chess, either against another player or against the AI

|: Racer - Choose your car and race

|: Racer - Choose your car and race

|: Slime Volley - Unrealistic 2D volleyball simulation

|: SolarWolf

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

|: Stormbaan Coureur

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

|: Supertuxkart - A kart racing game

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

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

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

|: Wind and Water: Puzzle Battles - Arcade style puzzle game

|: XBoard - An X Window System graphical chessboard

|: Xmoto

|: XSpaceWarp - Live long and prosper!

|: Xut - Button football simulation

|: Zelvici - Funny 2D platform game

|: Zero Ballistics

Graphics

a: LibreOffice Draw

b: Image Viewer

c: Document Viewer - View multi-page documents

d: Gcolor2 - Choose colours from palette or screen

e: Geeqie - View and manage images

f: PostScript Viewer - View PostScript files

g: GNU Image Manipulation Program - Create images and edit photographs

h: Image Viewer

i: GQview - View and manage images

j: gThumb - View and organize your images

k: gThumb - View and organize your images

l: GV

m: Inkscape - Create and edit Scalable Vector Graphics images

n: digiKam

o: Gwenview - A simple image viewer

p: KColorChooser

q: KolourPaint

r: KRuler

s: KSnapshot

t: Okular

u: Okular

v: Okular

w: Okular

x: Okular

y: Okular

z: Okular

0: Okular

1: Okular

2: Okular

3: Okular

4: Okular

5: Okular

6: Okular

7: Okular

8: Okular

9: showFoto - Manage your photographs like a professional with the power of open source

A: MuPDF - PDF file viewer

B: Xfig

C: xgps - Display GPS information from a gpsd daemon

D: xgpsspeed - Display GPS speed from a gpsd daemon

E: XSane - Scanning - Acquire images from a scanner

Network

a: Arora - Browse the World Wide Web

b: Epiphany Web Bookmarks - Browse and organize your bookmarks

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

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

e: Chromium - Access the Internet

f: Conkeror - Conkeror is a Mozilla-based web browser whose design is inspired by GNU Emacs

g: Ekiga Softphone - Talk to and see people over the Internet

h: Epiphany - Browse the web

i: Mail Reader

j: Web Browser

k: Minefield - Safe Mode

l: Minefield

m: Firefox

n: Gnaughty - Porn downloader

o: Gwget Download Manager - Download files from the Internet

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

q: Java Web Start

r: IcedTea Web Start - IcedTea Application Launcher

s: KMail

t: KNode

u: KPPP

v: Akregator - A Feed Reader for KDE

w: Blogilo

x: KGet

y: KNetAttach

z: Konqueror

0: Kopete - Instant Messenger

1: KPPPLogview

2: KRDC

3: Krfb

4: rekonq

5: Links

6: Midori - Lightweight web browser

7: MLDonkey GUI - multi-protocol P2P program

8: MultiGet - Multi thread download tools

9: OpenArena Server - Run an OpenArena server

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

B: SeaMonkey internet suite

C: Thunderbird - Mail & News Reader

D: Transmission - Download and share files over BitTorrent

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

F: unison - File synchronisation tool for X11

G: LibreOffice Writer/Web

H: Wicd - Manage Wired/Wireless Networks

I: Zenmap (as root)

J: Zenmap

Office

a: AbiWord

b: LibreOffice Base

c: LibreOffice Calc

d: ePDFViewer - Lightweight PDF document viewer

e: Evolution - Manage your email, contacts and schedule

f: FreeMind

g: Orage Globaltime - Show clocks from different countries

h: Gnumeric - Calculation, Analysis, and Visualization of Information

i: GV

j: LibreOffice Impress

k: Kontact

l: KAddressBook

m: KOrganizer - Calendar and Scheduling Program

n: KTimeTracker

o: KWord - Write text documents

p: Lokalize

q: Okular

r: LibreOffice 3.3 Math

s: LibreOffice 3.3 Printer Administration

t: LibreOffice 3.3

u: LibreOffice 3.3 Writer

v: Lyx - Latex WYSIWYM Editor

w: LibreOffice Extension Manager

x: OOo4Kids 1.2 Calc

y: OOo4Kids 1.2 Draw

z: OOo4Kids 1.2 Impress

0: OOo4Kids 1.2 Math

1: OOo4Kids 1.2

2: OOo4Kids 1.2 Printer Administration

3: OOo4Kids 1.2 Writer

4: LibreOffice Quickstarter

5: LibreOffice

6: Orage Calendar - Desktop calendar

7: XMind - Launch XMind 3.0

8: Xpdf - Views Adobe PDF (acrobat) files

9: Zathura - A minimalistic PDF viewer

Settings

a: Email Settings - Configure email accounts

b: Preferred Applications

c: Keyboard Indicator plugins - Enable/disable installed plugins

d: Privilege granting - Configure behavior of the privilege-granting tool

e: Multimedia Systems Selector - Configure defaults for GStreamer applications

f: Touchpad - Set your touchpad preferences

g: Java Control Panel

h: Java Policy Settings

i: Menu Updating Tool

j: Change Password

k: Menu Editor

l: System Settings

m: Preferred Applications

n: Customize Look and Feel - Customizes look and feel of your desktop and applications

o: Monitor Settings - Change screen resolution and configure external monitors

p: Opera Widget Manager

q: Panel

r: Qt Config - Configure Qt behavior, styles, fonts

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

t: File Manager - Configure the Thunar file manager

u: Panel tint2 - Customize the panel settings

v: Startup Disk Creator - Create a startup disk using a CD or disc image

w: Desktop - Set desktop background and menu and icon behaviour

x: Display - Configure screen settings and layout

y: Keyboard - Edit keyboard settings and application shortcuts

z: Mouse - Configure pointer device behavior and appearance

0: Session and Startup - Customize desktop startup and splash screen

1: Settings Manager - Graphical Settings Manager for Xfce 4

2: Appearance - Customize the look of your desktop

3: Window Manager - Configure window behavior and shortcuts

4: Window Manager Tweaks - Fine-tune window behaviour and effects

5: Workspaces - Set number and names of workspaces

6: Orage preferences - Settings for the Xfce 4 Calendar Application (Orage)

7: Accessibility - Improve keyboard and mouse accessibility

8: Settings Editor - Graphical settings editor for Xfconf

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

A: Screensaver - Change screensaver properties

System

a: Terminal - Use the command line

b: Bulk Rename - Rename Multiple Files

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

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

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

f: CD/DVD Creator - Create CDs and DVDs

g: Cairo-Dock (no OpenGL) - A light and eye-candy dock and desklets for your desktop.

h: GLX-Dock (Cairo-Dock with OpenGL) - Cairo-Dock with OpenGL (hardware acceleration)

i: Manage Printing

j: dconf Editor - Directly edit your entire configuration database

k: Configuration Editor - Directly edit your entire configuration database

l: Keyboard Layout - Preview keyboard layouts

m: Panel

n: System Monitor

o: GParted - Create, reorganize, and delete partitions

p: Htop - Show System Processes

q: Dolphin

r: K3b - Disk writing program

s: KDiskFree

t: Konqueror

u: Konqueror

v: Konqueror

w: Konqueror

x: KInfoCenter

y: File Manager - Super User Mode

z: Konsole

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

1: Krfb

2: Krusader - root-mode

3: System Monitor

4: KSystemLog

5: KUser

6: KWalletManager

7: KwikDisk

8: Nepomuk Backup

9: Yakuake

A: Task Manager - Manage running processes

B: rxvt-unicode - An Unicode capable rxvt clone

C: UNetbootin - Tool for creating Live USB drives

D: Startup Disk Creator - Create a startup disk using a CD or disc image

E: Startup Disk Creator - Create a startup disk using a CD or disc image

F: Oracle VM VirtualBox

G: Wireshark - Network traffic analyzer

H: Log Out

I: Xfe - A lightweight file manager for X Window

J: XNC - Graphical File manager, X Northern Captain

Utility

a: SAGE - SAGE NOTEBOOK

b: Terminal - Use the command line

c: Bulk Rename - Rename Multiple Files

d: Open Folder with Thunar - Open the specified folders in Thunar

e: Thunar File Manager - Browse the filesystem with the file manager

f: Brasero - Create and copy CDs and DVDs

g: Circle and Ruler - Geometry program

h: dosbox Emulator - An emulator to run old DOS games

i: File Manager - Configure the Thunar file manager

j: Terminal Emulator

k: gEDA Attribute Editor - Manipulate component attributes with gattrib

l: gEDA Schematic Editor - Create and edit electrical schematics and symbols with gschem

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

n: Orage Globaltime - Show clocks from different countries

o: Terminal - Use the command line

p: Image Viewer

q: GSpiceUI - A GUI to various freely available Spice electronic circuit simulators

r: Character Map - Insert special characters into documents

s: gVim - GTK2 enhanced vim text editor

t: HP Device Manager - View device status, ink levels and perform maintenance.

u: K3DSurf - Visualize and manipulate Mathematical models in three, four, five, and six dimensions

v: Help - Get help with GNOME

w: Home

x: KCharSelect

y: KFloppy

z: KJots

0: Akonaditray

1: Ark

2: KDE Groupware Wizard

3: KAlarm

4: Kate

5: KCalc

6: KFileReplace

7: Find Files/Folders

8: KFontView

9: KGpg - A GnuPG frontend

A: Kleopatra

B: Kleopatra

C: Klipper

D: KMag

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

F: KMouth

G: KNotes

H: KonsoleKalendar

I: Krusader

J: KTeaTime

K: Snippets datafile editor

L: KTimer

M: KTimeTracker

N: KWrite

O: Okteta

P: SuperKaramba - An engine for cool desktop eyecandy.

Q: Sweeper

R: LXTerminal - Use the command line

S: XMaxima - A sophisticated computer algebra system

T: Mousepad - Simple text editor

U: Files - Access and organize files

V: Disk Utility - Manage Drives and Media

W: File Manager - Configure the Thunar file manager

X: PDF Editor

Y: PlayOnLinux - PlayOnLinux

Z: Scilab - A scientific software package for numerical computations

|: Tilda

|: Worker - File manager for X.

|: About Xfce

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

|: Help - Get help with GNOME

|: Xfi - A simple image viewer for Xfe

|: Xfp - A simple package manager for Xfe

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

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

|: Run Program...

|: Xfv - A simple text viewer for Xfe

|: Xfw - A simple text editor for Xfe

|: XNC - Graphical File manager, X Northern Captain

|: Help - Get help with GNOME

|: Zhu3D - With Zhu3D, you can view, animate, and solve up to three functions in 3D-space in an interactive manner

|: KDE Resources - Configure KDE Resources

Terminalemulator

a: Terminal - Use the command line

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

c: Terminal - Use the command line

d: Konsole

e: Yakuake

f: LXTerminal - Use the command line

g: rxvt-unicode - An Unicode capable rxvt clone

h: Tilda

Archlinux

a: AUR - Archlinux AUR

b: Bugs - Archlinux Bugtracker

c: Developers - Archlinux development team

d: Documentation - Archlinux Documentation

e: Donate - Archlinux Donations

f: Forum - Archlinux Forum

g: Homepage - Archlinux homepage

h: SVN - Archlinux SVN

i: Schwag - Archlinux goodie shopping

j: Wiki - Archlinux Wiki

Screensaver

Child-Menu

r: Rename the current child

e: Ensure that all children names are unique

n: Ensure that all children numbers are unique

Delete: Delete the current child and its children in all frames

X: Remove the current child from its parent frame

h: Hide the current child

u: Unhide a child in the current frame

f: Unhide a child from all frames in the current frame

a: Unhide all current frame hidden children

Page_Up: Lower the child in the current frame

Page_Down: Raise the child in the current frame

Frame-Menu

a: < Adding frame menu >

l: < Frame layout menu >

n: < Frame new window hook menu >

m: < Frame movement menu >

f: < Frame focus policy menu >

w: < Managed window type menu >

u: < Unmanaged window behaviour >

s: < Frame miscallenous menu >

x: Maximize/Unmaximize the current frame in its parent frame

Frame-Adding-Menu

a: Add a default frame in the current frame

p: Add a placed frame in the current frame

Frame-Layout-Menu

a: < Frame fast layout menu >

b: No layout: Maximize windows in their frame - Leave frames to their original size

c: No layout: Maximize windows in their frame - Leave frames to their actual size

d: Maximize layout: Maximize windows and frames in their parent frame

e: < Frame tile layout menu >

f: < Tile in one direction layout menu >

g: < Tile with some space on one side menu >

h: < Main window layout menu >

i: < The GIMP layout menu >

Frame-Fast-Layout-Menu

s: Switch between two layouts

p: Push the current layout in the fast layout list

Frame-Tile-Layout-Menu

v: Tile child in its frame (vertical)

h: Tile child in its frame (horizontal)

c: One column layout

l: One line layout

s: Tile Space: tile child in its frame leaving spaces between them

Frame-Tile-Dir-Layout-Menu

l: Tile Left: main child on left and others on right

r: Tile Right: main child on right and others on left

t: Tile Top: main child on top and others on bottom

b: Tile Bottom: main child on bottom and others on top

Frame-Tile-Space-Layout-Menu

a: Tile Left Space: main child on left and others on right. Leave some space on the left.

Frame-Main-Window-Layout-Menu

r: Main window right: Main windows on the right. Others on the left.

l: Main window left: Main windows on the left. Others on the right.

t: Main window top: Main windows on the top. Others on the bottom.

b: Main window bottom: Main windows on the bottom. Others on the top.

-=- Actions on main windows list -=-

a: Add the current window in the main window list

v: Remove the current window from the main window list

c: Clear the main window list

Frame-Gimp-Layout-Menu

g: The GIMP Layout

p: Restore the previous layout

h: Help on the GIMP layout

-=- Main window layout -=-

r: Main window right: Main windows on the right. Others on the left.

l: Main window left: Main windows on the left. Others on the right.

t: Main window top: Main windows on the top. Others on the bottom.

b: Main window bottom: Main windows on the bottom. Others on the top.

-=- Actions on main windows list -=-

a: Add the current window in the main window list

v: Remove the current window from the main window list

c: Clear the main window list

Frame-Nw-Hook-Menu

a: Open the next window in the current frame

b: Open the next window in the current root

c: Open the next window in a new frame in the current root

d: Open the next window in a new frame in the root frame

e: Open the next window in a new frame in the parent frame

f: Open the next window in the current frame and leave the focus on the current child

g: Open the next window in a named frame

h: Open the next window in a numbered frame

i: Open the window in this frame if it match nw-absorb-test

Frame-Movement-Menu

p: < Frame pack menu >

f: < Frame fill menu >

r: < Frame resize menu >

c: Center the current frame

Right: Select the next brother frame

Left: Select the previous brother frame

Up: Select the next level

Down: Select the previous levelframe

Tab: Select the next child

Frame-Pack-Menu

Up: Pack the current frame up

Down: Pack the current frame down

Left: Pack the current frame left

Right: Pack the current frame right

Frame-Fill-Menu

Up: Fill the current frame up

Down: Fill the current frame down

Left: Fill the current frame left

Right: Fill the current frame right

a: Fill the current frame in all directions

v: Fill the current frame vertically

h: Fill the current frame horizontally

Frame-Resize-Menu

Up: Resize the current frame up to its half height

Down: Resize the current frame down to its half height

Left: Resize the current frame left to its half width

Right: Resize the current frame right to its half width

a: Resize down the current frame

m: Resize down the current frame to its minimal size

Frame-Focus-Policy

-=- For the current frame -=-

a: Set a click focus policy for the current frame.

b: Set a sloppy focus policy for the current frame.

c: Set a (strict) sloppy focus policy only for windows in the current frame.

d: Set a sloppy select policy for the current frame.

-=- For all frames -=-

e: Set a click focus policy for all frames.

f: Set a sloppy focus policy for all frames.

g: Set a (strict) sloppy focus policy for all frames.

h: Set a sloppy select policy for all frames.

Frame-Managed-Window-Menu

m: Change window types to be managed by a frame

a: Manage all window type

n: Manage only normal window type

u: Do not manage any window type

Frame-Unmanaged-Window-Menu

s: Show unmanaged windows when frame is not selected

h: Hide unmanaged windows when frame is not selected

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

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

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

Frame-Miscellaneous-Menu

s: Show all frames info windows

a: Hide all frames info windows

h: Hide the current frame window

w: Show the current frame window

u: Renumber the current frame

x: Create a new frame for each window in frame

i: Absorb all frames subchildren in frame (explode frame opposite)

Window-Menu

i: Display information on the current window

f: Force the current window to move in the frame (Useful only for unmanaged windows)

c: Force the current window to move in the center of the frame (Useful only for unmanaged windows)

m: Force to manage the current window by its parent frame

u: Force to not manage the current window by its parent frame

a: Adapt the current frame to the current window minimal size hints

w: Adapt the current frame to the current window minimal width hint

h: Adapt the current frame to the current window minimal height hint

Selection-Menu

x: Cut the current child to the selection

c: Copy the current child to the selection

v: Paste the selection in the current frame

p: Paste the selection in the current frame - Do not clear the selection after paste

Delete: Remove the current child from its parent frame

z: Clear the current selection

Action-By-Name-Menu

f: Focus a frame by name

o: Open a new frame in a named frame

d: Delete a frame by name

m: Move current child in a named frame

c: Copy current child in a named frame

Action-By-Number-Menu

f: Focus a frame by number

o: Open a new frame in a numbered frame

d: Delete a frame by number

m: Move current child in a numbered frame

c: Copy current child in a numbered frame

Utility-Menu

i: Identify a key

colon: Eval a lisp form from the query input

exclam: Run a program from the query input

o: < Other window manager menu >

Other-Window-Manager-Menu

x: Run xterm

t: Run twm

i: Run icewm

g: Run Gnome

k: Run KDE

c: Run XFCE

l: Run LXDE

p: Prompt for an other window manager

Configuration-Menu

a: < Gimp Layout Group >

b: < Notify Window Group >

c: < Menu Group >

d: < Expose Mode Group >

e: < Circulate Mode Group >

f: < Info Mode Group >

g: < Query String Group >

h: < Identify Key Group >

i: < Second Mode Group >

j: < Frame Colors Group >

k: < Corner Group >

l: < Placement Group >

m: < Hook Group >

n: < Main Mode Group >

o: < Miscellaneous Group >

F2: Save all configuration variables in clfswmrc

F3: Reset all configuration variables to their default values

Conf-Gimp-Layout

a: Configure GIMP-LAYOUT-NOTIFY-WINDOW-DELAY

Conf-Notify-Window

a: Configure NOTIFY-WINDOW-DELAY

b: Configure NOTIFY-WINDOW-BORDER

c: Configure NOTIFY-WINDOW-FOREGROUND

d: Configure NOTIFY-WINDOW-BACKGROUND

e: Configure NOTIFY-WINDOW-FONT-STRING

Conf-Menu

a: Configure XDG-SECTION-LIST

b: Configure MENU-COLOR-MENU-KEY

c: Configure MENU-COLOR-KEY

d: Configure MENU-COLOR-COMMENT

e: Configure MENU-COLOR-SUBMENU

Conf-Expose-Mode

a: Configure EXPOSE-SHOW-WINDOW-TITLE

b: Configure EXPOSE-VALID-ON-KEY

c: Configure EXPOSE-BORDER

d: Configure EXPOSE-FOREGROUND

e: Configure EXPOSE-BACKGROUND

f: Configure EXPOSE-FONT-STRING

Conf-Circulate-Mode

a: Configure CIRCULATE-TEXT-LIMITE

b: Configure CIRCULATE-HEIGHT

c: Configure CIRCULATE-WIDTH

d: Configure CIRCULATE-BORDER

e: Configure CIRCULATE-FOREGROUND

f: Configure CIRCULATE-BACKGROUND

g: Configure CIRCULATE-FONT-STRING

Conf-Info-Mode

a: Configure INFO-COLOR-SECOND

b: Configure INFO-COLOR-FIRST

c: Configure INFO-COLOR-UNDERLINE

d: Configure INFO-COLOR-TITLE

e: Configure INFO-CLICK-TO-SELECT

f: Configure INFO-FONT-STRING

g: Configure INFO-SELECTED-BACKGROUND

h: Configure INFO-LINE-CURSOR

i: Configure INFO-BORDER

j: Configure INFO-FOREGROUND

k: Configure INFO-BACKGROUND

Conf-Query-String

a: Configure QUERY-BORDER

b: Configure QUERY-PARENT-ERROR-COLOR

c: Configure QUERY-PARENT-COLOR

d: Configure QUERY-CURSOR-COLOR

e: Configure QUERY-FOREGROUND

f: Configure QUERY-MESSAGE-COLOR

g: Configure QUERY-BACKGROUND

h: Configure QUERY-FONT-STRING

Conf-Identify-Key

a: Configure IDENTIFY-BORDER

b: Configure IDENTIFY-FOREGROUND

c: Configure IDENTIFY-BACKGROUND

d: Configure IDENTIFY-FONT-STRING

Conf-Second-Mode

a: Configure SM-HEIGHT

b: Configure SM-WIDTH

c: Configure SM-FONT-STRING

d: Configure SM-FOREGROUND-COLOR

e: Configure SM-BACKGROUND-COLOR

f: Configure SM-BORDER-COLOR

Conf-Frame-Colors

a: Configure FRAME-FOREGROUND-HIDDEN

b: Configure FRAME-FOREGROUND-ROOT

c: Configure FRAME-FOREGROUND

d: Configure FRAME-BACKGROUND

Conf-Corner

a: Configure CLFSWM-TERMINAL-CMD

b: Configure CLFSWM-TERMINAL-NAME

c: Configure VIRTUAL-KEYBOARD-CMD

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

e: Configure CORNER-SECOND-MODE-MIDDLE-BUTTON

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

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

h: Configure CORNER-MAIN-MODE-MIDDLE-BUTTON

i: Configure CORNER-MAIN-MODE-LEFT-BUTTON

j: Configure CORNER-SIZE

Conf-Placement

a: Configure ASK-CLOSE/KILL-PLACEMENT

b: Configure NOTIFY-WINDOW-PLACEMENT

c: Configure EXPOSE-MODE-PLACEMENT

d: Configure CIRCULATE-MODE-PLACEMENT

e: Configure QUERY-MODE-PLACEMENT

f: Configure INFO-MODE-PLACEMENT

g: Configure SECOND-MODE-PLACEMENT

h: Configure BANISH-POINTER-PLACEMENT

Conf-Hook

a: Configure DEFAULT-NW-HOOK

b: Configure CLOSE-HOOK

c: Configure INIT-HOOK

d: Configure MAIN-ENTRANCE-HOOK

e: Configure LOOP-HOOK

f: Configure BINDING-HOOK

Conf-Main-Mode

a: Configure COLOR-MAYBE-SELECTED

b: Configure COLOR-UNSELECTED

c: Configure COLOR-SELECTED

d: Configure COLOR-MOVE-WINDOW

Conf-Miscellaneous

a: Configure DEFAULT-WINDOW-HEIGHT

b: Configure DEFAULT-WINDOW-WIDTH

c: Configure CREATE-FRAME-ON-ROOT

d: Configure SPATIAL-MOVE-DELAY-AFTER

e: Configure SPATIAL-MOVE-DELAY-BEFORE

f: Configure SNAP-SIZE

g: Configure HIDE-UNMANAGED-WINDOW

h: Configure NEVER-MANAGED-WINDOW-LIST

i: Configure DEFAULT-MODIFIERS

j: Configure DEFAULT-FOCUS-POLICY

k: Configure DEFAULT-MANAGED-TYPE

l: Configure DEFAULT-FRAME-DATA

m: Configure DEFAULT-FONT-STRING

n: Configure LOOP-TIMEOUT

o: Configure BORDER-SIZE

p: Configure SHOW-ROOT-FRAME-P

q: Configure HAVE-TO-COMPRESS-NOTIFY

Clfswm-Menu

r: Reset clfswm

l: Reload clfswm

x: Exit clfswm

This documentation was produced with the CLFSWM auto-doc functions. To reproduce it, use the produce-menu-doc-html-in-file or the produce-all-docs function from the Lisp REPL.

Something like this:
LISP> (in-package :clfswm)
CLFSWM> (produce-menu-doc-html-in-file "my-menu.html")
or
CLFSWM> (produce-all-docs)

clfswm-20111015.git51b0a02/doc/menu.txt000066400000000000000000001003301164636077000171770ustar00rootroot00000000000000Here is the map of the CLFSWM menu: (By default it is bound on second-mode + m) Main F1: < Help menu > d: < Standard menu > c: < Child menu > f: < Frame menu > w: < Window menu > s: < Selection menu > n: < Action by name menu > u: < Action by number menu > y: < Utility menu > o: < Configuration menu > m: < CLFSWM menu > Help-Menu a: Show the first aid kit key binding h: Show all key binding b: Show the main mode binding s: Show the second mode key binding r: Show the circulate mode key binding e: Show the expose window mode key binding c: Help on clfswm corner g: Show all configurable variables d: Show the current time and date p: Show current processes sorted by CPU usage m: Show current processes sorted by memory usage v: Show the current CLFSWM version Standard-Menu a: < TEXTEDITOR > b: < FILEMANAGER > c: < WEBBROWSER > d: < AUDIOVIDEO > e: < AUDIO > f: < VIDEO > g: < DEVELOPMENT > h: < EDUCATION > i: < GAME > j: < GRAPHICS > k: < NETWORK > l: < OFFICE > m: < SETTINGS > n: < SYSTEM > o: < UTILITY > p: < TERMINALEMULATOR > q: < ARCHLINUX > r: < SCREENSAVER > Texteditor a: Emacs Text Editor - Edit text b: gVim - GTK2 enhanced vim text editor c: Kate d: Snippets datafile editor e: KWrite f: Mousepad - Simple text editor g: PDF Editor h: Xfw - A simple text editor for Xfe Filemanager a: Open Folder with Thunar - Open the specified folders in Thunar b: Thunar File Manager - Browse the filesystem with the file manager c: Dolphin d: Krusader e: File Manager - Configure the Thunar file manager f: ROX Filer - ROX Filer g: Worker - File manager for X. h: Xfe - A lightweight file manager for X Window Webbrowser a: Arora - Browse the World Wide Web b: Chromium - Access the Internet c: Conkeror - Conkeror is a Mozilla-based web browser whose design is inspired by GNU Emacs d: Epiphany - Browse the web e: Firefox f: IcedTea Web Start - IcedTea Application Launcher g: Konqueror h: rekonq i: Links j: Midori - Lightweight web browser k: Opera - A fast and secure web browser and Internet suite Audiovideo a: AcidRip DVD Ripper - DVD Ripper b: Ardour - Multitrack hard disk recorder c: Ario - Client application to mpd d: Audacity - Record and edit audio files e: Beep Media Player - Play music f: Brasero - Create and copy CDs and DVDs g: Cinelerra - Video Editor h: dvd::rip - DVD Ripper and Encoder - Backup and compression utility for DVDs i: Freevo - Home theatre j: Camelot - Gmerlin webcam application k: Gmerlin KBD - Configure the Gmerlin keyboard daemon l: Gmerlin player - Multiformat mediaplayer m: Gmerlin recorder - Audio/video recorder n: Gmerlin transcoder - Gmerlin multimedia transcoder o: Gmerlin visualizer - Run visualization plugins p: Gnome Music Player Client - A gnome frontend for the mpd daemon q: Sound Recorder - Record sound clips r: Grip - CD player/ripper s: gtk-recordMyDesktop - Frontend for recordMyDesktop t: Hydrogen Drum Machine - Create drum sequences u: Dragon Player v: JuK w: K3b - Disk writing program x: Kdenlive - Nonlinear video editor for KDE y: KMix z: KsCD 0: Mixxx - A digital DJ interface 1: MPlayer Media Player - Play movies and songs 2: Open Movie Editor - Video Editor 3: OpenShot Video Editor - Create and edit videos and movies 4: QjackCtl - QjackCtl is a JACK Audio Connection Kit Qt GUI Interface 5: qt-recordMyDesktop - Frontend for recordMyDesktop 6: QT V4L2 test Utility - Allow testing Video4Linux devices 7: Rhythmbox - Play and organize your music collection 8: Rhythmbox - Play and organize your music collection 9: SMPlayer - A great MPlayer front-end A: Enqueue in SMPlayer B: Sonata - An elegant GTK+ MPD client C: Audio CD Extractor - Copy music from your CDs D: Movie Player - Play movies and songs E: VLC media player - Read, capture, broadcast your multimedia streams F: XBMC Media Center - Manage and view your media G: Mixer - Audio mixer for the Xfce Desktop Environment H: XMMS - X Multimedia System I: zynaddsubfx - An opensource software synthesizer Audio a: Ardour - Multitrack hard disk recorder b: Ario - Client application to mpd c: Audacity - Record and edit audio files d: Gmerlin plugin configurator - Configure gmerlin plugins e: Sound Recorder - Record sound clips f: Hydrogen Drum Machine - Create drum sequences g: KMix h: Mixxx - A digital DJ interface i: MPlayer Media Player - Play movies and songs j: QjackCtl - QjackCtl is a JACK Audio Connection Kit Qt GUI Interface k: Audio CD Extractor - Copy music from your CDs l: Mixer - Audio mixer for the Xfce Desktop Environment Video a: Ardour - Multitrack hard disk recorder b: dvd::rip - DVD Ripper and Encoder - Backup and compression utility for DVDs c: MPlayer Media Player - Play movies and songs d: OpenShot Video Editor - Create and edit videos and movies e: SMPlayer - A great MPlayer front-end f: Enqueue in SMPlayer g: Movie Player - Play movies and songs h: XBMC Media Center - Manage and view your media Development a: CMake - Cross-platform buildsystem b: Qt Assistant - Shows Qt documentation and examples c: Data Display Debugger - Graphical debugger frontend d: Qt Designer - Design GUIs for Qt applications e: DrRacket - DrRacket is an interactive, integrated, graphical programming environment for the Racket programming languages. f: EAGLE Light Edition g: Eeschema - Design a printed circuit board. h: Emacs Text Editor - Edit text i: Factor - Factor is a general purpose, dynamically typed, stack-based programming language j: Java Monitoring and Management Console k: Java VisualVM l: OpenJDK Monitoring & Management Console - Monitor and manage OpenJDK applications m: Akonadi Console - Akonadi Management and Debugging Console n: Cervisia o: KAppTemplate p: KBugBuster q: KCachegrind - Visualization of Performance Profiling Data r: KDE Source Builder - Builds the KDE Platform and associated software from its source code. A command-line only program. s: KImageMapEditor t: KLinkStatus u: Kompare v: KUIViewer w: Lokalize x: Umbrello y: KiCad - Design a printed circuit board. z: Qt Linguist - Add translations to Qt applications 0: OpenJDK Policy Tool - Manage OpenJDK policy files Education a: Avogadro - Advanced molecular editor b: Circle and Ruler - Geometry program c: DrGeo d: DrRacket - DrRacket is an interactive, integrated, graphical programming environment for the Racket programming languages. e: GeoGebra - Create interactive mathematical constructions and applets. f: geometria g: Blinken - A memory enhancement game h: Cantor i: KAlgebra - Math Expression Solver and Plotter j: KAlgebra Mobile - Pocket Math Expression Solver and Plotter k: Kalzium - KDE Periodic Table of Elements l: Kanagram - KDE Letter Order Game m: KBruch - Practice exercises with fractions n: KGeography - A Geography Learning Program o: KHangMan - KDE Hangman Game p: Kig - Explore Geometric Constructions q: Kiten - Japanese Reference and Study Tool r: KLettres - a KDE program to learn the alphabet s: KmPlot - Function Plotter t: KStars - Desktop Planetarium u: KTouch v: KTurtle w: KWordQuiz - A flashcard and vocabulary learning program x: Marble y: Parley z: Rocs - Graph Theory Tool for Professors and Students. 0: Step - Simulate physics experiments 1: Oregano electrical engineering tool - Schematic capture and simulation of electronic circuits 2: QtOctave - GUI for GNU Octave 3: VYM - View Your Mind 4: wxMaxima - Perform symbolic and numeric calculations using Maxima 5: Xcas Computer Algebra System - The swiss knife for mathematics Game a: 0 A.D. Editor b: 0 A.D. c: AssaultCube d: Astromenace - Space shooter e: Blobby Volley 2 f: Bloboats - A boat racing game reminiscent of Elasto Mania and X-Moto g: BomberClone - Atomic Bomberman clone h: Chromium B.S.U. - Scrolling space shooter i: DreamChess j: DROD - Simple puzzle game. k: eBoard l: Einstein - Einstein puzzle m: Extreme Tux Racer - Open source racing game featuring Tux the Linux Penguin. n: Flobopuyo - A remake of the famous PuyoPuyo o: Foobillard - A 3D billiards game using OpenGL p: Frasse - Frasse and the Peas of Kejick adventure game q: Frogatto - Old-school 2D platformer r: gbrainy - Play games that challenge your logic, verbal, calculation and memory abilities s: GGoban - Play go and review game records t: glChess u: GLTron - Lightcycle game with a nice 3D perspective. v: Hedgewars - Worms style game w: Hex-a-Hop - Hexagonal Tile-based Puzzle Game x: KGoldrunner - A game of action and puzzle-solving y: AMOR z: Blinken - A memory enhancement game 0: Bomber 1: Bovo 2: Granatier 3: Kanagram - KDE Letter Order Game 4: Kapman - Eat pills escaping ghosts 5: KAtomic 6: Naval Battle 7: KBlackBox 8: KBlocks 9: KBounce A: KBreakOut B: KSnake C: KDiamond D: KFourInLine E: KHangMan - KDE Hangman Game F: Kigo G: Killbots H: Kiriki I: KJumpingCube J: Klickety K: Kolor Lines L: KMahjongg M: KMines N: KNetWalk O: Knights P: Kolf Q: Kollision - A simple ball dodging game R: Konquest S: KPatience T: KReversi U: SameGame V: Shisen-Sho W: KsirK X: KsirK Skin Editor Y: KSpaceDuel Z: KSquares |: KSudoku - KSudoku, Sudoku game & more for KDE |: KSnakeDuel |: Potato Guy |: Kubrick |: LSkat |: Palapeli |: KoboDeluxe - An excellent 2D Shootem-up game. |: Maniadrive - An arcade car game on acrobatic tracks, with a quick and nervous gameplay |: mechtower(failsafe) |: mechtower |: Numpty Physics |: OpenArena - A Quake3-based FPS Game |: OpenTTD |: Pacdefence - Tower defence game. |: PainTown - Paintown is an open source fighting game in the same genre as Streets of Rage and Teenage Mutant Ninja Turtles. |: pouetChess - Play a game of chess, either against another player or against the AI |: Racer - Choose your car and race |: Racer - Choose your car and race |: Slime Volley - Unrealistic 2D volleyball simulation |: SolarWolf |: Spring - An open source RTS with similar gameplay to TA |: Stormbaan Coureur |: SuperTux 2 - Play a classic 2D platform game |: Supertuxkart - A kart racing game |: Trackballs - Simple game similar to the classical game Marble Madness |: Battle for Wesnoth - A fantasy turn-based strategy game |: Battle for Wesnoth Map Editor - A map editor for Battle for Wesnoth maps |: Wind and Water: Puzzle Battles - Arcade style puzzle game |: XBoard - An X Window System graphical chessboard |: Xmoto |: XSpaceWarp - Live long and prosper! |: Xut - Button football simulation |: Zelvici - Funny 2D platform game |: Zero Ballistics Graphics a: LibreOffice Draw b: Image Viewer c: Document Viewer - View multi-page documents d: Gcolor2 - Choose colours from palette or screen e: Geeqie - View and manage images f: PostScript Viewer - View PostScript files g: GNU Image Manipulation Program - Create images and edit photographs h: Image Viewer i: GQview - View and manage images j: gThumb - View and organize your images k: gThumb - View and organize your images l: GV m: Inkscape - Create and edit Scalable Vector Graphics images n: digiKam o: Gwenview - A simple image viewer p: KColorChooser q: KolourPaint r: KRuler s: KSnapshot t: Okular u: Okular v: Okular w: Okular x: Okular y: Okular z: Okular 0: Okular 1: Okular 2: Okular 3: Okular 4: Okular 5: Okular 6: Okular 7: Okular 8: Okular 9: showFoto - Manage your photographs like a professional with the power of open source A: MuPDF - PDF file viewer B: Xfig C: xgps - Display GPS information from a gpsd daemon D: xgpsspeed - Display GPS speed from a gpsd daemon E: XSane - Scanning - Acquire images from a scanner Network a: Arora - Browse the World Wide Web b: Epiphany Web Bookmarks - Browse and organize your bookmarks c: Avahi SSH Server Browser - Browse for Zeroconf-enabled SSH Servers d: Avahi VNC Server Browser - Browse for Zeroconf-enabled VNC Servers e: Chromium - Access the Internet f: Conkeror - Conkeror is a Mozilla-based web browser whose design is inspired by GNU Emacs g: Ekiga Softphone - Talk to and see people over the Internet h: Epiphany - Browse the web i: Mail Reader j: Web Browser k: Minefield - Safe Mode l: Minefield m: Firefox n: Gnaughty - Porn downloader o: Gwget Download Manager - Download files from the Internet p: JAP - JAP makes it possible to surf the internet anonymously and unobservably. q: Java Web Start r: IcedTea Web Start - IcedTea Application Launcher s: KMail t: KNode u: KPPP v: Akregator - A Feed Reader for KDE w: Blogilo x: KGet y: KNetAttach z: Konqueror 0: Kopete - Instant Messenger 1: KPPPLogview 2: KRDC 3: Krfb 4: rekonq 5: Links 6: Midori - Lightweight web browser 7: MLDonkey GUI - multi-protocol P2P program 8: MultiGet - Multi thread download tools 9: OpenArena Server - Run an OpenArena server A: Opera - A fast and secure web browser and Internet suite B: SeaMonkey internet suite C: Thunderbird - Mail & News Reader D: Transmission - Download and share files over BitTorrent E: Tucan Manager - Download and upload manager for hosting sites. F: unison - File synchronisation tool for X11 G: LibreOffice Writer/Web H: Wicd - Manage Wired/Wireless Networks I: Zenmap (as root) J: Zenmap Office a: AbiWord b: LibreOffice Base c: LibreOffice Calc d: ePDFViewer - Lightweight PDF document viewer e: Evolution - Manage your email, contacts and schedule f: FreeMind g: Orage Globaltime - Show clocks from different countries h: Gnumeric - Calculation, Analysis, and Visualization of Information i: GV j: LibreOffice Impress k: Kontact l: KAddressBook m: KOrganizer - Calendar and Scheduling Program n: KTimeTracker o: KWord - Write text documents p: Lokalize q: Okular r: LibreOffice 3.3 Math s: LibreOffice 3.3 Printer Administration t: LibreOffice 3.3 u: LibreOffice 3.3 Writer v: Lyx - Latex WYSIWYM Editor w: LibreOffice Extension Manager x: OOo4Kids 1.2 Calc y: OOo4Kids 1.2 Draw z: OOo4Kids 1.2 Impress 0: OOo4Kids 1.2 Math 1: OOo4Kids 1.2 2: OOo4Kids 1.2 Printer Administration 3: OOo4Kids 1.2 Writer 4: LibreOffice Quickstarter 5: LibreOffice 6: Orage Calendar - Desktop calendar 7: XMind - Launch XMind 3.0 8: Xpdf - Views Adobe PDF (acrobat) files 9: Zathura - A minimalistic PDF viewer Settings a: Email Settings - Configure email accounts b: Preferred Applications c: Keyboard Indicator plugins - Enable/disable installed plugins d: Privilege granting - Configure behavior of the privilege-granting tool e: Multimedia Systems Selector - Configure defaults for GStreamer applications f: Touchpad - Set your touchpad preferences g: Java Control Panel h: Java Policy Settings i: Menu Updating Tool j: Change Password k: Menu Editor l: System Settings m: Preferred Applications n: Customize Look and Feel - Customizes look and feel of your desktop and applications o: Monitor Settings - Change screen resolution and configure external monitors p: Opera Widget Manager q: Panel r: Qt Config - Configure Qt behavior, styles, fonts s: Startup Applications - Choose what applications to start when you log in t: File Manager - Configure the Thunar file manager u: Panel tint2 - Customize the panel settings v: Startup Disk Creator - Create a startup disk using a CD or disc image w: Desktop - Set desktop background and menu and icon behaviour x: Display - Configure screen settings and layout y: Keyboard - Edit keyboard settings and application shortcuts z: Mouse - Configure pointer device behavior and appearance 0: Session and Startup - Customize desktop startup and splash screen 1: Settings Manager - Graphical Settings Manager for Xfce 4 2: Appearance - Customize the look of your desktop 3: Window Manager - Configure window behavior and shortcuts 4: Window Manager Tweaks - Fine-tune window behaviour and effects 5: Workspaces - Set number and names of workspaces 6: Orage preferences - Settings for the Xfce 4 Calendar Application (Orage) 7: Accessibility - Improve keyboard and mouse accessibility 8: Settings Editor - Graphical settings editor for Xfconf 9: Xfce 4 Printing System Settings - Allow you to select the printing system backend that xfprint will use A: Screensaver - Change screensaver properties System a: Terminal - Use the command line b: Bulk Rename - Rename Multiple Files c: Open Folder with Thunar - Open the specified folders in Thunar d: Thunar File Manager - Browse the filesystem with the file manager e: Avahi Zeroconf Browser - Browse for Zeroconf services available on your network f: CD/DVD Creator - Create CDs and DVDs g: Cairo-Dock (no OpenGL) - A light and eye-candy dock and desklets for your desktop. h: GLX-Dock (Cairo-Dock with OpenGL) - Cairo-Dock with OpenGL (hardware acceleration) i: Manage Printing j: dconf Editor - Directly edit your entire configuration database k: Configuration Editor - Directly edit your entire configuration database l: Keyboard Layout - Preview keyboard layouts m: Panel n: System Monitor o: GParted - Create, reorganize, and delete partitions p: Htop - Show System Processes q: Dolphin r: K3b - Disk writing program s: KDiskFree t: Konqueror u: Konqueror v: Konqueror w: Konqueror x: KInfoCenter y: File Manager - Super User Mode z: Konsole 0: KRandRTray - A panel applet for resizing and reorientating X screens. 1: Krfb 2: Krusader - root-mode 3: System Monitor 4: KSystemLog 5: KUser 6: KWalletManager 7: KwikDisk 8: Nepomuk Backup 9: Yakuake A: Task Manager - Manage running processes B: rxvt-unicode - An Unicode capable rxvt clone C: UNetbootin - Tool for creating Live USB drives D: Startup Disk Creator - Create a startup disk using a CD or disc image E: Startup Disk Creator - Create a startup disk using a CD or disc image F: Oracle VM VirtualBox G: Wireshark - Network traffic analyzer H: Log Out I: Xfe - A lightweight file manager for X Window J: XNC - Graphical File manager, X Northern Captain Utility a: SAGE - SAGE NOTEBOOK b: Terminal - Use the command line c: Bulk Rename - Rename Multiple Files d: Open Folder with Thunar - Open the specified folders in Thunar e: Thunar File Manager - Browse the filesystem with the file manager f: Brasero - Create and copy CDs and DVDs g: Circle and Ruler - Geometry program h: dosbox Emulator - An emulator to run old DOS games i: File Manager - Configure the Thunar file manager j: Terminal Emulator k: gEDA Attribute Editor - Manipulate component attributes with gattrib l: gEDA Schematic Editor - Create and edit electrical schematics and symbols with gschem m: Root Terminal - Opens a terminal as the root user, using gksu to ask for the password n: Orage Globaltime - Show clocks from different countries o: Terminal - Use the command line p: Image Viewer q: GSpiceUI - A GUI to various freely available Spice electronic circuit simulators r: Character Map - Insert special characters into documents s: gVim - GTK2 enhanced vim text editor t: HP Device Manager - View device status, ink levels and perform maintenance. u: K3DSurf - Visualize and manipulate Mathematical models in three, four, five, and six dimensions v: Help - Get help with GNOME w: Home x: KCharSelect y: KFloppy z: KJots 0: Akonaditray 1: Ark 2: KDE Groupware Wizard 3: KAlarm 4: Kate 5: KCalc 6: KFileReplace 7: Find Files/Folders 8: KFontView 9: KGpg - A GnuPG frontend A: Kleopatra B: Kleopatra C: Klipper D: KMag E: KMouseTool - Clicks the mouse for you, reducing the effects of RSI F: KMouth G: KNotes H: KonsoleKalendar I: Krusader J: KTeaTime K: Snippets datafile editor L: KTimer M: KTimeTracker N: KWrite O: Okteta P: SuperKaramba - An engine for cool desktop eyecandy. Q: Sweeper R: LXTerminal - Use the command line S: XMaxima - A sophisticated computer algebra system T: Mousepad - Simple text editor U: Files - Access and organize files V: Disk Utility - Manage Drives and Media W: File Manager - Configure the Thunar file manager X: PDF Editor Y: PlayOnLinux - PlayOnLinux Z: Scilab - A scientific software package for numerical computations |: Tilda |: Worker - File manager for X. |: About Xfce |: Application Finder - Find and launch applications installed on your system |: Help - Get help with GNOME |: Xfi - A simple image viewer for Xfe |: Xfp - A simple package manager for Xfe |: Xfce 4 Print Manager - Show the printer list and allow you to manage their jobs |: Xfce 4 Print Dialog - Print a file and allow you to set up its layout |: Run Program... |: Xfv - A simple text viewer for Xfe |: Xfw - A simple text editor for Xfe |: XNC - Graphical File manager, X Northern Captain |: Help - Get help with GNOME |: Zhu3D - With Zhu3D, you can view, animate, and solve up to three functions in 3D-space in an interactive manner |: KDE Resources - Configure KDE Resources Terminalemulator a: Terminal - Use the command line b: Root Terminal - Opens a terminal as the root user, using gksu to ask for the password c: Terminal - Use the command line d: Konsole e: Yakuake f: LXTerminal - Use the command line g: rxvt-unicode - An Unicode capable rxvt clone h: Tilda Archlinux a: AUR - Archlinux AUR b: Bugs - Archlinux Bugtracker c: Developers - Archlinux development team d: Documentation - Archlinux Documentation e: Donate - Archlinux Donations f: Forum - Archlinux Forum g: Homepage - Archlinux homepage h: SVN - Archlinux SVN i: Schwag - Archlinux goodie shopping j: Wiki - Archlinux Wiki Screensaver Child-Menu r: Rename the current child e: Ensure that all children names are unique n: Ensure that all children numbers are unique Delete: Delete the current child and its children in all frames X: Remove the current child from its parent frame h: Hide the current child u: Unhide a child in the current frame f: Unhide a child from all frames in the current frame a: Unhide all current frame hidden children Page_Up: Lower the child in the current frame Page_Down: Raise the child in the current frame Frame-Menu a: < Adding frame menu > l: < Frame layout menu > n: < Frame new window hook menu > m: < Frame movement menu > f: < Frame focus policy menu > w: < Managed window type menu > u: < Unmanaged window behaviour > s: < Frame miscallenous menu > x: Maximize/Unmaximize the current frame in its parent frame Frame-Adding-Menu a: Add a default frame in the current frame p: Add a placed frame in the current frame Frame-Layout-Menu a: < Frame fast layout menu > b: No layout: Maximize windows in their frame - Leave frames to their original size c: No layout: Maximize windows in their frame - Leave frames to their actual size d: Maximize layout: Maximize windows and frames in their parent frame e: < Frame tile layout menu > f: < Tile in one direction layout menu > g: < Tile with some space on one side menu > h: < Main window layout menu > i: < The GIMP layout menu > Frame-Fast-Layout-Menu s: Switch between two layouts p: Push the current layout in the fast layout list Frame-Tile-Layout-Menu v: Tile child in its frame (vertical) h: Tile child in its frame (horizontal) c: One column layout l: One line layout s: Tile Space: tile child in its frame leaving spaces between them Frame-Tile-Dir-Layout-Menu l: Tile Left: main child on left and others on right r: Tile Right: main child on right and others on left t: Tile Top: main child on top and others on bottom b: Tile Bottom: main child on bottom and others on top Frame-Tile-Space-Layout-Menu a: Tile Left Space: main child on left and others on right. Leave some space on the left. Frame-Main-Window-Layout-Menu r: Main window right: Main windows on the right. Others on the left. l: Main window left: Main windows on the left. Others on the right. t: Main window top: Main windows on the top. Others on the bottom. b: Main window bottom: Main windows on the bottom. Others on the top. -=- Actions on main windows list -=- a: Add the current window in the main window list v: Remove the current window from the main window list c: Clear the main window list Frame-Gimp-Layout-Menu g: The GIMP Layout p: Restore the previous layout h: Help on the GIMP layout -=- Main window layout -=- r: Main window right: Main windows on the right. Others on the left. l: Main window left: Main windows on the left. Others on the right. t: Main window top: Main windows on the top. Others on the bottom. b: Main window bottom: Main windows on the bottom. Others on the top. -=- Actions on main windows list -=- a: Add the current window in the main window list v: Remove the current window from the main window list c: Clear the main window list Frame-Nw-Hook-Menu a: Open the next window in the current frame b: Open the next window in the current root c: Open the next window in a new frame in the current root d: Open the next window in a new frame in the root frame e: Open the next window in a new frame in the parent frame f: Open the next window in the current frame and leave the focus on the current child g: Open the next window in a named frame h: Open the next window in a numbered frame i: Open the window in this frame if it match nw-absorb-test Frame-Movement-Menu p: < Frame pack menu > f: < Frame fill menu > r: < Frame resize menu > c: Center the current frame Right: Select the next brother frame Left: Select the previous brother frame Up: Select the next level Down: Select the previous levelframe Tab: Select the next child Frame-Pack-Menu Up: Pack the current frame up Down: Pack the current frame down Left: Pack the current frame left Right: Pack the current frame right Frame-Fill-Menu Up: Fill the current frame up Down: Fill the current frame down Left: Fill the current frame left Right: Fill the current frame right a: Fill the current frame in all directions v: Fill the current frame vertically h: Fill the current frame horizontally Frame-Resize-Menu Up: Resize the current frame up to its half height Down: Resize the current frame down to its half height Left: Resize the current frame left to its half width Right: Resize the current frame right to its half width a: Resize down the current frame m: Resize down the current frame to its minimal size Frame-Focus-Policy -=- For the current frame -=- a: Set a click focus policy for the current frame. b: Set a sloppy focus policy for the current frame. c: Set a (strict) sloppy focus policy only for windows in the current frame. d: Set a sloppy select policy for the current frame. -=- For all frames -=- e: Set a click focus policy for all frames. f: Set a sloppy focus policy for all frames. g: Set a (strict) sloppy focus policy for all frames. h: Set a sloppy select policy for all frames. Frame-Managed-Window-Menu m: Change window types to be managed by a frame a: Manage all window type n: Manage only normal window type u: Do not manage any window type Frame-Unmanaged-Window-Menu s: Show unmanaged windows when frame is not selected h: Hide unmanaged windows when frame is not selected d: Set default behaviour to hide or not unmanaged windows when frame is not selected w: Show unmanaged windows by default. This is overriden by functions above i: Hide unmanaged windows by default. This is overriden by functions above Frame-Miscellaneous-Menu s: Show all frames info windows a: Hide all frames info windows h: Hide the current frame window w: Show the current frame window u: Renumber the current frame x: Create a new frame for each window in frame i: Absorb all frames subchildren in frame (explode frame opposite) Window-Menu i: Display information on the current window f: Force the current window to move in the frame (Useful only for unmanaged windows) c: Force the current window to move in the center of the frame (Useful only for unmanaged windows) m: Force to manage the current window by its parent frame u: Force to not manage the current window by its parent frame a: Adapt the current frame to the current window minimal size hints w: Adapt the current frame to the current window minimal width hint h: Adapt the current frame to the current window minimal height hint Selection-Menu x: Cut the current child to the selection c: Copy the current child to the selection v: Paste the selection in the current frame p: Paste the selection in the current frame - Do not clear the selection after paste Delete: Remove the current child from its parent frame z: Clear the current selection Action-By-Name-Menu f: Focus a frame by name o: Open a new frame in a named frame d: Delete a frame by name m: Move current child in a named frame c: Copy current child in a named frame Action-By-Number-Menu f: Focus a frame by number o: Open a new frame in a numbered frame d: Delete a frame by number m: Move current child in a numbered frame c: Copy current child in a numbered frame Utility-Menu i: Identify a key colon: Eval a lisp form from the query input exclam: Run a program from the query input o: < Other window manager menu > Other-Window-Manager-Menu x: Run xterm t: Run twm i: Run icewm g: Run Gnome k: Run KDE c: Run XFCE l: Run LXDE p: Prompt for an other window manager Configuration-Menu a: < Gimp Layout Group > b: < Notify Window Group > c: < Menu Group > d: < Expose Mode Group > e: < Circulate Mode Group > f: < Info Mode Group > g: < Query String Group > h: < Identify Key Group > i: < Second Mode Group > j: < Frame Colors Group > k: < Corner Group > l: < Placement Group > m: < Hook Group > n: < Main Mode Group > o: < Miscellaneous Group > F2: Save all configuration variables in clfswmrc F3: Reset all configuration variables to their default values Conf-Gimp-Layout a: Configure GIMP-LAYOUT-NOTIFY-WINDOW-DELAY Conf-Notify-Window a: Configure NOTIFY-WINDOW-DELAY b: Configure NOTIFY-WINDOW-BORDER c: Configure NOTIFY-WINDOW-FOREGROUND d: Configure NOTIFY-WINDOW-BACKGROUND e: Configure NOTIFY-WINDOW-FONT-STRING Conf-Menu a: Configure XDG-SECTION-LIST b: Configure MENU-COLOR-MENU-KEY c: Configure MENU-COLOR-KEY d: Configure MENU-COLOR-COMMENT e: Configure MENU-COLOR-SUBMENU Conf-Expose-Mode a: Configure EXPOSE-SHOW-WINDOW-TITLE b: Configure EXPOSE-VALID-ON-KEY c: Configure EXPOSE-BORDER d: Configure EXPOSE-FOREGROUND e: Configure EXPOSE-BACKGROUND f: Configure EXPOSE-FONT-STRING Conf-Circulate-Mode a: Configure CIRCULATE-TEXT-LIMITE b: Configure CIRCULATE-HEIGHT c: Configure CIRCULATE-WIDTH d: Configure CIRCULATE-BORDER e: Configure CIRCULATE-FOREGROUND f: Configure CIRCULATE-BACKGROUND g: Configure CIRCULATE-FONT-STRING Conf-Info-Mode a: Configure INFO-COLOR-SECOND b: Configure INFO-COLOR-FIRST c: Configure INFO-COLOR-UNDERLINE d: Configure INFO-COLOR-TITLE e: Configure INFO-CLICK-TO-SELECT f: Configure INFO-FONT-STRING g: Configure INFO-SELECTED-BACKGROUND h: Configure INFO-LINE-CURSOR i: Configure INFO-BORDER j: Configure INFO-FOREGROUND k: Configure INFO-BACKGROUND Conf-Query-String a: Configure QUERY-BORDER b: Configure QUERY-PARENT-ERROR-COLOR c: Configure QUERY-PARENT-COLOR d: Configure QUERY-CURSOR-COLOR e: Configure QUERY-FOREGROUND f: Configure QUERY-MESSAGE-COLOR g: Configure QUERY-BACKGROUND h: Configure QUERY-FONT-STRING Conf-Identify-Key a: Configure IDENTIFY-BORDER b: Configure IDENTIFY-FOREGROUND c: Configure IDENTIFY-BACKGROUND d: Configure IDENTIFY-FONT-STRING Conf-Second-Mode a: Configure SM-HEIGHT b: Configure SM-WIDTH c: Configure SM-FONT-STRING d: Configure SM-FOREGROUND-COLOR e: Configure SM-BACKGROUND-COLOR f: Configure SM-BORDER-COLOR Conf-Frame-Colors a: Configure FRAME-FOREGROUND-HIDDEN b: Configure FRAME-FOREGROUND-ROOT c: Configure FRAME-FOREGROUND d: Configure FRAME-BACKGROUND Conf-Corner a: Configure CLFSWM-TERMINAL-CMD b: Configure CLFSWM-TERMINAL-NAME c: Configure VIRTUAL-KEYBOARD-CMD d: Configure CORNER-SECOND-MODE-RIGHT-BUTTON e: Configure CORNER-SECOND-MODE-MIDDLE-BUTTON f: Configure CORNER-SECOND-MODE-LEFT-BUTTON g: Configure CORNER-MAIN-MODE-RIGHT-BUTTON h: Configure CORNER-MAIN-MODE-MIDDLE-BUTTON i: Configure CORNER-MAIN-MODE-LEFT-BUTTON j: Configure CORNER-SIZE Conf-Placement a: Configure ASK-CLOSE/KILL-PLACEMENT b: Configure NOTIFY-WINDOW-PLACEMENT c: Configure EXPOSE-MODE-PLACEMENT d: Configure CIRCULATE-MODE-PLACEMENT e: Configure QUERY-MODE-PLACEMENT f: Configure INFO-MODE-PLACEMENT g: Configure SECOND-MODE-PLACEMENT h: Configure BANISH-POINTER-PLACEMENT Conf-Hook a: Configure DEFAULT-NW-HOOK b: Configure CLOSE-HOOK c: Configure INIT-HOOK d: Configure MAIN-ENTRANCE-HOOK e: Configure LOOP-HOOK f: Configure BINDING-HOOK Conf-Main-Mode a: Configure COLOR-MAYBE-SELECTED b: Configure COLOR-UNSELECTED c: Configure COLOR-SELECTED d: Configure COLOR-MOVE-WINDOW Conf-Miscellaneous a: Configure DEFAULT-WINDOW-HEIGHT b: Configure DEFAULT-WINDOW-WIDTH c: Configure CREATE-FRAME-ON-ROOT d: Configure SPATIAL-MOVE-DELAY-AFTER e: Configure SPATIAL-MOVE-DELAY-BEFORE f: Configure SNAP-SIZE g: Configure HIDE-UNMANAGED-WINDOW h: Configure NEVER-MANAGED-WINDOW-LIST i: Configure DEFAULT-MODIFIERS j: Configure DEFAULT-FOCUS-POLICY k: Configure DEFAULT-MANAGED-TYPE l: Configure DEFAULT-FRAME-DATA m: Configure DEFAULT-FONT-STRING n: Configure LOOP-TIMEOUT o: Configure BORDER-SIZE p: Configure SHOW-ROOT-FRAME-P q: Configure HAVE-TO-COMPRESS-NOTIFY Clfswm-Menu r: Reset clfswm l: Reload clfswm x: Exit clfswm This documentation was produced with the CLFSWM auto-doc functions. To reproduce it, use the produce-menu-doc-in-file or the produce-all-docs function from the Lisp REPL. Something like this: LISP> (in-package :clfswm) CLFSWM> (produce-menu-doc-in-file "my-menu.txt") or CLFSWM> (produce-all-docs) clfswm-20111015.git51b0a02/doc/variables.html000066400000000000000000000764361164636077000203530ustar00rootroot00000000000000 CLFSWM - Configuration variables

CLFSWM - Configuration variables

Here are the variables you can configure in CLFSWM with the configuration file or the configuration menu:

Configuration variables groups:

<= Circulate Mode Group =>

   *circulate-font-string* = "fixed"
        Circulate string window font string
   *circulate-background* = "black"
        Circulate string window background color
   *circulate-foreground* = "green"
        Circulate string window foreground color
   *circulate-border* = "red"
        Circulate string window border color
   *circulate-width* = 400
        Circulate mode window width
   *circulate-height* = 15
        Circulate mode window height
   *circulate-text-limite* = 30
        Maximum text limite in the circulate window

<= Corner Group =>

   *corner-size* = 3
        The size of the corner square
   *corner-main-mode-left-button* = ((:TOP-LEFT OPEN-MENU)
        (:TOP-RIGHT PRESENT-VIRTUAL-KEYBOARD)
        (:BOTTOM-RIGHT EXPOSE-WINDOWS-MODE)
        (:BOTTOM-LEFT NIL))
        Actions on corners in the main mode with the left mouse button
   *corner-main-mode-middle-button* = ((:TOP-LEFT HELP-ON-CLFSWM)
        (:TOP-RIGHT
        ASK-CLOSE/KILL-CURRENT-WINDOW)
        (:BOTTOM-RIGHT NIL) (:BOTTOM-LEFT NIL))
        Actions on corners in the main mode with the middle mouse button
   *corner-main-mode-right-button* = ((:TOP-LEFT PRESENT-CLFSWM-TERMINAL)
        (:TOP-RIGHT ASK-CLOSE/KILL-CURRENT-WINDOW)
        (:BOTTOM-RIGHT EXPOSE-ALL-WINDOWS-MODE)
        (:BOTTOM-LEFT NIL))
        Actions on corners in the main mode with the right mouse button
   *corner-second-mode-left-button* = ((:TOP-LEFT NIL) (:TOP-RIGHT NIL)
        (:BOTTOM-RIGHT EXPOSE-WINDOWS-MODE)
        (:BOTTOM-LEFT NIL))
        Actions on corners in the second mode with the left mouse button
   *corner-second-mode-middle-button* = ((:TOP-LEFT HELP-ON-CLFSWM)
        (:TOP-RIGHT NIL) (:BOTTOM-RIGHT NIL)
        (:BOTTOM-LEFT NIL))
        Actions on corners in the second mode with the middle mouse button
   *corner-second-mode-right-button* = ((:TOP-LEFT NIL) (:TOP-RIGHT NIL)
        (:BOTTOM-RIGHT EXPOSE-ALL-WINDOWS-MODE)
        (:BOTTOM-LEFT NIL))
        Actions on corners in the second mode with the right mouse button
   *virtual-keyboard-cmd* = "xvkbd"
        The command to display the virtual keybaord
        Here is an ~/.Xresources example for xvkbd:
        xvkbd.windowGeometry: 300x100-0-0
        xvkbd*Font: 6x12
        xvkbd.modalKeytop: true
        xvkbd.customization: -french
        xvkbd.keypad: false
        And make it always on top
   *clfswm-terminal-name* = "clfswm-terminal"
        The clfswm terminal name
   *clfswm-terminal-cmd* = "xterm -T clfswm-terminal"
        The clfswm terminal command.
        This command must set the window title to *clfswm-terminal-name*

<= Expose Mode Group =>

   *expose-font-string* = "fixed"
        Expose string window font string
   *expose-background* = "black"
        Expose string window background color
   *expose-foreground* = "green"
        Expose string window foreground color
   *expose-border* = "red"
        Expose string window border color
   *expose-valid-on-key* = T
        Valid expose mode when an accel key is pressed
   *expose-show-window-title* = T
        Show the window title on accel window

<= Frame Colors Group =>

   *frame-background* = "Black"
        Frame background
   *frame-foreground* = "Green"
        Frame foreground
   *frame-foreground-root* = "Red"
        Frame foreground when the frame is the root frame
   *frame-foreground-hidden* = "Darkgreen"
        Frame foreground for hidden windows

<= Gimp Layout Group =>

   *gimp-layout-notify-window-delay* = 30
        Time to display the GIMP layout notify window help

<= Hook Group =>

   *binding-hook* = (SET-DEFAULT-CIRCULATE-KEYS SET-DEFAULT-EXPOSE-KEYS
        INIT-*INFO-KEYS*
        INIT-*INFO-MOUSE*
        SET-DEFAULT-INFO-KEYS
        SET-DEFAULT-INFO-MOUSE
        INIT-*QUERY-KEYS*
        SET-DEFAULT-QUERY-KEYS
        INIT-*MAIN-KEYS*
        INIT-*MAIN-MOUSE*
        SET-DEFAULT-MAIN-KEYS
        SET-DEFAULT-MAIN-MOUSE
        INIT-*SECOND-KEYS*
        INIT-*SECOND-MOUSE*
        SET-DEFAULT-SECOND-KEYS
        SET-DEFAULT-SECOND-MOUSE)
        Hook executed when keys/buttons are bounds
   *loop-hook* = NIL
        Hook executed on each event loop
   *main-entrance-hook* = NIL
        Hook executed on the main function entrance after
        loading configuration file and before opening the display.
   *init-hook* = (DEFAULT-INIT-HOOK DISPLAY-HELLO-WINDOW)
        Init hook. This hook is run just after the first root frame is created
   *close-hook* = (CLOSE-NOTIFY-WINDOW CLOSE-CLFSWM-TERMINAL
        CLOSE-VIRTUAL-KEYBOARD)
        Close hook. This hook is run just before closing the display
   *default-nw-hook* = DEFAULT-FRAME-NW-HOOK
        Default action to do on newly created windows

<= Identify Key Group =>

   *identify-font-string* = "fixed"
        Identify window font string
   *identify-background* = "black"
        Identify window background color
   *identify-foreground* = "green"
        Identify window foreground color
   *identify-border* = "red"
        Identify window border color

<= Info Mode Group =>

   *info-background* = "black"
        Info window background color
   *info-foreground* = "green"
        Info window foreground color
   *info-border* = "red"
        Info window border color
   *info-line-cursor* = "white"
        Info window line cursor color color
   *info-selected-background* = "blue"
        Info selected item background color
   *info-font-string* = "fixed"
        Info window font string
   *info-click-to-select* = T
        If true, click on info window select item. Otherwise, click to drag the menu
   *info-color-title* = "Magenta"
        Colored info title color
   *info-color-underline* = "Yellow"
        Colored info underline color
   *info-color-first* = "Cyan"
        Colored info first color
   *info-color-second* = "lightblue"
        Colored info second color

<= Main Mode Group =>

   *color-move-window* = "DeepPink"
        Color when moving or resizing a windows
   *color-selected* = "Red"
        Color of selected window
   *color-unselected* = "Blue"
        Color of unselected color
   *color-maybe-selected* = "Yellow"
        Color of maybe selected windows

<= Menu Group =>

   *menu-color-submenu* = "Cyan"
        Submenu color in menu
   *menu-color-comment* = "Yellow"
        Comment color in menu
   *menu-color-key* = "Magenta"
        Key color in menu
   *menu-color-menu-key* = #
        Menu key color in menu
   *xdg-section-list* = (TEXTEDITOR FILEMANAGER WEBBROWSER AUDIOVIDEO AUDIO
        VIDEO DEVELOPMENT EDUCATION GAME GRAPHICS NETWORK
        OFFICE SETTINGS SYSTEM UTILITY TERMINALEMULATOR
        ARCHLINUX SCREENSAVER)
        Standard menu sections

<= Miscellaneous Group =>

   *have-to-compress-notify* = T
        Compress event notify?
        This variable may be useful to speed up some slow version of CLX.
        It is particulary useful with CLISP/MIT-CLX.
   *show-root-frame-p* = NIL
        Show the root frame information or not
   *border-size* = 1
        Windows and frames border size
   *loop-timeout* = 0.1
        Maximum time (in seconds) to wait before calling *loop-hook*
   *default-font-string* = "fixed"
        The default font used in clfswm
   *default-frame-data* = ((:TILE-SIZE 0.8) (:TILE-SPACE-SIZE 0.1)
        (:FAST-LAYOUT (TILE-LEFT-LAYOUT TILE-LAYOUT))
        (:MAIN-LAYOUT-WINDOWS NIL))
        Default slots set in frame date
   *default-managed-type* = (:NORMAL)
        Default managed window types
   *default-focus-policy* = :CLICK
        Default mouse focus policy. One of :click, :sloppy, :sloppy-strict or :sloppy-select.
   *default-modifiers* = NIL
        Default modifiers list to append to explicit modifiers
        Example: :mod-2 for num_lock, :lock for Caps_lock...
   *never-managed-window-list* = ((EQUAL-WM-CLASS-ROX-PINBOARD NIL)
        (EQUAL-WM-CLASS-XVKBD RAISE-WINDOW)
        (EQUAL-CLFSWM-TERMINAL RAISE-AND-FOCUS-WINDOW))
        CLFSWM will never manage windows of this type.
        A list of (list match-function handle-function)
   *hide-unmanaged-window* = T
        Hide or not unmanaged windows when a child is deselected.
   *snap-size* = 20
        Snap size (in pixels) when move or resize frame is constrained
   *spatial-move-delay-before* = 0.2
        Delay to display the current child before doing a spatial move
   *spatial-move-delay-after* = 0.5
        Delay to display the new child after doing a spatial move
   *create-frame-on-root* = NIL
        Create frame on root.
        Set this variable to true if you want to allow to create a new frame
        on the root window in the main mode with the mouse
   *default-window-width* = 400
        Default window width
   *default-window-height* = 300
        Default window height

<= Notify Window Group =>

   *notify-window-font-string* = "fixed"
        Notify window font string
   *notify-window-background* = "black"
        Notify Window background color
   *notify-window-foreground* = "green"
        Notify Window foreground color
   *notify-window-border* = "red"
        Notify Window border color
   *notify-window-delay* = 10
        Notify Window display delay

<= Placement Group =>

   *banish-pointer-placement* = BOTTOM-RIGHT-PLACEMENT
        Pointer banishment placement
   *second-mode-placement* = TOP-MIDDLE-PLACEMENT
        Second mode window placement
   *info-mode-placement* = TOP-LEFT-PLACEMENT
        Info mode window placement
   *query-mode-placement* = TOP-LEFT-PLACEMENT
        Query mode window placement
   *circulate-mode-placement* = BOTTOM-MIDDLE-PLACEMENT
        Circulate mode window placement
   *expose-mode-placement* = TOP-LEFT-CHILD-PLACEMENT
        Expose mode window placement (Selection keys position)
   *notify-window-placement* = BOTTOM-RIGHT-PLACEMENT
        Notify window placement
   *ask-close/kill-placement* = TOP-RIGHT-PLACEMENT
        Ask close/kill window placement

<= Query String Group =>

   *query-font-string* = "fixed"
        Query string window font string
   *query-background* = "black"
        Query string window background color
   *query-message-color* = "yellow"
        Query string window message color
   *query-foreground* = "green"
        Query string window foreground color
   *query-cursor-color* = "white"
        Query string window foreground cursor color
   *query-parent-color* = "blue"
        Query string window parenthesis color
   *query-parent-error-color* = "red"
        Query string window parenthesis color when no match
   *query-border* = "red"
        Query string window border color

<= Second Mode Group =>

   *sm-border-color* = "Green"
        Second mode window border color
   *sm-background-color* = "Black"
        Second mode window background color
   *sm-foreground-color* = "Red"
        Second mode window foreground color
   *sm-font-string* = "fixed"
        Second mode window font string
   *sm-width* = 300
        Second mode window width
   *sm-height* = 25
        Second mode window height

This documentation was produced with the CLFSWM auto-doc functions. To reproduce it, use the produce-conf-var-doc-html-in-file or the produce-all-docs function from the Lisp REPL.

Something like this:
LISP> (in-package :clfswm)
CLFSWM> (produce-conf-var-doc-html-in-file "my-variables.html")
or
CLFSWM> (produce-all-docs)

clfswm-20111015.git51b0a02/doc/variables.txt000066400000000000000000000275741164636077000202250ustar00rootroot00000000000000 * CLFSWM Configuration variables * ------------------------------ <= Circulate Mode Group => *CIRCULATE-FONT-STRING* = "fixed" Circulate string window font string *CIRCULATE-BACKGROUND* = "black" Circulate string window background color *CIRCULATE-FOREGROUND* = "green" Circulate string window foreground color *CIRCULATE-BORDER* = "red" Circulate string window border color *CIRCULATE-WIDTH* = 400 Circulate mode window width *CIRCULATE-HEIGHT* = 15 Circulate mode window height *CIRCULATE-TEXT-LIMITE* = 30 Maximum text limite in the circulate window <= Corner Group => *CORNER-SIZE* = 3 The size of the corner square *CORNER-MAIN-MODE-LEFT-BUTTON* = ((:TOP-LEFT OPEN-MENU) (:TOP-RIGHT PRESENT-VIRTUAL-KEYBOARD) (:BOTTOM-RIGHT EXPOSE-WINDOWS-MODE) (:BOTTOM-LEFT NIL)) Actions on corners in the main mode with the left mouse button *CORNER-MAIN-MODE-MIDDLE-BUTTON* = ((:TOP-LEFT HELP-ON-CLFSWM) (:TOP-RIGHT ASK-CLOSE/KILL-CURRENT-WINDOW) (:BOTTOM-RIGHT NIL) (:BOTTOM-LEFT NIL)) Actions on corners in the main mode with the middle mouse button *CORNER-MAIN-MODE-RIGHT-BUTTON* = ((:TOP-LEFT PRESENT-CLFSWM-TERMINAL) (:TOP-RIGHT ASK-CLOSE/KILL-CURRENT-WINDOW) (:BOTTOM-RIGHT EXPOSE-ALL-WINDOWS-MODE) (:BOTTOM-LEFT NIL)) Actions on corners in the main mode with the right mouse button *CORNER-SECOND-MODE-LEFT-BUTTON* = ((:TOP-LEFT NIL) (:TOP-RIGHT NIL) (:BOTTOM-RIGHT EXPOSE-WINDOWS-MODE) (:BOTTOM-LEFT NIL)) Actions on corners in the second mode with the left mouse button *CORNER-SECOND-MODE-MIDDLE-BUTTON* = ((:TOP-LEFT HELP-ON-CLFSWM) (:TOP-RIGHT NIL) (:BOTTOM-RIGHT NIL) (:BOTTOM-LEFT NIL)) Actions on corners in the second mode with the middle mouse button *CORNER-SECOND-MODE-RIGHT-BUTTON* = ((:TOP-LEFT NIL) (:TOP-RIGHT NIL) (:BOTTOM-RIGHT EXPOSE-ALL-WINDOWS-MODE) (:BOTTOM-LEFT NIL)) Actions on corners in the second mode with the right mouse button *VIRTUAL-KEYBOARD-CMD* = "xvkbd" The command to display the virtual keybaord Here is an ~/.Xresources example for xvkbd: xvkbd.windowGeometry: 300x100-0-0 xvkbd*Font: 6x12 xvkbd.modalKeytop: true xvkbd.customization: -french xvkbd.keypad: false And make it always on top *CLFSWM-TERMINAL-NAME* = "clfswm-terminal" The clfswm terminal name *CLFSWM-TERMINAL-CMD* = "xterm -T clfswm-terminal" The clfswm terminal command. This command must set the window title to *clfswm-terminal-name* <= Expose Mode Group => *EXPOSE-FONT-STRING* = "fixed" Expose string window font string *EXPOSE-BACKGROUND* = "black" Expose string window background color *EXPOSE-FOREGROUND* = "green" Expose string window foreground color *EXPOSE-BORDER* = "red" Expose string window border color *EXPOSE-VALID-ON-KEY* = T Valid expose mode when an accel key is pressed *EXPOSE-SHOW-WINDOW-TITLE* = T Show the window title on accel window <= Frame Colors Group => *FRAME-BACKGROUND* = "Black" Frame background *FRAME-FOREGROUND* = "Green" Frame foreground *FRAME-FOREGROUND-ROOT* = "Red" Frame foreground when the frame is the root frame *FRAME-FOREGROUND-HIDDEN* = "Darkgreen" Frame foreground for hidden windows <= Gimp Layout Group => *GIMP-LAYOUT-NOTIFY-WINDOW-DELAY* = 30 Time to display the GIMP layout notify window help <= Hook Group => *BINDING-HOOK* = (SET-DEFAULT-CIRCULATE-KEYS SET-DEFAULT-EXPOSE-KEYS INIT-*INFO-KEYS* INIT-*INFO-MOUSE* SET-DEFAULT-INFO-KEYS SET-DEFAULT-INFO-MOUSE INIT-*QUERY-KEYS* SET-DEFAULT-QUERY-KEYS INIT-*MAIN-KEYS* INIT-*MAIN-MOUSE* SET-DEFAULT-MAIN-KEYS SET-DEFAULT-MAIN-MOUSE INIT-*SECOND-KEYS* INIT-*SECOND-MOUSE* SET-DEFAULT-SECOND-KEYS SET-DEFAULT-SECOND-MOUSE) Hook executed when keys/buttons are bounds *LOOP-HOOK* = NIL Hook executed on each event loop *MAIN-ENTRANCE-HOOK* = NIL Hook executed on the main function entrance after loading configuration file and before opening the display. *INIT-HOOK* = (DEFAULT-INIT-HOOK DISPLAY-HELLO-WINDOW) Init hook. This hook is run just after the first root frame is created *CLOSE-HOOK* = (CLOSE-NOTIFY-WINDOW CLOSE-CLFSWM-TERMINAL CLOSE-VIRTUAL-KEYBOARD) Close hook. This hook is run just before closing the display *DEFAULT-NW-HOOK* = DEFAULT-FRAME-NW-HOOK Default action to do on newly created windows <= Identify Key Group => *IDENTIFY-FONT-STRING* = "fixed" Identify window font string *IDENTIFY-BACKGROUND* = "black" Identify window background color *IDENTIFY-FOREGROUND* = "green" Identify window foreground color *IDENTIFY-BORDER* = "red" Identify window border color <= Info Mode Group => *INFO-BACKGROUND* = "black" Info window background color *INFO-FOREGROUND* = "green" Info window foreground color *INFO-BORDER* = "red" Info window border color *INFO-LINE-CURSOR* = "white" Info window line cursor color color *INFO-SELECTED-BACKGROUND* = "blue" Info selected item background color *INFO-FONT-STRING* = "fixed" Info window font string *INFO-CLICK-TO-SELECT* = T If true, click on info window select item. Otherwise, click to drag the menu *INFO-COLOR-TITLE* = "Magenta" Colored info title color *INFO-COLOR-UNDERLINE* = "Yellow" Colored info underline color *INFO-COLOR-FIRST* = "Cyan" Colored info first color *INFO-COLOR-SECOND* = "lightblue" Colored info second color <= Main Mode Group => *COLOR-MOVE-WINDOW* = "DeepPink" Color when moving or resizing a windows *COLOR-SELECTED* = "Red" Color of selected window *COLOR-UNSELECTED* = "Blue" Color of unselected color *COLOR-MAYBE-SELECTED* = "Yellow" Color of maybe selected windows <= Menu Group => *MENU-COLOR-SUBMENU* = "Cyan" Submenu color in menu *MENU-COLOR-COMMENT* = "Yellow" Comment color in menu *MENU-COLOR-KEY* = "Magenta" Key color in menu *MENU-COLOR-MENU-KEY* = # Menu key color in menu *XDG-SECTION-LIST* = (TEXTEDITOR FILEMANAGER WEBBROWSER AUDIOVIDEO AUDIO VIDEO DEVELOPMENT EDUCATION GAME GRAPHICS NETWORK OFFICE SETTINGS SYSTEM UTILITY TERMINALEMULATOR ARCHLINUX SCREENSAVER) Standard menu sections <= Miscellaneous Group => *HAVE-TO-COMPRESS-NOTIFY* = T Compress event notify? This variable may be useful to speed up some slow version of CLX. It is particulary useful with CLISP/MIT-CLX. *SHOW-ROOT-FRAME-P* = NIL Show the root frame information or not *BORDER-SIZE* = 1 Windows and frames border size *LOOP-TIMEOUT* = 0.1 Maximum time (in seconds) to wait before calling *loop-hook* *DEFAULT-FONT-STRING* = "fixed" The default font used in clfswm *DEFAULT-FRAME-DATA* = ((:TILE-SIZE 0.8) (:TILE-SPACE-SIZE 0.1) (:FAST-LAYOUT (TILE-LEFT-LAYOUT TILE-LAYOUT)) (:MAIN-LAYOUT-WINDOWS NIL)) Default slots set in frame date *DEFAULT-MANAGED-TYPE* = (:NORMAL) Default managed window types *DEFAULT-FOCUS-POLICY* = :CLICK Default mouse focus policy. One of :click, :sloppy, :sloppy-strict or :sloppy-select. *DEFAULT-MODIFIERS* = NIL Default modifiers list to append to explicit modifiers Example: :mod-2 for num_lock, :lock for Caps_lock... *NEVER-MANAGED-WINDOW-LIST* = ((EQUAL-WM-CLASS-ROX-PINBOARD NIL) (EQUAL-WM-CLASS-XVKBD RAISE-WINDOW) (EQUAL-CLFSWM-TERMINAL RAISE-AND-FOCUS-WINDOW)) CLFSWM will never manage windows of this type. A list of (list match-function handle-function) *HIDE-UNMANAGED-WINDOW* = T Hide or not unmanaged windows when a child is deselected. *SNAP-SIZE* = 20 Snap size (in pixels) when move or resize frame is constrained *SPATIAL-MOVE-DELAY-BEFORE* = 0.2 Delay to display the current child before doing a spatial move *SPATIAL-MOVE-DELAY-AFTER* = 0.5 Delay to display the new child after doing a spatial move *CREATE-FRAME-ON-ROOT* = NIL Create frame on root. Set this variable to true if you want to allow to create a new frame on the root window in the main mode with the mouse *DEFAULT-WINDOW-WIDTH* = 400 Default window width *DEFAULT-WINDOW-HEIGHT* = 300 Default window height <= Notify Window Group => *NOTIFY-WINDOW-FONT-STRING* = "fixed" Notify window font string *NOTIFY-WINDOW-BACKGROUND* = "black" Notify Window background color *NOTIFY-WINDOW-FOREGROUND* = "green" Notify Window foreground color *NOTIFY-WINDOW-BORDER* = "red" Notify Window border color *NOTIFY-WINDOW-DELAY* = 10 Notify Window display delay <= Placement Group => *BANISH-POINTER-PLACEMENT* = BOTTOM-RIGHT-PLACEMENT Pointer banishment placement *SECOND-MODE-PLACEMENT* = TOP-MIDDLE-PLACEMENT Second mode window placement *INFO-MODE-PLACEMENT* = TOP-LEFT-PLACEMENT Info mode window placement *QUERY-MODE-PLACEMENT* = TOP-LEFT-PLACEMENT Query mode window placement *CIRCULATE-MODE-PLACEMENT* = BOTTOM-MIDDLE-PLACEMENT Circulate mode window placement *EXPOSE-MODE-PLACEMENT* = TOP-LEFT-CHILD-PLACEMENT Expose mode window placement (Selection keys position) *NOTIFY-WINDOW-PLACEMENT* = BOTTOM-RIGHT-PLACEMENT Notify window placement *ASK-CLOSE/KILL-PLACEMENT* = TOP-RIGHT-PLACEMENT Ask close/kill window placement <= Query String Group => *QUERY-FONT-STRING* = "fixed" Query string window font string *QUERY-BACKGROUND* = "black" Query string window background color *QUERY-MESSAGE-COLOR* = "yellow" Query string window message color *QUERY-FOREGROUND* = "green" Query string window foreground color *QUERY-CURSOR-COLOR* = "white" Query string window foreground cursor color *QUERY-PARENT-COLOR* = "blue" Query string window parenthesis color *QUERY-PARENT-ERROR-COLOR* = "red" Query string window parenthesis color when no match *QUERY-BORDER* = "red" Query string window border color <= Second Mode Group => *SM-BORDER-COLOR* = "Green" Second mode window border color *SM-BACKGROUND-COLOR* = "Black" Second mode window background color *SM-FOREGROUND-COLOR* = "Red" Second mode window foreground color *SM-FONT-STRING* = "fixed" Second mode window font string *SM-WIDTH* = 300 Second mode window width *SM-HEIGHT* = 25 Second mode window height Those variables can be changed in clfswm. Maybe you'll need to restart clfswm to take care of new values This documentation was produced with the CLFSWM auto-doc functions. To reproduce it, use the produce-conf-var-doc-in-file or the produce-all-docs function from the Lisp REPL. Something like this: LISP> (in-package :clfswm) CLFSWM> (produce-conf-var-doc-in-file "my-variables.txt") or CLFSWM> (produce-all-docs) clfswm-20111015.git51b0a02/load.lisp000066400000000000000000000047361164636077000165520ustar00rootroot00000000000000;;; -------------------------------------------------------------------------- ;;; CLFSWM - FullScreen Window Manager ;;; ;;; -------------------------------------------------------------------------- ;;; Documentation: System loading functions ;;; -------------------------------------------------------------------------- ;;; ;;; (C) 2005 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;; ;;; -------------------------------------------------------------------------- ;;;;;; Uncomment lines above to save the default documentation. ;;(pushnew :BUILD-DOC *features*) ;;(load (compile-file "metering.cl")) (defparameter *base-dir* (directory-namestring *load-truename*)) (export '*base-dir*) #+CMU (setf ext:*gc-verbose* nil) #+SBCL (require :asdf) #+(or CMU ECL) (require :clx) #-ASDF (load (make-pathname :host (pathname-host *base-dir*) :device (pathname-device *base-dir*) :directory (append (pathname-directory *base-dir*) (list "contrib")) :name "asdf" :type "lisp")) (push *base-dir* asdf:*central-registry*) ;;;; Uncomment the line above if you want to follow the ;;;; handle event mecanism. ;;(pushnew :event-debug *features*) (asdf:oos 'asdf:load-op :clfswm) (in-package :clfswm) #-:BUILD-DOC (ignore-errors (main :read-conf-file-p t)) #+:BUILD-DOC (ignore-errors (main :read-conf-file-p nil) (produce-all-docs)) ;;; For debuging: start another sever (for example: 'startx -- :1'), Xnest ;;; or Zephyr and add the lines above in a dot-clfswmrc-debug file ;;; mod-2 is the numlock key on some keyboards. ;;(setf *default-modifiers* '(:mod-2)) ;; ;;(defun my-add-escape () ;; (define-main-key ("Escape" :mod-2) 'exit-clfswm)) ;; ;;(add-hook *binding-hook* 'my-add-escape) ;; ;;(clfswm:main :display ":1" :alternate-conf #P"/where/is/dot-clfswmrc-debug") clfswm-20111015.git51b0a02/src/000077500000000000000000000000001164636077000155175ustar00rootroot00000000000000clfswm-20111015.git51b0a02/src/bindings-second-mode.lisp000066400000000000000000000266331164636077000224120ustar00rootroot00000000000000;;; -------------------------------------------------------------------------- ;;; CLFSWM - FullScreen Window Manager ;;; ;;; -------------------------------------------------------------------------- ;;; Documentation: Bindings keys and mouse for second mode ;;; ;;; Note: Mod-1 is the Alt or Meta key, Mod-2 is the Numlock key. ;;; -------------------------------------------------------------------------- ;;; ;;; (C) 2011 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;; ;;; -------------------------------------------------------------------------- (in-package :clfswm) ;;;,----- ;;;| Second keys ;;;| ;;;| CONFIG - Second mode bindings ;;;`----- (add-hook *binding-hook* 'init-*second-keys* 'init-*second-mouse*) (defun open-frame-menu () "Open the frame menu" (open-menu (find-menu 'frame-menu))) (defun open-window-menu () "Open the window menu" (open-menu (find-menu 'window-menu))) (defun open-action-by-name-menu () "Open the action by name menu" (open-menu (find-menu 'action-by-name-menu))) (defun open-action-by-number-menu () "Open the action by number menu" (open-menu (find-menu 'action-by-number-menu))) (defun open-frame-pack-menu () "Open the frame pack menu" (open-menu (find-menu 'frame-pack-menu))) (defun open-frame-fill-menu () "Open the frame fill menu" (open-menu (find-menu 'frame-fill-menu))) (defun open-frame-resize-menu () "Open the frame resize menu" (open-menu (find-menu 'frame-resize-menu))) (defun tile-current-frame () "Tile the current frame" (set-layout-once #'tile-layout) (leave-second-mode)) (defun stop-all-pending-actions () "Stop all pending actions" (clear-all-nw-hooks) (leave-second-mode)) ;;; default shell programs (defmacro define-shell (key name docstring cmd) "Define a second key to start a shell command" `(define-second-key ,key (defun ,name () ,docstring (setf *second-mode-leave-function* (let ((cmd ,cmd)) (lambda () (do-shell cmd)))) (leave-second-mode)))) (defun set-default-second-keys () (define-second-key ("F1" :mod-1) 'help-on-clfswm) (define-second-key ("m") 'open-menu) (define-second-key ("less") 'open-menu) (define-second-key ("less" :control) 'open-menu) (define-second-key ("f") 'open-frame-menu) (define-second-key ("w") 'open-window-menu) (define-second-key ("n") 'open-action-by-name-menu) (define-second-key ("u") 'open-action-by-number-menu) (define-second-key ("p") 'open-frame-pack-menu) (define-second-key ("l") 'open-frame-fill-menu) (define-second-key ("r") 'open-frame-resize-menu) (define-second-key ("x") 'update-layout-managed-children-position) (define-second-key ("g" :control) 'stop-all-pending-actions) (define-second-key ("q") 'sm-delete-focus-window) (define-second-key ("k") 'sm-ask-close/kill-current-window) (define-second-key ("i") 'identify-key) (define-second-key ("colon") 'eval-from-query-string) (define-second-key ("exclam") 'run-program-from-query-string) (define-second-key ("Return") 'leave-second-mode) (define-second-key ("Escape") 'leave-second-mode) (define-second-key ("t") 'tile-current-frame) (define-second-key ("Home" :mod-1 :control :shift) 'exit-clfswm) (define-second-key ("Right" :mod-1) 'select-next-brother) (define-second-key ("Left" :mod-1) 'select-previous-brother) (define-second-key ("Down" :mod-1) 'select-previous-level) (define-second-key ("Up" :mod-1) 'select-next-level) (define-second-key ("Left" :control :mod-1) 'select-brother-spatial-move-left) (define-second-key ("Right" :control :mod-1) 'select-brother-spatial-move-right) (define-second-key ("Up" :control :mod-1) 'select-brother-spatial-move-up) (define-second-key ("Down" :control :mod-1) 'select-brother-spatial-move-down) (define-second-key ("Right") 'speed-mouse-right) (define-second-key ("Left") 'speed-mouse-left) (define-second-key ("Down") 'speed-mouse-down) (define-second-key ("Up") 'speed-mouse-up) (define-second-key ("Left" :control) 'speed-mouse-undo) (define-second-key ("Up" :control) 'speed-mouse-first-history) (define-second-key ("Down" :control) 'speed-mouse-reset) (define-second-key ("Tab" :mod-1) 'select-next-child) (define-second-key ("Tab" :mod-1 :shift) 'select-previous-child) (define-second-key ("Tab" :mod-1 :control) 'select-next-subchild) (define-second-key ("Tab") 'switch-to-last-child) (define-second-key ("Return" :mod-1) 'enter-frame) (define-second-key ("Return" :mod-1 :shift) 'leave-frame) (define-second-key ("Return" :mod-5) 'frame-toggle-maximize) (define-second-key ("Page_Up" :mod-1) 'frame-lower-child) (define-second-key ("Page_Down" :mod-1) 'frame-raise-child) (define-second-key ("Home" :mod-1) 'switch-to-root-frame) (define-second-key ("Home" :mod-1 :shift) 'switch-and-select-root-frame) (define-second-key ("Menu") 'toggle-show-root-frame) (define-second-key ("b" :mod-1) 'banish-pointer) (define-second-key ("o") 'set-open-in-new-frame-in-parent-frame-nw-hook) (define-second-key ("o" :control) 'set-open-in-new-frame-in-root-frame-nw-hook) (define-second-key ("a") 'add-default-frame) (define-second-key ("a" :control) 'add-frame-in-parent-frame) (define-second-key ("plus") 'inc-tile-layout-size) (define-second-key ("minus") 'dec-tile-layout-size) (define-second-key ("plus" :control) 'inc-slow-tile-layout-size) (define-second-key ("minus" :control) 'dec-slow-tile-layout-size) ;; Escape (define-second-key ("Escape" :control) 'ask-close/kill-current-window) ;; Selection (define-second-key ("x" :control) 'cut-current-child) (define-second-key ("x" :control :mod-1) 'clear-selection) (define-second-key ("c" :control) 'copy-current-child) (define-second-key ("v" :control) 'paste-selection) (define-second-key ("v" :control :shift) 'paste-selection-no-clear) (define-second-key ("Delete" :control) 'remove-current-child) (define-second-key ("Delete") 'delete-current-child) (define-shell ("c") b-start-xterm "start an xterm" "cd $HOME && exec xterm") (define-shell ("e") b-start-emacs "start emacs" "cd $HOME && exec emacs") (define-shell ("e" :control) b-start-emacsremote "start an emacs for another user" "exec xterm -e emacsremote") (define-shell ("h") b-start-xclock "start an xclock" "exec xclock -d") (define-second-key ("F10" :mod-1) 'fast-layout-switch) (define-second-key ("F10" :shift :control) 'toggle-show-root-frame) (define-second-key ("F10") 'expose-windows-current-child-mode) (define-second-key ("F10" :control) 'expose-windows-mode) (define-second-key ("F10" :control :shift) 'expose-all-windows-mode) (define-second-key ("L2" :shift) 'show-all-frames-info-key) (define-second-key ("L2" :shift :mod-1) 'show-all-frames-info) ;; Bind or jump functions (define-second-key ("1" :mod-1) 'bind-or-jump 1) (define-second-key ("2" :mod-1) 'bind-or-jump 2) (define-second-key ("3" :mod-1) 'bind-or-jump 3) (define-second-key ("4" :mod-1) 'bind-or-jump 4) (define-second-key ("5" :mod-1) 'bind-or-jump 5) (define-second-key ("6" :mod-1) 'bind-or-jump 6) (define-second-key ("7" :mod-1) 'bind-or-jump 7) (define-second-key ("8" :mod-1) 'bind-or-jump 8) (define-second-key ("9" :mod-1) 'bind-or-jump 9) (define-second-key ("0" :mod-1) 'bind-or-jump 10)) (add-hook *binding-hook* 'set-default-second-keys) ;;; Mouse action (defun sm-mouse-click-to-focus-and-move (window root-x root-y) "Move and focus the current child - Create a new frame on the root window. Or do corners actions" (declare (ignore window)) (or (do-corner-action root-x root-y *corner-second-mode-left-button*) (mouse-focus-move/resize-generic root-x root-y #'move-frame nil))) (defun sm-mouse-click-to-focus-and-resize (window root-x root-y) "Resize and focus the current child - Create a new frame on the root window. Or do corners actions" (declare (ignore window)) (or (do-corner-action root-x root-y *corner-second-mode-right-button*) (mouse-focus-move/resize-generic root-x root-y #'resize-frame nil))) (defun sm-mouse-middle-click (window root-x root-y) "Do actions on corners" (declare (ignore window)) (or (do-corner-action root-x root-y *corner-second-mode-middle-button*) (replay-button-event))) (defun sm-mouse-select-next-level (window root-x root-y) "Select the next level in frame" (declare (ignore window root-x root-y)) (select-next-level)) (defun sm-mouse-select-previous-level (window root-x root-y) "Select the previous level in frame" (declare (ignore window root-x root-y)) (select-previous-level)) (defun sm-mouse-enter-frame (window root-x root-y) "Enter in the selected frame - ie make it the root frame" (declare (ignore window root-x root-y)) (enter-frame)) (defun sm-mouse-leave-frame (window root-x root-y) "Leave the selected frame - ie make its parent the root frame" (declare (ignore window root-x root-y)) (leave-frame)) (defun sm-mouse-click-to-focus-and-move-window (window root-x root-y) "Move and focus the current child - Create a new frame on the root window" (declare (ignore window)) (mouse-focus-move/resize-generic root-x root-y #'move-frame t)) (defun sm-mouse-click-to-focus-and-resize-window (window root-x root-y) "Resize and focus the current child - Create a new frame on the root window" (declare (ignore window)) (mouse-focus-move/resize-generic root-x root-y #'resize-frame t)) (defun sm-mouse-click-to-focus-and-move-window-constrained (window root-x root-y) "Move (constrained by other frames) and focus the current child - Create a new frame on the root window" (declare (ignore window)) (mouse-focus-move/resize-generic root-x root-y #'move-frame-constrained t)) (defun sm-mouse-click-to-focus-and-resize-window-constrained (window root-x root-y) "Resize (constrained by other frames) and focus the current child - Create a new frame on the root window" (declare (ignore window)) (mouse-focus-move/resize-generic root-x root-y #'resize-frame-constrained t)) (defun set-default-second-mouse () (define-second-mouse (1) 'sm-mouse-click-to-focus-and-move) (define-second-mouse (2) 'sm-mouse-middle-click) (define-second-mouse (3) 'sm-mouse-click-to-focus-and-resize) (define-second-mouse (1 :mod-1) 'sm-mouse-click-to-focus-and-move-window) (define-second-mouse (3 :mod-1) 'sm-mouse-click-to-focus-and-resize-window) (define-second-mouse (1 :mod-1 :shift) 'sm-mouse-click-to-focus-and-move-window-constrained) (define-second-mouse (3 :mod-1 :shift) 'sm-mouse-click-to-focus-and-resize-window-constrained) (define-second-mouse (1 :control :mod-1) 'mouse-move-child-over-frame) (define-second-mouse (4) 'sm-mouse-select-next-level) (define-second-mouse (5) 'sm-mouse-select-previous-level) (define-second-mouse (4 :mod-1) 'sm-mouse-enter-frame) (define-second-mouse (5 :mod-1) 'sm-mouse-leave-frame)) (add-hook *binding-hook* 'set-default-second-mouse) clfswm-20111015.git51b0a02/src/bindings.lisp000066400000000000000000000142551164636077000202140ustar00rootroot00000000000000;;; -------------------------------------------------------------------------- ;;; CLFSWM - FullScreen Window Manager ;;; ;;; -------------------------------------------------------------------------- ;;; Documentation: Bindings keys and mouse ;;; ;;; Note: Mod-1 is the Alt or Meta key, Mod-2 is the Numlock key. ;;; -------------------------------------------------------------------------- ;;; ;;; (C) 2011 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;; ;;; -------------------------------------------------------------------------- (in-package :clfswm) ;;;,----- ;;;| CONFIG - Bindings main mode ;;;`----- (add-hook *binding-hook* 'init-*main-keys* 'init-*main-mouse*) (defun help-on-clfswm () "Open the help and info window" (open-menu (find-menu 'help-menu))) (defun set-default-main-keys () (define-main-key ("F1" :mod-1) 'help-on-clfswm) (define-main-key ("Home" :mod-1 :control :shift) 'exit-clfswm) (define-main-key ("Right" :mod-1) 'select-next-brother) (define-main-key ("Left" :mod-1) 'select-previous-brother) (define-main-key ("Down" :mod-1) 'select-previous-level) (define-main-key ("Up" :mod-1) 'select-next-level) (define-main-key ("Left" :control :mod-1) 'select-brother-spatial-move-left) (define-main-key ("Right" :control :mod-1) 'select-brother-spatial-move-right) (define-main-key ("Up" :control :mod-1) 'select-brother-spatial-move-up) (define-main-key ("Down" :control :mod-1) 'select-brother-spatial-move-down) (define-main-key ("Tab" :mod-1) 'select-next-child) (define-main-key ("Tab" :mod-1 :shift) 'select-previous-child) (define-main-key ("Tab" :mod-1 :control) 'select-next-subchild) (define-main-key ("Return" :mod-1) 'enter-frame) (define-main-key ("Return" :mod-1 :shift) 'leave-frame) (define-main-key ("Return" :mod-5) 'frame-toggle-maximize) (define-main-key ("Page_Up" :mod-1) 'frame-select-previous-child) (define-main-key ("Page_Down" :mod-1) 'frame-select-next-child) (define-main-key ("Page_Up" :mod-1 :control) 'frame-lower-child) (define-main-key ("Page_Down" :mod-1 :control) 'frame-raise-child) (define-main-key ("Home" :mod-1) 'switch-to-root-frame) (define-main-key ("Home" :mod-1 :shift) 'switch-and-select-root-frame) (define-main-key ("F10" :mod-1) 'fast-layout-switch) (define-main-key ("F10" :shift :control) 'toggle-show-root-frame) (define-main-key ("F10") 'expose-windows-current-child-mode) (define-main-key ("F10" :control) 'expose-windows-mode) (define-main-key ("F10" :control :shift) 'expose-all-windows-mode) (define-main-key ("L2" :control) 'present-clfswm-terminal) (define-main-key ("L2" :shift) 'show-all-frames-info-key) (define-main-key ("L2" :shift :mod-1) 'show-all-frames-info) (define-main-key ("b" :mod-1) 'banish-pointer) ;; Escape (define-main-key ("Escape" :control) 'ask-close/kill-current-window) ;; Second mode (define-main-key (#\t :mod-1) 'second-key-mode) (define-main-key ("less" :control) 'second-key-mode) ;; Bind or jump functions (define-main-key ("1" :mod-1) 'bind-or-jump 1) (define-main-key ("2" :mod-1) 'bind-or-jump 2) (define-main-key ("3" :mod-1) 'bind-or-jump 3) (define-main-key ("4" :mod-1) 'bind-or-jump 4) (define-main-key ("5" :mod-1) 'bind-or-jump 5) (define-main-key ("6" :mod-1) 'bind-or-jump 6) (define-main-key ("7" :mod-1) 'bind-or-jump 7) (define-main-key ("8" :mod-1) 'bind-or-jump 8) (define-main-key ("9" :mod-1) 'bind-or-jump 9) (define-main-key ("0" :mod-1) 'bind-or-jump 10)) (add-hook *binding-hook* 'set-default-main-keys) ;;; Mouse actions (defun mouse-click-to-focus-and-move-window (window root-x root-y) "Move and focus the current child - Create a new frame on the root window" (declare (ignore window)) (stop-button-event) (mouse-focus-move/resize-generic root-x root-y #'move-frame t)) (defun mouse-click-to-focus-and-resize-window (window root-x root-y) "Resize and focus the current child - Create a new frame on the root window" (declare (ignore window)) (stop-button-event) (mouse-focus-move/resize-generic root-x root-y #'resize-frame t)) (defun mouse-click-to-focus-and-move-window-constrained (window root-x root-y) "Move (constrained by other frames) and focus the current child - Create a new frame on the root window" (declare (ignore window)) (stop-button-event) (mouse-focus-move/resize-generic root-x root-y #'move-frame-constrained t)) (defun mouse-click-to-focus-and-resize-window-constrained (window root-x root-y) "Resize (constrained by other frames) and focus the current child - Create a new frame on the root window" (declare (ignore window)) (stop-button-event) (mouse-focus-move/resize-generic root-x root-y #'resize-frame-constrained t)) (defun set-default-main-mouse () (define-main-mouse (1) 'mouse-click-to-focus-and-move) (define-main-mouse (2) 'mouse-middle-click) (define-main-mouse (3) 'mouse-click-to-focus-and-resize) (define-main-mouse (1 :mod-1) 'mouse-click-to-focus-and-move-window) (define-main-mouse (3 :mod-1) 'mouse-click-to-focus-and-resize-window) (define-main-mouse (1 :mod-1 :shift) 'mouse-click-to-focus-and-move-window-constrained) (define-main-mouse (3 :mod-1 :shift) 'mouse-click-to-focus-and-resize-window-constrained) (define-main-mouse (1 :control :mod-1) 'mouse-move-child-over-frame) (define-main-mouse (4) 'mouse-select-next-level) (define-main-mouse (5) 'mouse-select-previous-level) (define-main-mouse (4 :mod-1) 'mouse-enter-frame) (define-main-mouse (5 :mod-1) 'mouse-leave-frame)) (add-hook *binding-hook* 'set-default-main-mouse) clfswm-20111015.git51b0a02/src/clfswm-autodoc.lisp000066400000000000000000000413161164636077000213440ustar00rootroot00000000000000;;; -------------------------------------------------------------------------- ;;; CLFSWM - FullScreen Window Manager ;;; ;;; -------------------------------------------------------------------------- ;;; Documentation: Auto documentation tools ;;; -------------------------------------------------------------------------- ;;; ;;; (C) 2011 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;; ;;; -------------------------------------------------------------------------- (in-package :clfswm) (defun is-string-keysym (k) (when (stringp k) (or (parse-integer k :junk-allowed t) (intern (string-upcase k))))) (defun produce-doc-html (hash-table-key-list &optional (stream t)) "Produce an html doc from a hash-table key" (labels ((clean-string (str) (cond ((string-equal str "#\\:") ":") ((string-equal str "#\\#") "#") ((string-equal str "#\\\\") "\\") (t (substitute #\Space #\# (substitute #\Space #\\ (substitute #\Space #\: str)))))) (produce-keys (hk) `("table class=\"ex\" cellspacing=\"5\" border=\"0\" width=\"100%\"" (tr ("th align=\"right\" width=\"10%\"" "Modifiers") ("th align=\"center\" width=\"10%\"" "Key/Button") ("th align=\"left\"" "Function")) ,@(let ((acc nil)) (maphash #'(lambda (k v) (when (consp k) (push `(tr ("td align=\"right\" style=\"color:#FF0000\" nowrap" ,(clean-string (format nil "~{~@(~S ~)~}" (state->modifiers (second k))))) ("td align=\"center\" nowrap" ,(clean-string (format nil "~@(~S~)" (or (is-string-keysym (first k)) (first k))))) ("td style=\"color:#0000FF\" nowrap" ,(documentation (or (first v) (third v)) 'function))) acc))) hk) (nreverse acc))))) (produce-html `(html (head (title "CLFSWM Keys")) (body (h1 "CLFSWM Keys") (p (small "Note: Mod-1 is the Meta or Alt key")) ,@(let ((acc nil)) (dolist (hk hash-table-key-list) (push `(h3 (u ,(gethash 'name hk))) acc) (push (produce-keys hk) acc)) (nreverse acc)) (p (small "This documentation was produced with the CLFSWM auto-doc functions. To reproduce it, use the produce-doc-html-in-file or the produce-all-docs function from the Lisp REPL.")) (p (small "Something like this:
LISP> (in-package :clfswm)
CLFSWM> (produce-doc-html-in-file \"my-keys.html\")
or
CLFSWM> (produce-all-docs)")))) 0 stream))) (defun produce-doc-html-in-file (filename) (format t "Producing html keys documentation in ~S " filename) (with-open-file (stream filename :direction :output :if-exists :supersede :if-does-not-exist :create) (produce-doc-html (list *main-keys* *main-mouse* *second-keys* *second-mouse* *info-keys* *info-mouse* *circulate-keys* *expose-keys* *expose-mouse*) stream)) (format t " done~%")) (defun produce-doc (hash-table-key-list &optional (stream t) (display-producing-doc t)) "Produce a text doc from a hash-table key" (format stream " * CLFSWM Keys *~%") (format stream " -----------~%") (format stream "~%Note: Mod-1 is the Meta or Alt key~%") (dolist (hk hash-table-key-list) (format stream "~2&~A:~%" (gethash 'name hk)) (dotimes (i (length (gethash 'name hk))) (format stream "-")) (format stream "~2%") (maphash #'(lambda (k v) (when (consp k) (format stream "~& ~20@<~{~@(~A~) ~}~> ~13@<~@(~A~)~> ~A~%" (state->modifiers (second k)) (remove #\# (remove #\\ (format nil "~S" (or (is-string-keysym (first k)) (first k))))) (documentation (or (first v) (third v)) 'function)))) hk) (format stream "~2&")) (when display-producing-doc (format stream "~2%This documentation was produced with the CLFSWM auto-doc functions. To reproduce it, use the produce-doc-in-file or the produce-all-docs function from the Lisp REPL. Something like this: LISP> (in-package :clfswm) CLFSWM> (produce-doc-in-file \"my-keys.txt\") or CLFSWM> (produce-all-docs)~2%"))) (defun produce-doc-in-file (filename) (format t "Producing text keys documentation in ~S " filename) (with-open-file (stream filename :direction :output :if-exists :supersede :if-does-not-exist :create) (produce-doc (list *main-keys* *main-mouse* *second-keys* *second-mouse* *info-keys* *info-mouse* *circulate-keys* *expose-keys* *expose-mouse*) stream)) (format t " done~%")) ;;; Menu autodoc functions (defun produce-menu-doc (&optional (stream t)) (labels ((rec (base) (format stream "~2&~:(~A~)~%" (menu-name base)) (dolist (item (menu-item base)) (typecase item (menu (format stream "~A: ~A~%" (menu-name item) (menu-doc item))) (menu-item (aif (menu-item-key item) (format stream "~A: ~A~%" it (typecase (menu-item-value item) (menu (format nil "< ~A >" (menu-doc (menu-item-value item)))) (t (documentation (menu-item-value item) 'function)))) (format stream "~A~%" (menu-item-value item)))))) (dolist (item (menu-item base)) (typecase item (menu (rec item)) (menu-item (when (menu-p (menu-item-value item)) (rec (menu-item-value item)))))))) (format stream "Here is the map of the CLFSWM menu:~%") (format stream "(By default it is bound on second-mode + m)~%") (rec *menu*) (format stream "~2%This documentation was produced with the CLFSWM auto-doc functions. To reproduce it, use the produce-menu-doc-in-file or the produce-all-docs function from the Lisp REPL. Something like this: LISP> (in-package :clfswm) CLFSWM> (produce-menu-doc-in-file \"my-menu.txt\") or CLFSWM> (produce-all-docs)~2%"))) (defun produce-menu-doc-in-file (filename) (format t "Producing text menus documentation in ~S " filename) (with-open-file (stream filename :direction :output :if-exists :supersede :if-does-not-exist :create) (produce-menu-doc stream)) (format t " done~%")) (defun produce-menu-doc-html (&optional (stream t)) (let ((menu-list nil)) (labels ((rec (base parent) (push `(h3 ,(format nil "~:(~A~)" (menu-name base) (if parent (menu-name parent) "Top") (menu-name base))) menu-list) (dolist (item (menu-item base)) (typecase item (menu (push `(p ,(format nil "~A: ~A" (menu-name item) (menu-doc item))) menu-list)) (menu-item (push `(p ,(aif (menu-item-key item) (format nil "~A: ~A" it (typecase (menu-item-value item) (menu (format nil "< ~A >" (menu-name (menu-item-value item)) (menu-doc (menu-item-value item)))) (t (documentation (menu-item-value item) 'function)))) (format nil "~A" (menu-item-value item)))) menu-list)))) (push '
menu-list) (dolist (item (menu-item base)) (typecase item (menu (rec item base)) (menu-item (when (menu-p (menu-item-value item)) (rec (menu-item-value item) base))))))) (rec *menu* nil) (produce-html `(html (head (title "CLFSWM Menu")) (body (h1 ("a name=\"Top\"" "CLFSWM Menu")) (p "Here is the map of the CLFSWM menu:" "(By default it is bound on second-mode + m)") ,@(nreverse menu-list) (p (small "This documentation was produced with the CLFSWM auto-doc functions. To reproduce it, use the produce-menu-doc-html-in-file or the produce-all-docs function from the Lisp REPL.")) (p (small "Something like this:
LISP> (in-package :clfswm)
CLFSWM> (produce-menu-doc-html-in-file \"my-menu.html\")
or
CLFSWM> (produce-all-docs)")))) 0 stream)))) (defun produce-menu-doc-html-in-file (filename) (format t "Producing html menus documentation in ~S " filename) (with-open-file (stream filename :direction :output :if-exists :supersede :if-does-not-exist :create) (produce-menu-doc-html stream)) (format t " done~%")) ;;; Corner autodoc functions (defun produce-corner-doc (&optional (stream t)) (labels ((print-doc (corner-list) (format stream "~2&~:(~A~):~%" corner-list) (dolist (corner (symbol-value corner-list)) (format stream " ~:(~A:~) ~A~%" (first corner) (if (fboundp (second corner)) (documentation (second corner) 'function) "---"))))) (format stream "Here are the actions associated to screen corners in CLFSWM:") (dolist (corner '(*corner-main-mode-left-button* *corner-main-mode-middle-button* *corner-main-mode-right-button* *corner-second-mode-left-button* *corner-second-mode-middle-button* *corner-second-mode-right-button*)) (print-doc corner)) (format stream "~2%This documentation was produced with the CLFSWM auto-doc functions. To reproduce it, use the produce-corner-doc-in-file or the produce-all-docs function from the Lisp REPL. Something like this: LISP> (in-package :clfswm) CLFSWM> (produce-corner-doc-in-file \"my-corner.txt\") or CLFSWM> (produce-all-docs)~2%"))) (defun produce-corner-doc-in-file (filename) (format t "Producing text corner documentation in ~S " filename) (with-open-file (stream filename :direction :output :if-exists :supersede :if-does-not-exist :create) (produce-corner-doc stream)) (format t " done~%")) (defun produce-corner-doc-html (&optional (stream t)) (let ((corner-html nil)) (labels ((one-corner (corner-list) (push `(h3 ,corner-list) corner-html) (push `("table class=\"ex\" cellspacing=\"5\" border=\"0\" width=\"100%\"" ,@(loop :for corner :in (symbol-value corner-list) :collect `(tr ("td align=\"left\" width=\"1%\" style=\"color:#FF0000\" nowrap" ,(format nil "~:(~A~):" (first corner))) ("td style=\"color:#0000FF\" nowrap" ,(if (fboundp (second corner)) (documentation (second corner) 'function) "---"))))) corner-html)) (fill-corner-list () (dolist (corner '(*corner-main-mode-left-button* *corner-main-mode-middle-button* *corner-main-mode-right-button* *corner-second-mode-left-button* *corner-second-mode-middle-button* *corner-second-mode-right-button*)) (one-corner corner)))) (fill-corner-list) (produce-html `(html (head (title "CLFSWM Corners")) (body (h1 ("a name=\"Top\"" "CLFSWM Corners")) (p "Here are the actions associated to screen corners in CLFSWM:") ,@(nreverse corner-html) (p (small "This documentation was produced with the CLFSWM auto-doc functions. To reproduce it, use the produce-corner-doc-html-in-file or the produce-all-docs function from the Lisp REPL.")) (p (small "Something like this:
LISP> (in-package :clfswm)
CLFSWM> (produce-corner-doc-html-in-file \"my-corner.html\")
or
CLFSWM> (produce-all-docs)")))) 0 stream)))) (defun produce-corner-doc-html-in-file (filename) (format t "Producing html corner documentation in ~S " filename) (with-open-file (stream filename :direction :output :if-exists :supersede :if-does-not-exist :create) (produce-corner-doc-html stream)) (format t " done~%")) ;;; Configuration variables autodoc functions (defun produce-conf-var-doc (stream &optional (group t) (title t) (footnote t)) (when title (format stream " * CLFSWM Configuration variables *~%") (format stream " ------------------------------~2%")) (format stream "<= ~A =>~2%" (if (equal group t) "" (config-group->string group))) (maphash (lambda (key val) (when (or (equal group t) (equal group (configvar-group val))) (format stream " ~A = ~S~% ~A~%" key (symbol-value key) (documentation key 'variable)))) *config-var-table*) (when footnote (format stream "~2& Those variables can be changed in clfswm. Maybe you'll need to restart clfswm to take care of new values") (format stream "~2%This documentation was produced with the CLFSWM auto-doc functions. To reproduce it, use the produce-conf-var-doc-in-file or the produce-all-docs function from the Lisp REPL. Something like this: LISP> (in-package :clfswm) CLFSWM> (produce-conf-var-doc-in-file \"my-variables.txt\") or CLFSWM> (produce-all-docs)~2%")) (format stream "~2%")) (defun produce-conf-var-doc-in-file (filename) (format t "Producing text config variables documentation in ~S " filename) (with-open-file (stream filename :direction :output :if-exists :supersede :if-does-not-exist :create) (let* ((title t) (all-groups (config-all-groups)) (last-group (first (last all-groups)))) (dolist (group all-groups) (produce-conf-var-doc stream group title (equal group last-group)) (setf title nil)))) (format t " done~%")) (defun produce-conf-var-doc-html (&optional (stream t)) (let ((all-groups (config-all-groups))) (labels ((conf-var-group () `((h3 ("a name='TOP'" "Configuration variables groups:")) (ul ,@(loop for group in all-groups collect `(li (,(format nil "a href='#~A'" group) ,(config-group->string group))))))) (colorize-line (group list) (let ((acc nil)) (dolist (line list) (cond ((search "* =" line) (let ((pos (position #\= line))) (push `("font color='#FF0000'" ,(format nil "  ~(~A~)" (subseq line 0 (1- pos)))) acc) (push `("font color='#0000FF'" ,(format nil "~A
" (subseq line (1- pos)))) acc))) ((search "<=" line) (push `(p (,(format nil "a name='~A' href='#TOP'" group) ,(escape-html line))) acc)) ((not (string= line " ")) (push (format nil "        ~A
~%" line) acc)))) (nreverse acc))) (conf-var (group) (colorize-line group (split-string (append-newline-space (with-output-to-string (stream) (produce-conf-var-doc stream group nil nil))) #\Newline))) (all-conf-var () (let ((acc nil)) (dolist (group all-groups) (setf acc (nconc acc (conf-var group)))) acc))) (produce-html `(html (head (title "CLFSWM - Configuration variables")) (body (h1 ("a name='Top'" "CLFSWM - Configuration variables")) (p "Here are the variables you can configure in CLFSWM with the configuration file or the configuration menu:") ,@(conf-var-group) ,@(all-conf-var) (p (small "This documentation was produced with the CLFSWM auto-doc functions. To reproduce it, use the produce-conf-var-doc-html-in-file or the produce-all-docs function from the Lisp REPL.")) (p (small "Something like this:
LISP> (in-package :clfswm)
CLFSWM> (produce-conf-var-doc-html-in-file \"my-variables.html\")
or
CLFSWM> (produce-all-docs)")))) 0 stream)))) (defun produce-conf-var-doc-html-in-file (filename) (format t "Producing html configuration variables documentation in ~S " filename) (with-open-file (stream filename :direction :output :if-exists :supersede :if-does-not-exist :create) (produce-conf-var-doc-html stream)) (format t " done~%")) (defun produce-all-docs () "Produce all docs in keys.html and keys.txt" (produce-doc-in-file "doc/keys.txt") (produce-doc-html-in-file "doc/keys.html") (produce-menu-doc-in-file "doc/menu.txt") (produce-menu-doc-html-in-file "doc/menu.html") (produce-corner-doc-in-file "doc/corner.txt") (produce-corner-doc-html-in-file "doc/corner.html") (produce-conf-var-doc-in-file "doc/variables.txt") (produce-conf-var-doc-html-in-file "doc/variables.html")) clfswm-20111015.git51b0a02/src/clfswm-circulate-mode.lisp000066400000000000000000000335611164636077000226060ustar00rootroot00000000000000;;; -------------------------------------------------------------------------- ;;; CLFSWM - FullScreen Window Manager ;;; ;;; -------------------------------------------------------------------------- ;;; Documentation: Main functions ;;; -------------------------------------------------------------------------- ;;; ;;; (C) 2011 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;; ;;; -------------------------------------------------------------------------- (in-package :clfswm) (defparameter *circulate-window* nil) (defparameter *circulate-font* nil) (defparameter *circulate-gc* nil) (defparameter *circulate-hit* 0) (defparameter *circulate-orig* nil) (defparameter *circulate-parent* nil) (defun draw-circulate-mode-window () (raise-window *circulate-window*) (clear-pixmap-buffer *circulate-window* *circulate-gc*) (let* ((text (format nil "~A [~A]" (limit-length (ensure-printable (child-name (xlib:input-focus *display*))) *circulate-text-limite*) (limit-length (ensure-printable (child-name *current-child*)) *circulate-text-limite*))) (len (length text))) (xlib:draw-glyphs *pixmap-buffer* *circulate-gc* (truncate (/ (- *circulate-width* (* (xlib:max-char-width *circulate-font*) len)) 2)) (truncate (/ (+ *circulate-height* (- (xlib:font-ascent *circulate-font*) (xlib:font-descent *circulate-font*))) 2)) text)) (copy-pixmap-buffer *circulate-window* *circulate-gc*)) (defun leave-circulate-mode () "Leave the circulate mode" (throw 'exit-circulate-loop nil)) (defun reset-circulate-child () (setf *circulate-hit* 0 *circulate-parent* nil *circulate-orig* (frame-child *current-child*))) (defun reset-circulate-brother () (setf *circulate-parent* (find-parent-frame *current-child*) *circulate-hit* 0) (when (frame-p *circulate-parent*) (setf *circulate-orig* (frame-child *circulate-parent*)))) (defun reorder-child (direction) (no-focus) (with-slots (child selected-pos) *current-child* (unless *circulate-orig* (reset-circulate-child)) (let ((len (length *circulate-orig*))) (when (plusp len) (let ((elem (nth (mod (incf *circulate-hit* direction) len) *circulate-orig*))) (setf child (cons elem (child-remove elem *circulate-orig*)) selected-pos 0))) (show-all-children) (draw-circulate-mode-window)))) (defun reorder-brother (direction) (no-focus) (let ((frame-is-root? (and (child-equal-p *current-root* *current-child*) (not (child-equal-p *current-root* *root-frame*))))) (select-current-frame nil) (unless (and *circulate-orig* *circulate-parent*) (reset-circulate-brother)) (let ((len (length *circulate-orig*))) (when (plusp len) (when (frame-p *circulate-parent*) (let ((elem (nth (mod (incf *circulate-hit* direction) len) *circulate-orig*))) (setf (frame-child *circulate-parent*) (cons elem (child-remove elem *circulate-orig*)) (frame-selected-pos *circulate-parent*) 0 *current-child* (frame-selected-child *circulate-parent*)))) (when frame-is-root? (setf *current-root* *current-child*)))) (show-all-children t) (draw-circulate-mode-window))) (defun reorder-subchild (direction) (declare (ignore direction)) (when (frame-p *current-child*) (let ((selected-child (frame-selected-child *current-child*))) (when (frame-p selected-child) (no-focus) (with-slots (child selected-pos) selected-child (let ((elem (first (last child)))) (when elem (setf child (cons elem (child-remove elem child)) selected-pos 0)) (show-all-children) (draw-circulate-mode-window))))))) (defun circulate-select-next-child () "Select the next child" (when (frame-p *current-child*) (when *circulate-parent* (reset-circulate-child)) (reorder-child +1))) (defun circulate-select-previous-child () "Select the previous child" (when (frame-p *current-child*) (when *circulate-parent* (reset-circulate-child)) (reorder-child -1))) (defun circulate-select-next-brother () "Select the next brother" (unless *circulate-parent* (reset-circulate-brother)) (reorder-brother +1)) (defun circulate-select-previous-brother () "Select the previous borther" (unless *circulate-parent* (reset-circulate-brother)) (reorder-brother -1)) (defun circulate-select-next-subchild () "Select the next subchild" (reorder-subchild +1)) (add-hook *binding-hook* 'set-default-circulate-keys) (defun set-default-circulate-keys () (define-circulate-key ("Escape") 'leave-circulate-mode) (define-circulate-key ("g" :control) 'leave-circulate-mode) (define-circulate-key ("Escape" :alt) 'leave-circulate-mode) (define-circulate-key ("g" :control :alt) 'leave-circulate-mode) (define-circulate-key ("Tab" :mod-1) 'circulate-select-next-child) (define-circulate-key ("Tab" :mod-1 :control) 'circulate-select-next-subchild) (define-circulate-key ("Tab" :mod-1 :shift) 'circulate-select-previous-child) (define-circulate-key ("Iso_Left_Tab" :mod-1 :shift) 'circulate-select-previous-child) (define-circulate-key ("Right" :mod-1) 'circulate-select-next-brother) (define-circulate-key ("Left" :mod-1) 'circulate-select-previous-brother) (define-circulate-release-key ("Alt_L" :alt) 'leave-circulate-mode) (define-circulate-release-key ("Alt_L") 'leave-circulate-mode)) (defun circulate-leave-function () (when *circulate-gc* (xlib:free-gcontext *circulate-gc*)) (when *circulate-window* (xlib:destroy-window *circulate-window*)) (when *circulate-font* (xlib:close-font *circulate-font*)) (xlib:display-finish-output *display*) (setf *circulate-window* nil *circulate-gc* nil *circulate-font* nil)) (defun circulate-loop-function () (unless (is-a-key-pressed-p) (leave-circulate-mode))) (define-handler circulate-mode :key-press (code state) (unless (funcall-key-from-code *circulate-keys* code state) (setf *circulate-hit* 0 *circulate-orig* nil *circulate-parent* nil) (funcall-key-from-code *main-keys* code state))) (define-handler circulate-mode :key-release (code state) (funcall-key-from-code *circulate-keys-release* code state)) (defun circulate-mode (&key child-direction brother-direction subchild-direction) (setf *circulate-hit* 0) (with-placement (*circulate-mode-placement* x y *circulate-width* *circulate-height*) (setf *circulate-font* (xlib:open-font *display* *circulate-font-string*) *circulate-window* (xlib:create-window :parent *root* :x x :y y :width *circulate-width* :height *circulate-height* :background (get-color *circulate-background*) :border-width *border-size* :border (get-color *circulate-border*) :colormap (xlib:screen-default-colormap *screen*) :event-mask '(:exposure :key-press)) *circulate-gc* (xlib:create-gcontext :drawable *circulate-window* :foreground (get-color *circulate-foreground*) :background (get-color *circulate-background*) :font *circulate-font* :line-style :solid)) (map-window *circulate-window*) (draw-circulate-mode-window) (when child-direction (reorder-child child-direction)) (when brother-direction (reorder-brother brother-direction)) (when subchild-direction (reorder-subchild subchild-direction)) (let ((grab-keyboard-p (xgrab-keyboard-p)) (grab-pointer-p (xgrab-pointer-p))) (xgrab-pointer *root* 92 93) (unless grab-keyboard-p (ungrab-main-keys) (xgrab-keyboard *root*)) (generic-mode 'circulate-mode 'exit-circulate-loop :loop-function #'circulate-loop-function :leave-function #'circulate-leave-function :original-mode '(main-mode)) (circulate-leave-function) (unless grab-keyboard-p (xungrab-keyboard) (grab-main-keys)) (if grab-pointer-p (xgrab-pointer *root* 66 67) (xungrab-pointer))))) (defun select-next-child () "Select the next child" (when (frame-p *current-child*) (setf *circulate-orig* (frame-child *current-child*) *circulate-parent* nil) (circulate-mode :child-direction +1))) (defun select-previous-child () "Select the previous child" (when (frame-p *current-child*) (setf *circulate-orig* (frame-child *current-child*) *circulate-parent* nil) (circulate-mode :child-direction -1))) (defun select-next-brother () "Select the next brother" (setf *circulate-parent* (find-parent-frame *current-child*)) (when (frame-p *circulate-parent*) (setf *circulate-orig* (frame-child *circulate-parent*))) (circulate-mode :brother-direction +1)) (defun select-previous-brother () "Select the previous brother" (setf *circulate-parent* (find-parent-frame *current-child*)) (when (frame-p *circulate-parent*) (setf *circulate-orig* (frame-child *circulate-parent*))) (circulate-mode :brother-direction -1)) (defun select-next-subchild () "Select the next subchild" (when (and (frame-p *current-child*) (frame-p (frame-selected-child *current-child*))) (setf *circulate-orig* (frame-child *current-child*) *circulate-parent* nil) (circulate-mode :subchild-direction +1))) (defun select-next-child-simple () "Select the next child (do not enter in circulate mode)" (when (frame-p *current-child*) (with-slots (child) *current-child* (setf child (rotate-list child))) (show-all-children))) (defun reorder-brother-simple (reorder-fun) (unless (child-equal-p *current-child* *current-root*) (no-focus) (select-current-frame nil) (let ((parent-frame (find-parent-frame *current-child*))) (when (frame-p parent-frame) (with-slots (child) parent-frame (setf child (funcall reorder-fun child) *current-child* (frame-selected-child parent-frame)))) (show-all-children t)))) (defun select-next-brother-simple () "Select the next brother frame (do not enter in circulate mode)" (reorder-brother-simple #'rotate-list)) (defun select-previous-brother-simple () "Select the previous brother frame (do not enter in circulate mode)" (reorder-brother-simple #'anti-rotate-list)) ;;; Spatial move functions (defun select-brother-generic-spatial-move (fun-found) "Select the nearest brother of the current child based on the fun-found function" (let ((is-root? (child-equal-p *current-child* *current-root*))) (when is-root? (leave-frame) (sleep *spatial-move-delay-before*)) (no-focus) (select-current-frame nil) (let ((parent-frame (find-parent-frame *current-child*))) (when (frame-p parent-frame) (with-slots (child selected-pos) parent-frame (let ((found nil) (found-dist nil)) (dolist (c child) (let ((dist (funcall fun-found *current-child* c))) (when (and dist (not (child-equal-p *current-child* c)) (or (not found) (and found-dist (< dist found-dist)))) (setf found c found-dist dist)))) (when found (setf *current-child* found selected-pos 0 child (cons found (child-remove found child))))))) (show-all-children t) (when is-root? (sleep *spatial-move-delay-after*) (enter-frame))))) (defun select-brother-spatial-move-right () "Select spatially the nearest brother of the current child in the right direction" (select-brother-generic-spatial-move #'(lambda (current child) (when (> (child-x2 child) (child-x2 current)) (distance (child-x2 current) (middle-child-y current) (child-x child) (middle-child-y child)))))) (defun select-brother-spatial-move-left () "Select spatially the nearest brother of the current child in the left direction" (select-brother-generic-spatial-move #'(lambda (current child) (when (< (child-x child) (child-x current)) (distance (child-x current) (middle-child-y current) (child-x2 child) (middle-child-y child)))))) (defun select-brother-spatial-move-down () "Select spatially the nearest brother of the current child in the down direction" (select-brother-generic-spatial-move #'(lambda (current child) (when (> (child-y2 child) (child-y2 current)) (distance (middle-child-x current) (child-y2 current) (middle-child-x child) (child-y child)))))) (defun select-brother-spatial-move-up () "Select spatially the nearest brother of the current child in the up direction" (select-brother-generic-spatial-move #'(lambda (current child) (when (< (child-y child) (child-y current)) (distance (middle-child-x current) (child-y current) (middle-child-x child) (child-y2 child)))))) clfswm-20111015.git51b0a02/src/clfswm-configuration.lisp000066400000000000000000000174101164636077000225530ustar00rootroot00000000000000;;; -------------------------------------------------------------------------- ;;; CLFSWM - FullScreen Window Manager ;;; ;;; -------------------------------------------------------------------------- ;;; Documentation: Configuration definitions and Menu generation ;;; ;;; -------------------------------------------------------------------------- ;;; ;;; (C) 2011 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;; ;;; -------------------------------------------------------------------------- (in-package :clfswm) (defun find-configuration-variables () (let ((all-groups nil) (all-variables nil)) (maphash (lambda (key val) (pushnew (configvar-group val) all-groups :test #'string-equal) (push (list key (configvar-group val)) all-variables)) *config-var-table*) (values all-groups all-variables))) (defun find-symbol-function (function) (with-all-internal-symbols (symbol :clfswm) (when (and (fboundp symbol) (equal (symbol-function symbol) function)) (return-from find-symbol-function symbol)))) (defun escape-conf-value (value) (cond ((or (equal value t) (equal value nil)) (format nil "~S" value)) ((consp value) (format nil "(quote ~S)" value)) ((symbolp value) (format nil "'~S" value)) ((functionp value) (format nil "'~S" (find-symbol-function value))) ((xlib:color-p value) (format nil "(->color #x~X)" (color->rgb value))) (t (format nil "~S" value)))) (defun escape-conf-symbol-value (symbol) (let ((value (symbol-value symbol))) (escape-conf-value value))) (defun get-config-value (value) (ignore-errors (eval (read-from-string value)))) (defun reset-config-to-default-value (symbol) (setf (symbol-value symbol) (config-default-value symbol))) ;;; Save configuration variables part (defun temp-conf-file-name () (let ((name (conf-file-name))) (make-pathname :directory (pathname-directory name) :name (concatenate 'string (pathname-name name) "-tmp")))) (defun copy-previous-conf-file-begin (stream-in stream-out) (loop for line = (read-line stream-in nil nil) while line until (zerop (or (search ";;; ### Internal variables definitions" line) -1)) do (format stream-out "~A~%" line))) (defun copy-previous-conf-file-end (stream-in stream-out) (loop for line = (read-line stream-in nil nil) while line until (zerop (or (search ";;; ### End of internal variables definitions" line) -1))) (loop for line = (read-line stream-in nil nil) while line do (format stream-out "~A~%" line))) (defun save-variables-in-conf-file (stream) (multiple-value-bind (all-groups all-variables) (find-configuration-variables) (format stream "~&;;; ### Internal variables definitions ### ;;;~%") (format stream ";;; ### You can edit this part when clfswm is not running ### ;;;~%") (format stream ";;; ### And you can remove this part to revert to the ### ;;;~%") (format stream ";;; ### original configuration variables values. ### ;;;~%") (format stream "(in-package :clfswm)~2%") (format stream "(setf~%") (dolist (group all-groups) (format stream " ;; ~A:~%" (config-group->string group)) (dolist (var all-variables) (unless (equal (escape-conf-symbol-value (first var)) (escape-conf-value (config-default-value (first var)))) (when (string-equal (second var) group) (format stream " ~A ~A~%" (first var) (escape-conf-symbol-value (first var)))))) (format stream "~%")) (format stream ")~%") (format stream ";;; ### End of internal variables definitions ### ;;;~%"))) (defun save-configuration-variables () "Save all configuration variables in clfswmrc" (let ((conffile (conf-file-name)) (tempfile (temp-conf-file-name))) (with-open-file (stream-in conffile :direction :input :if-does-not-exist :create) (with-open-file (stream-out tempfile :direction :output :if-exists :supersede) (copy-previous-conf-file-begin stream-in stream-out) (save-variables-in-conf-file stream-out) (copy-previous-conf-file-end stream-in stream-out))) (delete-file conffile) (rename-file tempfile conffile) nil)) ;;; Configuration menu definition (defun group->menu (group) (intern (string-upcase (format nil "conf-~A" group)) :clfswm)) (defun query-conf-value (var string original) (labels ((warn-wrong-type (result original) (if (equal (simple-type-of result) (simple-type-of original)) result (if (query-yes-or-no "~A and ~A are not of the same type (~A and ~A). Do you really want to use this value?" (escape-conf-value result) (escape-conf-value original) (type-of result) (type-of original)) result original))) (ask-set-default-value (original-val) (let ((default (config-default-value var))) (if (query-yes-or-no "Reset ~A from ~A to ~A?" var original (escape-conf-value default)) default original-val)))) (multiple-value-bind (result return) (query-string (format nil "Configure ~A - ~A (blank=Default: ~A)" string (documentation var 'variable) (escape-conf-value (config-default-value var))) original) (let ((original-val (get-config-value original))) (if (equal return :Return) (if (string= result "") (ask-set-default-value original-val) (let ((result-val (get-config-value result))) (warn-wrong-type result-val original-val))) original-val))))) (defun create-conf-function (var) (let* ((string (remove #\* (format nil "~A" var))) (symbol (intern (format nil "CONFIGURE-~A" string) :clfswm))) (setf (symbol-function symbol) (lambda () (setf (symbol-value var) (query-conf-value var string (escape-conf-symbol-value var))) (open-menu (find-menu 'configuration-menu))) (documentation symbol 'function) (format nil "Configure ~A" string)) symbol)) (defun create-configuration-menu (&key clear) "Configuration menu" (when clear (clear-sub-menu 'main 'configuration-menu)) (multiple-value-bind (all-groups all-variables) (find-configuration-variables) (loop for group in all-groups for i from 0 do (let ((menu (group->menu group))) (add-sub-menu 'configuration-menu (number->char i) menu (config-group->string group)) (loop for var in all-variables with j = -1 do (when (equal (second var) group) (add-menu-key menu (number->char (incf j)) (create-conf-function (first var)))))))) (add-menu-key 'configuration-menu "F2" 'save-configuration-variables) (add-menu-key 'configuration-menu "F3" 'reset-all-config-variables)) (defun reset-all-config-variables () "Reset all configuration variables to their default values" (when (query-yes-or-no "Do you really want to reset all values to their default?") (maphash (lambda (key val) (declare (ignore val)) (reset-config-to-default-value key)) *config-var-table*)) (open-menu (find-menu 'configuration-menu))) clfswm-20111015.git51b0a02/src/clfswm-corner.lisp000066400000000000000000000103651164636077000211760ustar00rootroot00000000000000;;; -------------------------------------------------------------------------- ;;; CLFSWM - FullScreen Window Manager ;;; ;;; -------------------------------------------------------------------------- ;;; Documentation: Corner functions ;;; -------------------------------------------------------------------------- ;;; ;;; (C) 2011 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;; ;;; -------------------------------------------------------------------------- (in-package :clfswm) (symbol-macrolet ((sw (xlib:screen-width *screen*)) (sh (xlib:screen-height *screen*)) (cs *corner-size*)) (defun in-corner (corner x y) "Return t if (x, y) is in corner. Corner is one of :bottom-right :bottom-left :top-right :top-left" (multiple-value-bind (xmin ymin xmax ymax) (case corner (:bottom-right (values (- sw cs) (- sh cs) sw sh)) (:bottom-left (values 0 (- sh cs) cs sh)) (:top-left (values 0 0 cs cs)) (:top-right (values (- sw cs) 0 sw cs)) (t (values 10 10 0 0))) (and (<= xmin x xmax) (<= ymin y ymax))))) (symbol-macrolet ((sw (xlib:screen-width *screen*)) (sh (xlib:screen-height *screen*)) (cs *corner-size*)) (defun find-corner (x y) (cond ((and (< cs x (- sw cs)) (< cs y (- sh cs))) nil) ((and (<= 0 x cs) (<= 0 y cs)) :top-left) ((and (<= (- sw cs) x sw) (<= 0 y cs)) :top-right) ((and (<= 0 x cs) (<= (- sh cs) y sh)) :bottom-left) ((and (<= (- sw cs) x sw) (<= (- sh cs) y sh)) :bottom-right) (t nil)))) (defun do-corner-action (x y corner-list) "Do the action associated with corner. The corner function must return T to stop the button event" (when (frame-p *current-root*) (let ((corner (find-corner x y))) (when corner (let ((fun (second (assoc corner corner-list)))) (when fun (funcall fun))))))) ;;;***************************************;;; ;;; CONFIG - Corner actions definitions: ;;; ;;;***************************************;;; (defun find-window-in-query-tree (target-win) (dolist (win (xlib:query-tree *root*)) (when (child-equal-p win target-win) (return t)))) (defun wait-window-in-query-tree (wait-test) (loop (dolist (win (xlib:query-tree *root*)) (when (funcall wait-test win) (return-from wait-window-in-query-tree win))))) (defun generic-present-body (cmd wait-test win &optional focus-p) (stop-button-event) (unless (find-window-in-query-tree win) (do-shell cmd) (setf win (wait-window-in-query-tree wait-test)) (grab-all-buttons win) (hide-window win)) (cond ((window-hidden-p win) (unhide-window win) (when focus-p (focus-window win)) (raise-window win)) (t (hide-window win) (show-all-children))) win) (let (win) (defun close-virtual-keyboard () (when win (xlib:destroy-window win) (xlib:display-finish-output *display*) (setf win nil))) (defun present-virtual-keyboard () "Present a virtual keyboard" (setf win (generic-present-body *virtual-keyboard-cmd* (lambda (win) (string-equal (xlib:get-wm-class win) "xvkbd")) win)) t)) (let (win) (defun equal-clfswm-terminal (window) (when win (xlib:window-equal window win))) (defun close-clfswm-terminal () (when win (xlib:destroy-window win) (xlib:display-finish-output *display*) (setf win nil))) (defun present-clfswm-terminal () "Hide/Unhide a terminal" (setf win (generic-present-body *clfswm-terminal-cmd* (lambda (win) (string-equal (xlib:wm-name win) *clfswm-terminal-name*)) win t)) t)) clfswm-20111015.git51b0a02/src/clfswm-expose-mode.lisp000066400000000000000000000206131164636077000221300ustar00rootroot00000000000000;;; -------------------------------------------------------------------------- ;;; CLFSWM - FullScreen Window Manager ;;; ;;; -------------------------------------------------------------------------- ;;; Documentation: Expose functions - An expose like. ;;; -------------------------------------------------------------------------- ;;; ;;; (C) 2011 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;; ;;; -------------------------------------------------------------------------- (in-package :clfswm) (defparameter *expose-font* nil) (defparameter *expose-windows-list* nil) (defparameter *expose-selected-child* nil) (defun leave-expose-mode () "Leave the expose mode" (throw 'exit-expose-loop nil)) (defun valid-expose-mode () "Valid the expose mode" (throw 'exit-expose-loop t)) (defun mouse-leave-expose-mode (window root-x root-y) "Leave the expose mode" (declare (ignore window root-x root-y)) (throw 'exit-expose-loop nil)) (defun mouse-valid-expose-mode (window root-x root-y) "Valid the expose mode" (declare (ignore window root-x root-y)) (throw 'exit-expose-loop t)) (define-handler expose-mode :key-press (code state) (funcall-key-from-code *expose-keys* code state)) (define-handler expose-mode :button-press (code state window root-x root-y) (funcall-button-from-code *expose-mouse* code state window root-x root-y *fun-press*)) (define-handler expose-mode :exposure () (expose-draw-letter)) (add-hook *binding-hook* 'set-default-expose-keys) (defun set-default-expose-keys () (define-expose-key ("Escape") 'leave-expose-mode) (define-expose-key ("g" :control) 'leave-expose-mode) (define-expose-key ("Escape" :alt) 'leave-expose-mode) (define-expose-key ("g" :control :alt) 'leave-expose-mode) (define-expose-key ("Return") 'valid-expose-mode) (define-expose-key ("space") 'valid-expose-mode) (define-expose-key ("Tab") 'valid-expose-mode) (define-expose-key ("Right") 'speed-mouse-right) (define-expose-key ("Left") 'speed-mouse-left) (define-expose-key ("Down") 'speed-mouse-down) (define-expose-key ("Up") 'speed-mouse-up) (define-expose-key ("Left" :control) 'speed-mouse-undo) (define-expose-key ("Up" :control) 'speed-mouse-first-history) (define-expose-key ("Down" :control) 'speed-mouse-reset) (define-expose-mouse (1) 'mouse-valid-expose-mode) (define-expose-mouse (2) 'mouse-leave-expose-mode) (define-expose-mouse (3) 'mouse-leave-expose-mode)) (defmacro define-expose-letter-keys () (labels ((produce-name (n) (symb "%" "expose-fun-key-" n "%"))) `(progn ,@(loop for n from 0 to 61 collect `(progn (defun ,(produce-name n) () ,(format nil "Select child '~A' (~A)" (number->string n) n) (let ((child (nth ,n *expose-windows-list*))) (when child (xlib:warp-pointer *root* (xlib:drawable-x (first child)) (xlib:drawable-y (first child))) (setf *expose-selected-child* (fourth child)) (when *expose-valid-on-key* (valid-expose-mode))))) (define-expose-key (,(number->string n)) ',(produce-name n))))))) (define-expose-letter-keys) (defun expose-draw-letter () (loop for lwin in *expose-windows-list* do (xlib:draw-glyphs (first lwin) (second lwin) (xlib:max-char-width *expose-font*) (+ (xlib:font-ascent *expose-font*) (xlib:font-descent *expose-font*)) (third lwin)))) (defun expose-create-window (child n) (let* ((*current-child* child) (string (format nil "~A~A" (number->string n) (if *expose-show-window-title* (format nil " - ~A" (ensure-printable (child-fullname child))) ""))) (width (if *expose-show-window-title* (min (* (xlib:max-char-width *expose-font*) (+ (length string) 2)) (- (child-width child) 4)) (* (xlib:max-char-width *expose-font*) 3))) (height (* (xlib:font-ascent *expose-font*) 2))) (with-placement (*expose-mode-placement* x y width height) (let* ((window (xlib:create-window :parent *root* :x x :y y :width width :height height :background (get-color *expose-background*) :border-width *border-size* :border (get-color *expose-border*) :colormap (xlib:screen-default-colormap *screen*) :event-mask '(:exposure :key-press))) (gc (xlib:create-gcontext :drawable window :foreground (get-color *expose-foreground*) :background (get-color *expose-background*) :font *expose-font* :line-style :solid))) (map-window window) (push (list window gc string child) *expose-windows-list*))))) (defun expose-mode-display-accel-windows () (let ((n -1)) (with-all-children-reversed (*current-root* child) (if (or (frame-p child) (managed-window-p child (find-parent-frame child *root-frame*))) (when (< n 61) (expose-create-window child (incf n))) (hide-child child)))) (setf *expose-windows-list* (nreverse *expose-windows-list*)) (expose-draw-letter)) (defun expose-windows-generic (first-restore-frame &optional body body-escape) (setf *expose-font* (xlib:open-font *display* *expose-font-string*) *expose-windows-list* nil *expose-selected-child* nil) (xlib:warp-pointer *root* (truncate (/ (xlib:screen-width *screen*) 2)) (truncate (/ (xlib:screen-height *screen*) 2))) (with-all-frames (first-restore-frame frame) (setf (frame-data-slot frame :old-layout) (frame-layout frame) (frame-layout frame) #'tile-space-layout)) (show-all-children t) (expose-mode-display-accel-windows) (let ((grab-keyboard-p (xgrab-keyboard-p)) (grab-pointer-p (xgrab-pointer-p))) (xgrab-pointer *root* 92 93) (unless grab-keyboard-p (ungrab-main-keys) (xgrab-keyboard *root*)) (if (generic-mode 'expose-mode 'exit-expose-loop :original-mode '(main-mode)) (multiple-value-bind (x y) (xlib:query-pointer *root*) (let* ((child (or *expose-selected-child* (find-child-under-mouse x y))) (parent (find-parent-frame child *root-frame*))) (when (and child parent) (pfuncall body parent) (focus-all-children child parent)))) (pfuncall body-escape)) (dolist (lwin *expose-windows-list*) (awhen (first lwin) (xlib:destroy-window it)) (awhen (second lwin) (xlib:free-gcontext it))) (when *expose-font* (xlib:close-font *expose-font*)) (setf *expose-windows-list* nil) (with-all-frames (first-restore-frame frame) (setf (frame-layout frame) (frame-data-slot frame :old-layout) (frame-data-slot frame :old-layout) nil)) (show-all-children t) (banish-pointer) (unless grab-keyboard-p (xungrab-keyboard) (grab-main-keys)) (if grab-pointer-p (xgrab-pointer *root* 66 67) (xungrab-pointer)) (wait-no-key-or-button-press)) t) (defun expose-windows-mode () "Present all windows in the current frame (An expose like)" (stop-button-event) (expose-windows-generic *current-root*)) (defun expose-all-windows-mode () "Present all windows in all frames (An expose like)" (stop-button-event) (let ((orig-root *current-root*)) (switch-to-root-frame :show-later t) (expose-windows-generic *root-frame* (lambda (parent) (setf *current-root* parent)) (lambda () (setf *current-root* orig-root))))) (defun expose-windows-current-child-mode () "Present all windows in the current child (An expose like)" (stop-button-event) (when (frame-p *current-child*) (let ((orig-root *current-root*)) (unless (child-equal-p *current-child* *current-root*) (setf *current-root* *current-child*)) (expose-windows-generic *current-root* (lambda (parent) (setf *current-root* parent)) (lambda () (setf *current-root* orig-root)))))) clfswm-20111015.git51b0a02/src/clfswm-generic-mode.lisp000066400000000000000000000037541164636077000222500ustar00rootroot00000000000000;;; -------------------------------------------------------------------------- ;;; CLFSWM - FullScreen Window Manager ;;; ;;; -------------------------------------------------------------------------- ;;; Documentation: Main functions ;;; -------------------------------------------------------------------------- ;;; ;;; (C) 2011 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;; ;;; -------------------------------------------------------------------------- (in-package :clfswm) (defun generic-mode (mode exit-tag &key enter-function loop-function leave-function (loop-hook *loop-hook*) original-mode) "Enter in a generic mode" (let ((last-mode *current-event-mode*)) (unassoc-keyword-handle-event) (when original-mode (dolist (add-mode (ensure-list original-mode)) (assoc-keyword-handle-event add-mode))) (assoc-keyword-handle-event mode) (nfuncall enter-function) (catch exit-tag (unwind-protect (loop (call-hook loop-hook) (process-timers) (nfuncall loop-function) (when (xlib:event-listen *display* *loop-timeout*) (xlib:process-event *display* :handler #'handle-event)) (xlib:display-finish-output *display*)) (nfuncall leave-function) (unassoc-keyword-handle-event) (assoc-keyword-handle-event last-mode))))) clfswm-20111015.git51b0a02/src/clfswm-info.lisp000066400000000000000000000510451164636077000206410ustar00rootroot00000000000000;;; -------------------------------------------------------------------------- ;;; CLFSWM - FullScreen Window Manager ;;; ;;; -------------------------------------------------------------------------- ;;; Documentation: Info function (see the end of this file for user definition ;;; -------------------------------------------------------------------------- ;;; ;;; (C) 2011 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;; ;;; -------------------------------------------------------------------------- (in-package :clfswm) (defstruct info window gc font list ilw ilh x y max-x max-y) (defparameter *info-selected-item* nil) (defun leave-info-mode (info) "Leave the info mode" (declare (ignore info)) (setf *info-selected-item* nil) (throw 'exit-info-loop nil)) (defun leave-info-mode-and-valid (info) "Leave the info mode and valid the selected item" (declare (ignore info)) (throw 'exit-info-loop nil)) (defun mouse-leave-info-mode (window root-x root-y info) "Leave the info mode" (declare (ignore window root-x root-y info)) (setf *info-selected-item* nil) (throw 'exit-info-loop nil)) (defun find-info-item-from-mouse (root-x root-y info) (if (< (xlib:drawable-x (info-window info)) root-x (+ (xlib:drawable-x (info-window info)) (xlib:drawable-width (info-window info)))) (truncate (/ (- (+ (- root-y (xlib:drawable-y (info-window info))) (xlib:max-char-ascent (info-font info)) (info-y info)) (info-ilh info)) (info-ilh info))) nil)) (defun set-info-item-form-mouse (root-x root-y info) (setf *info-selected-item* (find-info-item-from-mouse root-x root-y info))) (defun info-y-display-coords (info posy) (- (+ (* (info-ilh info) posy) (info-ilh info)) (info-y info))) (defun incf-info-selected-item (info n) (setf *info-selected-item* (min (if *info-selected-item* (+ *info-selected-item* n) 0) (1- (or (length (info-list info)) 1))))) (defun decf-info-selected-item (info n) (declare (ignore info)) (setf *info-selected-item* (max (if *info-selected-item* (- *info-selected-item* n) 0) 0))) (defun draw-info-window (info) (labels ((print-line (line posx posy &optional (color *info-foreground*)) (xlib:with-gcontext ((info-gc info) :foreground (get-color color) :background (if (equal posy *info-selected-item*) (get-color *info-selected-background*) (get-color *info-background*))) (xlib:draw-image-glyphs *pixmap-buffer* (info-gc info) (- (+ (info-ilw info) (* posx (info-ilw info))) (info-x info)) (info-y-display-coords info posy) (format nil "~A" line))) (+ posx (length line)))) (clear-pixmap-buffer (info-window info) (info-gc info)) (loop for line in (info-list info) for y from 0 do (typecase line (cons (typecase (first line) (cons (let ((posx 0)) (dolist (l line) (typecase l (cons (setf posx (print-line (first l) posx y (second l)))) (t (setf posx (print-line l posx y))))))) (t (print-line (first line) 0 y (second line))))) (t (print-line line 0 y)))) (copy-pixmap-buffer (info-window info) (info-gc info)))) ;;;,----- ;;;| Key binding ;;;`----- (add-hook *binding-hook* 'init-*info-keys* 'init-*info-mouse*) (defun set-default-info-keys () (define-info-key (#\q) 'leave-info-mode) (define-info-key ("Return") 'leave-info-mode-and-valid) (define-info-key ("space") 'leave-info-mode-and-valid) (define-info-key ("Escape") 'leave-info-mode) (define-info-key ("g" :control) 'leave-info-mode) (define-info-key ("twosuperior") (defun info-banish-pointer (info) "Move the pointer to the lower right corner of the screen" (declare (ignore info)) (banish-pointer))) (define-info-key ("Down") (defun info-next-line (info) "Move one line down" (incf-info-selected-item info 1) (when (> (info-y-display-coords info *info-selected-item*) (+ (xlib:drawable-y (info-window info)) (xlib:drawable-height (info-window info)))) (setf (info-y info) (min (+ (info-y info) (info-ilh info)) (info-max-y info)))) (draw-info-window info))) (define-info-key ("Up") (defun info-previous-line (info) "Move one line up" (decf-info-selected-item info 1) (when (< (info-y-display-coords info *info-selected-item*) (+ (xlib:drawable-y (info-window info)) (info-ilh info))) (setf (info-y info) (max (- (info-y info) (info-ilh info)) 0))) (draw-info-window info))) (define-info-key ("Left") (defun info-previous-char (info) "Move one char left" (setf (info-x info) (max (- (info-x info) (info-ilw info)) 0)) (draw-info-window info))) (define-info-key ("Right") (defun info-next-char (info) "Move one char right" (setf (info-x info) (min (+ (info-x info) (info-ilw info)) (info-max-x info))) (draw-info-window info))) (define-info-key ("Home") (defun info-first-line (info) "Move to first line" (setf (info-x info) 0 (info-y info) 0) (setf *info-selected-item* 0) (draw-info-window info))) (define-info-key ("End") (defun info-end-line (info) "Move to last line" (setf (info-x info) 0 (info-y info) (- (* (length (info-list info)) (info-ilh info)) (xlib:drawable-height (info-window info)))) (setf *info-selected-item* (1- (or (length (info-list info)) 1))) (draw-info-window info))) (define-info-key ("Page_Down") (defun info-next-ten-lines (info) "Move ten lines down" (incf-info-selected-item info 10) (when (> (info-y-display-coords info *info-selected-item*) (+ (xlib:drawable-y (info-window info)) (xlib:drawable-height (info-window info)))) (setf (info-y info) (min (+ (info-y info) (* (info-ilh info) 10)) (info-max-y info)))) (draw-info-window info))) (define-info-key ("Page_Up") (defun info-previous-ten-lines (info) "Move ten lines up" (decf-info-selected-item info 10) (when (< (info-y-display-coords info *info-selected-item*) (+ (xlib:drawable-y (info-window info)) (info-ilh info))) (setf (info-y info) (max (- (info-y info) (* (info-ilh info) 10)) 0))) (draw-info-window info)))) (add-hook *binding-hook* 'set-default-info-keys) (defparameter *info-start-grab-x* nil) (defparameter *info-start-grab-y* nil) (defun info-begin-grab (window root-x root-y info) "Begin grab text" (declare (ignore window)) (setf *info-start-grab-x* (min (max (+ root-x (info-x info)) 0) (info-max-x info)) *info-start-grab-y* (min (max (+ root-y (info-y info)) 0) (info-max-y info))) (draw-info-window info)) (defun info-end-grab (window root-x root-y info) "End grab" (declare (ignore window)) (setf (info-x info) (min (max (- *info-start-grab-x* root-x) 0) (info-max-x info)) (info-y info) (min (max (- *info-start-grab-y* root-y) 0) (info-max-y info)) *info-start-grab-x* nil *info-start-grab-y* nil) (draw-info-window info)) (defun info-mouse-next-line (window root-x root-y info) "Move one line down" (declare (ignore window)) (setf (info-y info) (min (+ (info-y info) (info-ilh info)) (info-max-y info))) (set-info-item-form-mouse root-x root-y info) (draw-info-window info)) (defun info-mouse-previous-line (window root-x root-y info) "Move one line up" (declare (ignore window)) (setf (info-y info) (max (- (info-y info) (info-ilh info)) 0)) (set-info-item-form-mouse root-x root-y info) (draw-info-window info)) (defun info-mouse-motion-drag (window root-x root-y info) "Grab text" (declare (ignore window)) (when (and *info-start-grab-x* *info-start-grab-y*) (setf (info-x info) (min (max (- *info-start-grab-x* root-x) 0) (info-max-x info)) (info-y info) (min (max (- *info-start-grab-y* root-y) 0) (info-max-y info))) (draw-info-window info))) (defun info-mouse-select-item (window root-x root-y info) (declare (ignore window)) (set-info-item-form-mouse root-x root-y info) (leave-info-mode-and-valid info)) (defun info-mouse-motion-click (window root-x root-y info) (declare (ignore window)) (let ((last *info-selected-item*)) (set-info-item-form-mouse root-x root-y info) (unless (equal last *info-selected-item*) (draw-info-window info)))) (defun set-default-info-mouse () (if *info-click-to-select* (define-info-mouse (1) nil 'info-mouse-select-item) (define-info-mouse (1) 'info-begin-grab 'info-end-grab)) (define-info-mouse (2) 'mouse-leave-info-mode) (define-info-mouse (3) 'mouse-leave-info-mode) (define-info-mouse (4) 'info-mouse-previous-line) (define-info-mouse (5) 'info-mouse-next-line) (if *info-click-to-select* (define-info-mouse ('motion) 'info-mouse-motion-click nil) (define-info-mouse ('motion) 'info-mouse-motion-drag nil))) (add-hook *binding-hook* 'set-default-info-mouse) (let (info) (define-handler info-mode :key-press (code state) (funcall-key-from-code *info-keys* code state info)) (define-handler info-mode :motion-notify (window root-x root-y) (unless (compress-motion-notify) (funcall-button-from-code *info-mouse* 'motion (modifiers->state *default-modifiers*) window root-x root-y *fun-press* (list info)))) (define-handler info-mode :button-press (window root-x root-y code state) (funcall-button-from-code *info-mouse* code state window root-x root-y *fun-press* (list info))) (define-handler info-mode :button-release (window root-x root-y code state) (funcall-button-from-code *info-mouse* code state window root-x root-y *fun-release* (list info))) (defun info-mode (info-list &key (width nil) (height nil)) "Open the info mode. Info-list is a list of info: One string per line Or for colored output: a list (line_string color) Or ((1_word color) (2_word color) 3_word (4_word color)...)" (when info-list (setf *info-selected-item* 0) (labels ((compute-size (line) (typecase line (cons (typecase (first line) (cons (let ((val 0)) (dolist (l line val) (incf val (typecase l (cons (length (first l))) (t (length l))))))) (t (length (first line))))) (t (length line))))) (let* ((font (xlib:open-font *display* *info-font-string*)) (ilw (xlib:max-char-width font)) (ilh (+ (xlib:max-char-ascent font) (xlib:max-char-descent font) 1)) (width (or width (min (* (+ (loop for l in info-list maximize (compute-size l)) 2) ilw) (xlib:screen-width *screen*)))) (height (or height (min (round (+ (* (length info-list) ilh) (/ ilh 2))) (xlib:screen-height *screen*))))) (with-placement (*info-mode-placement* x y width height) (let* ((pointer-grabbed-p (xgrab-pointer-p)) (keyboard-grabbed-p (xgrab-keyboard-p)) (window (xlib:create-window :parent *root* :x x :y y :width width :height height :background (get-color *info-background*) :colormap (xlib:screen-default-colormap *screen*) :border-width *border-size* :border (get-color *info-border*) :event-mask '(:exposure))) (gc (xlib:create-gcontext :drawable window :foreground (get-color *info-foreground*) :background (get-color *info-background*) :font font :line-style :solid))) (setf info (make-info :window window :gc gc :x 0 :y 0 :list info-list :font font :ilw ilw :ilh ilh :max-x (* (loop for l in info-list maximize (compute-size l)) ilw) :max-y (* (length info-list) ilh))) (map-window window) (draw-info-window info) (xgrab-pointer *root* 68 69) (unless keyboard-grabbed-p (xgrab-keyboard *root*)) (wait-no-key-or-button-press) (generic-mode 'info-mode 'exit-info-loop :loop-function (lambda () (raise-window (info-window info))) :original-mode '(main-mode)) (if pointer-grabbed-p (xgrab-pointer *root* 66 67) (xungrab-pointer)) (unless keyboard-grabbed-p (xungrab-keyboard)) (xlib:free-gcontext gc) (xlib:destroy-window window) (xlib:close-font font) (xlib:display-finish-output *display*) (display-all-frame-info) (wait-no-key-or-button-press) *info-selected-item*))))))) (defun info-mode-menu (item-list &key (width nil) (height nil)) "Open an info help menu. Item-list is: '((key function) separator (key function)) or with explicit docstring: '((key function \"documentation 1\") (key function \"bla bla\") (key function)) key is a character, a keycode or a keysym Separator is a string or a symbol (all but a list) Function can be a function or a list (function color) for colored output" (let ((info-list nil) (action nil) (old-info-keys (copy-hash-table *info-keys*))) (labels ((define-key (key function) (define-info-key-fun (list key) (lambda (&optional args) (declare (ignore args)) (setf action function) (leave-info-mode nil))))) (dolist (item item-list) (typecase item (cons (destructuring-bind (key function explicit-doc) (ensure-n-elems item 3) (typecase function (cons (push (list (list (format nil "~A" key) *menu-color-menu-key*) (list (format nil ": ~A" (or explicit-doc (documentation (first function) 'function))) (second function))) info-list) (define-key key (first function))) (t (push (list (list (format nil "~A" key) *menu-color-key*) (format nil ": ~A" (or explicit-doc (documentation function 'function)))) info-list) (define-key key function))))) (t (push (list (format nil "-=- ~A -=-" item) *menu-color-comment*) info-list)))) (let ((selected-item (info-mode (nreverse info-list) :width width :height height))) (setf *info-keys* old-info-keys) (when selected-item (awhen (nth selected-item item-list) (when (consp it) (destructuring-bind (key function explicit-doc) (ensure-n-elems it 3) (declare (ignore key explicit-doc)) (typecase function (cons (setf action (first function))) (t (setf action function))))))) (typecase action (function (funcall action)) (symbol (when (fboundp action) (funcall action)))))))) (defun keys-from-list (list) "Produce a key menu based on list item" (loop for l in list for i from 0 collect (list (number->char i) l))) ;;;,----- ;;;| CONFIG - Info mode functions ;;;`----- (defun key-binding-colorize-line (list) (loop :for line :in list :collect (cond ((search "* CLFSWM Keys *" line) (list line *info-color-title*)) ((search "---" line) (list line *info-color-underline*)) ((begin-with-2-spaces line) (list (list (subseq line 0 22) *info-color-second*) (list (subseq line 22 35) *info-color-first*) (subseq line 35))) (t line)))) (defun show-key-binding (&rest hash-table-key) "Show the binding of each hash-table-key. Pass the :no-producing-doc symbol to remove the producing doc" (info-mode (key-binding-colorize-line (split-string (append-newline-space (with-output-to-string (stream) (produce-doc (remove :no-producing-doc hash-table-key) stream (not (member :no-producing-doc hash-table-key))))) #\Newline)))) (defun show-global-key-binding () "Show all key binding" (show-key-binding *main-keys* *main-mouse* *second-keys* *second-mouse* *info-keys* *info-mouse*)) (defun show-main-mode-key-binding () "Show the main mode binding" (show-key-binding *main-keys* *main-mouse*)) (defun show-second-mode-key-binding () "Show the second mode key binding" (show-key-binding *second-keys* *second-mouse*)) (defun show-circulate-mode-key-binding () "Show the circulate mode key binding" (show-key-binding *circulate-keys*)) (defun show-expose-window-mode-key-binding () "Show the expose window mode key binding" (show-key-binding *expose-keys* *expose-mouse*)) (defun show-first-aid-kit () "Show the first aid kit key binding" (labels ((add-key (hash symbol &optional (hashkey *main-keys*)) (multiple-value-bind (k v) (find-in-hash symbol hashkey) (setf (gethash k hash) v)))) (let ((hash (make-hash-table :test #'equal)) (hash-second (make-hash-table :test #'equal))) (setf (gethash 'name hash) "First aid kit - Main mode key binding" (gethash 'name hash-second) "First aid kit - Second mode key binding") (add-key hash 'select-next-child) (add-key hash 'select-previous-child) (add-key hash 'select-next-brother) (add-key hash 'select-previous-brother) (add-key hash 'select-previous-level) (add-key hash 'select-next-level) (add-key hash 'enter-frame) (add-key hash 'leave-frame) (add-key hash 'second-key-mode) (add-key hash 'expose-windows-mode) (add-key hash 'expose-all-windows-mode) (add-key hash 'present-clfswm-terminal) (add-key hash-second 'leave-second-mode *second-keys*) (add-key hash-second 'open-menu *second-keys*) (add-key hash-second 'run-program-from-query-string *second-keys*) (add-key hash-second 'eval-from-query-string *second-keys*) (add-key hash-second 'set-open-in-new-frame-in-parent-frame-nw-hook *second-keys*) (add-key hash-second 'b-start-xterm *second-keys*) (add-key hash-second 'b-start-emacs *second-keys*) (show-key-binding hash hash-second :no-producing-doc)))) (defun corner-help-colorize-line (list) (loop :for line :in list :collect (cond ((search "CLFSWM:" line) (list line *info-color-title*)) ((search "*:" line) (list line *info-color-underline*)) ((begin-with-2-spaces line) (let ((pos (position #\: line))) (if pos (list (list (subseq line 0 (1+ pos)) *info-color-first*) (subseq line (1+ pos))) line))) (t line)))) (defun show-corner-help () "Help on clfswm corner" (info-mode (corner-help-colorize-line (split-string (append-newline-space (with-output-to-string (stream) (produce-corner-doc stream))) #\Newline)))) (defun configuration-variable-colorize-line (list) (loop :for line :in list :collect (cond ((search "CLFSWM " line) (list line *info-color-title*)) ((search "* =" line) (let ((pos (position #\= line))) (list (list (subseq line 0 (1+ pos)) *info-color-first*) (list (subseq line (1+ pos)) *info-color-second*)))) ((search "<=" line) (list line *info-color-underline*)) (t line)))) (defun show-config-variable () "Show all configurable variables" (let ((result nil)) (labels ((rec () (setf result nil) (info-mode-menu (loop :for group :in (config-all-groups) :for i :from 0 :collect (list (number->char i) (let ((group group)) (lambda () (setf result group))) (config-group->string group)))) (when result (info-mode (configuration-variable-colorize-line (split-string (append-newline-space (with-output-to-string (stream) (produce-conf-var-doc stream result t nil))) #\Newline))) (rec)))) (rec)))) (defun show-date () "Show the current time and date" (info-mode (list (list `("Current date:" ,*menu-color-comment*) (date-string))))) (defun info-on-shell (msg program) (let ((lines (do-shell program nil t))) (info-mode (append (list (list msg *menu-color-comment*)) (loop for line = (read-line lines nil nil) while line collect line))))) (defun show-cpu-proc () "Show current processes sorted by CPU usage" (info-on-shell "Current processes sorted by CPU usage:" "ps --cols=1000 --sort='-%cpu,uid,pgid,ppid,pid' -e -o user,pid,stime,pcpu,pmem,args")) (defun show-mem-proc () "Show current processes sorted by memory usage" (info-on-shell "Current processes sorted by MEMORY usage:" "ps --cols=1000 --sort='-vsz,uid,pgid,ppid,pid' -e -o user,pid,stime,pcpu,pmem,args")) (defun show-cd-info () "Show the current CD track" (info-on-shell "Current CD track:" "pcd i")) (defun show-cd-playlist () "Show the current CD playlist" (info-on-shell "Current CD playlist:" "pcd mi")) (defun show-version () "Show the current CLFSWM version" (info-mode (list *version*))) clfswm-20111015.git51b0a02/src/clfswm-internal.lisp000066400000000000000000001220311164636077000215140ustar00rootroot00000000000000;; -------------------------------------------------------------------------- ;;; CLFSWM - FullScreen Window Manager ;;; ;;; -------------------------------------------------------------------------- ;;; Documentation: Main functions ;;; -------------------------------------------------------------------------- ;;; ;;; (C) 2011 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;; ;;; -------------------------------------------------------------------------- (in-package :clfswm) ;;; Conversion functions ;;; Float -> Pixel conversion (defun x-fl->px (x parent) "Convert float X coordinate to pixel" (round (+ (* x (frame-rw parent)) (frame-rx parent)))) (defun y-fl->px (y parent) "Convert float Y coordinate to pixel" (round (+ (* y (frame-rh parent)) (frame-ry parent)))) (defun w-fl->px (w parent) "Convert float Width coordinate to pixel" (round (* w (frame-rw parent)))) (defun h-fl->px (h parent) "Convert float Height coordinate to pixel" (round (* h (frame-rh parent)))) ;;; Pixel -> Float conversion (defun x-px->fl (x parent) "Convert pixel X coordinate to float" (/ (- x (frame-rx parent) *border-size*) (frame-rw parent))) (defun y-px->fl (y parent) "Convert pixel Y coordinate to float" (/ (- y (frame-ry parent) *border-size*) (frame-rh parent))) (defun w-px->fl (w parent) "Convert pixel Width coordinate to float" (/ w (frame-rw parent))) (defun h-px->fl (h parent) "Convert pixel Height coordinate to float" (/ h (frame-rh parent))) (defun rect-hidden-p (rect1 rect2) "Return T if child-rect1 hide child-rect2" (and (<= (child-rect-x rect1) (child-rect-x rect2)) (<= (child-rect-y rect1) (child-rect-y rect2)) (>= (+ (child-rect-x rect1) (child-rect-w rect1)) (+ (child-rect-x rect2) (child-rect-w rect2))) (>= (+ (child-rect-y rect1) (child-rect-h rect1)) (+ (child-rect-y rect2) (child-rect-h rect2))))) (defgeneric frame-p (frame)) (defmethod frame-p ((frame frame)) (declare (ignore frame)) t) (defmethod frame-p (frame) (declare (ignore frame)) nil) ;;; in-*: Find if point (x,y) is in frame, window or child (defun in-frame (frame x y) (and (frame-p frame) (<= (frame-rx frame) x (+ (frame-rx frame) (frame-rw frame))) (<= (frame-ry frame) y (+ (frame-ry frame) (frame-rh frame))))) (defun in-window (window x y) (and (xlib:window-p window) (<= (xlib:drawable-x window) x (+ (xlib:drawable-x window) (xlib:drawable-width window))) (<= (xlib:drawable-y window) y (+ (xlib:drawable-y window) (xlib:drawable-height window))))) (defgeneric in-child (child x y)) (defmethod in-child ((child frame) x y) (in-frame child x y)) (defmethod in-child ((child xlib:window) x y) (in-window child x y)) (defmethod in-child (child x y) (declare (ignore child x y)) nil) (defun frame-selected-child (frame) (when (frame-p frame) (with-slots (child selected-pos) frame (let ((len (length child))) (cond ((minusp selected-pos) (setf selected-pos 0)) ((>= selected-pos len) (setf selected-pos (max (1- len) 0))))) (nth selected-pos child)))) (defgeneric child-equal-p (child-1 child-2)) (defmethod child-equal-p ((child-1 xlib:window) (child-2 xlib:window)) (xlib:window-equal child-1 child-2)) (defmethod child-equal-p ((child-1 frame) (child-2 frame)) (equal child-1 child-2)) (defmethod child-equal-p (child-1 child-2) (declare (ignore child-1 child-2)) nil) (declaim (inline child-member child-remove child-position)) (defun child-member (child list) (member child list :test #'child-equal-p)) (defun child-remove (child list) (remove child list :test #'child-equal-p)) (defun child-position (child list) (position child list :test #'child-equal-p)) ;;; Frame data manipulation functions (defun frame-data-slot (frame slot) "Return the value associated to data slot" (when (frame-p frame) (second (assoc slot (frame-data frame))))) (defun set-frame-data-slot (frame slot value) "Set the value associated to data slot" (when (frame-p frame) (with-slots (data) frame (setf data (remove (assoc slot data) data)) (push (list slot value) data)) value)) (defsetf frame-data-slot set-frame-data-slot) (defun remove-frame-data-slot (frame slot) "Remove a slot in frame data slots" (when (frame-p frame) (with-slots (data) frame (setf data (remove (assoc slot data) data))))) (defun managed-window-p (window frame) "Return t only if window is managed by frame" (if (frame-p frame) (with-slots ((managed forced-managed-window) (unmanaged forced-unmanaged-window)) frame (and (xlib:window-p window) (not (child-member window unmanaged)) (not (member (xlib:wm-name window) unmanaged :test #'string-equal-p)) (or (member :all (frame-managed-type frame)) (member (window-type window) (frame-managed-type frame)) (child-member window managed) (member (xlib:wm-name window) managed :test #'string-equal-p)))) t)) (defun never-managed-window-p (window) (when (xlib:window-p window) (dolist (type *never-managed-window-list*) (when (funcall (first type) window) (return (values t (second type))))))) (defgeneric child-name (child)) (defmethod child-name ((child xlib:window)) (xlib:wm-name child)) (defmethod child-name ((child frame)) (frame-name child)) (defmethod child-name (child) (declare (ignore child)) "???") (defgeneric set-child-name (child name)) (defmethod set-child-name ((child xlib:window) name) (setf (xlib:wm-name child) name)) (defmethod set-child-name ((child frame) name) (setf (frame-name child) name)) (defmethod set-child-name (child name) (declare (ignore child name))) (defsetf child-name set-child-name) (defgeneric child-fullname (child)) (defmethod child-fullname ((child xlib:window)) (format nil "~A (~A)" (or (xlib:wm-name child) "?") (or (xlib:get-wm-class child) "?"))) (defmethod child-fullname ((child frame)) (aif (frame-name child) (format nil "~A (Frame ~A)" it (frame-number child)) (format nil "Frame ~A" (frame-number child)))) (defmethod child-fullname (child) (declare (ignore child)) "???") (defgeneric child-x (child)) (defmethod child-x ((child xlib:window)) (xlib:drawable-x child)) (defmethod child-x ((child frame)) (frame-rx child)) (defgeneric child-y (child)) (defmethod child-y ((child xlib:window)) (xlib:drawable-y child)) (defmethod child-y ((child frame)) (frame-ry child)) (defgeneric child-width (child)) (defmethod child-width ((child xlib:window)) (xlib:drawable-width child)) (defmethod child-width ((child frame)) (frame-rw child)) (defgeneric child-height (child)) (defmethod child-height ((child xlib:window)) (xlib:drawable-height child)) (defmethod child-height ((child frame)) (frame-rh child)) (defgeneric child-x2 (child)) (defmethod child-x2 ((child xlib:window)) (+ (xlib:drawable-x child) (xlib:drawable-width child))) (defmethod child-x2 ((child frame)) (+ (frame-rx child) (frame-rw child))) (defgeneric child-y2 (child)) (defmethod child-y2 ((child xlib:window)) (+ (xlib:drawable-y child) (xlib:drawable-height child))) (defmethod child-y2 ((child frame)) (+ (frame-ry child) (frame-rh child))) (defgeneric child-center (child)) (defmethod child-center ((child xlib:window)) (values (+ (xlib:drawable-x child) (/ (xlib:drawable-width child) 2)) (+ (xlib:drawable-y child) (/ (xlib:drawable-height child) 2)))) (defmethod child-center ((child frame)) (values (+ (frame-rx child) (/ (frame-rw child) 2)) (+ (frame-ry child) (/ (frame-rh child) 2)))) (defun child-distance (child1 child2) (multiple-value-bind (x1 y1) (child-center child1) (multiple-value-bind (x2 y2) (child-center child2) (values (+ (abs (- x2 x1)) (abs (- y2 y1))) (- x2 x1) (- y2 y1))))) (defun middle-child-x (child) (+ (child-x child) (/ (child-width child) 2))) (defun middle-child-y (child) (+ (child-y child) (/ (child-height child) 2))) (declaim (inline adj-border-xy adj-border-wh)) (defgeneric adj-border-xy (value child)) (defgeneric adj-border-wh (value child)) (defmethod adj-border-xy (v (child xlib:window)) (+ v (xlib:drawable-border-width child))) (defmethod adj-border-xy (v (child frame)) (+ v (xlib:drawable-border-width (frame-window child)))) (defmethod adj-border-wh (v (child xlib:window)) (- v (* (xlib:drawable-border-width child) 2))) (defmethod adj-border-wh (v (child frame)) (- v (* (xlib:drawable-border-width (frame-window child)) 2))) (declaim (inline anti-adj-border-xy anti-adj-border-wh)) (defgeneric anti-adj-border-xy (value child)) (defgeneric anti-adj-border-wh (value child)) (defmethod anti-adj-border-xy (v (child xlib:window)) (- v (xlib:drawable-border-width child))) (defmethod anti-adj-border-xy (v (child frame)) (- v (xlib:drawable-border-width (frame-window child)))) (defmethod anti-adj-border-wh (v (child xlib:window)) (+ v (* (xlib:drawable-border-width child) 2))) (defmethod anti-adj-border-wh (v (child frame)) (+ v (* (xlib:drawable-border-width (frame-window child)) 2))) (defmacro with-focus-window ((window) &body body) `(let ((,window (xlib:input-focus *display*))) (when (and ,window (not (xlib:window-equal ,window *no-focus-window*))) ,@body))) (defgeneric rename-child (child name)) (defmethod rename-child ((child frame) name) (setf (frame-name child) name) (display-frame-info child)) (defmethod rename-child ((child xlib:window) name) (setf (xlib:wm-name child) name)) (defmethod rename-child (child name) (declare (ignore child name))) (defun is-in-current-child-p (child) (and (frame-p *current-child*) (child-member child (frame-child *current-child*)))) ;; (with-all-children (*root-frame* child) (typecase child (xlib:window (print child)) (frame (print (frame-number child))))) (defmacro with-all-children ((root child) &body body) (let ((rec (gensym)) (sub-child (gensym))) `(block nil (labels ((,rec (,child) ,@body (when (frame-p ,child) (dolist (,sub-child (reverse (frame-child ,child))) (,rec ,sub-child))))) (,rec ,root))))) ;; (with-all-children (*root-frame* child) (typecase child (xlib:window (print child)) (frame (print (frame-number child))))) (defmacro with-all-children-reversed ((root child) &body body) (let ((rec (gensym)) (sub-child (gensym))) `(block nil (labels ((,rec (,child) ,@body (when (frame-p ,child) (dolist (,sub-child (frame-child ,child)) (,rec ,sub-child))))) (,rec ,root))))) ;; (with-all-frames (*root-frame* frame) (print (frame-number frame))) (defmacro with-all-frames ((root frame) &body body) (let ((rec (gensym)) (child (gensym))) `(block nil (labels ((,rec (,frame) (when (frame-p ,frame) ,@body (dolist (,child (reverse (frame-child ,frame))) (,rec ,child))))) (,rec ,root))))) ;; (with-all-windows (*root-frame* window) (print window)) (defmacro with-all-windows ((root window) &body body) (let ((rec (gensym)) (child (gensym))) `(block nil (labels ((,rec (,window) (when (xlib:window-p ,window) ,@body) (when (frame-p ,window) (dolist (,child (reverse (frame-child ,window))) (,rec ,child))))) (,rec ,root))))) ;; (with-all-frames-windows (*root-frame* child) (print child) (print (frame-number child))) (defmacro with-all-windows-frames ((root child) body-window body-frame) (let ((rec (gensym)) (sub-child (gensym))) `(block nil (labels ((,rec (,child) (typecase ,child (xlib:window ,body-window) (frame ,body-frame (dolist (,sub-child (reverse (frame-child ,child))) (,rec ,sub-child)))))) (,rec ,root))))) (defmacro with-all-windows-frames-and-parent ((root child parent) body-window body-frame) (let ((rec (gensym)) (sub-child (gensym))) `(block nil (labels ((,rec (,child ,parent) (typecase ,child (xlib:window ,body-window) (frame ,body-frame (dolist (,sub-child (reverse (frame-child ,child))) (,rec ,sub-child ,child)))))) (,rec ,root nil))))) (defun create-frame-window () (xlib:create-window :parent *root* :x 0 :y 0 :width 200 :height 200 :background (get-color *frame-background*) :colormap (xlib:screen-default-colormap *screen*) :border-width *border-size* :border (get-color *color-selected*) :event-mask '(:exposure :button-press :button-release :pointer-motion :enter-window))) (defun create-frame-gc (window) (xlib:create-gcontext :drawable window :foreground (get-color *frame-foreground*) :background (get-color *frame-background*) :font *default-font* :line-style :solid)) (defun destroy-all-frames-window () (with-all-frames (*root-frame* frame) (when (frame-gc frame) (xlib:free-gcontext (frame-gc frame)) (setf (frame-gc frame) nil)) (when (frame-window frame) (xlib:destroy-window (frame-window frame)) (setf (frame-window frame) nil)))) (defun create-all-frames-window () (with-all-frames (*root-frame* frame) (unless (frame-window frame) (setf (frame-window frame) (create-frame-window))) (unless (frame-gc frame) (setf (frame-gc frame) (create-frame-gc (frame-window frame))))) (with-all-frames (*root-frame* frame) (dolist (child (frame-child frame)) (handler-case (dbg (child-fullname child)) (error (c) (setf (frame-child frame) (remove child (frame-child frame) :test #'child-equal-p)) (dbg c child)))))) (defun frame-find-free-number () (let ((all-numbers nil)) (with-all-frames (*root-frame* frame) (pushnew (frame-number frame) all-numbers)) (find-free-number all-numbers))) (defun create-frame (&rest args &key (number (frame-find-free-number)) &allow-other-keys) (let* ((window (create-frame-window)) (gc (create-frame-gc window))) (apply #'make-instance 'frame :number number :window window :gc gc args))) (defun add-frame (frame parent) (push frame (frame-child parent)) frame) (defun place-frame (frame parent prx pry prw prh) "Place a frame from real (pixel) coordinates" (when (and (frame-p frame) (frame-p parent)) (with-slots (window x y w h) frame (setf (xlib:drawable-x window) prx (xlib:drawable-y window) pry (xlib:drawable-width window) prw (xlib:drawable-height window) prh x (x-px->fl prx parent) y (y-px->fl pry parent) w (w-px->fl prw parent) h (h-px->fl prh parent)) (xlib:display-finish-output *display*)))) (defun fixe-real-size (frame parent) "Fixe real (pixel) coordinates in float coordinates" (when (frame-p frame) (with-slots (x y w h rx ry rw rh) frame (setf x (x-px->fl rx parent) y (y-px->fl ry parent) w (w-px->fl (anti-adj-border-wh rw parent) parent) h (h-px->fl (anti-adj-border-wh rh parent) parent))))) (defun fixe-real-size-current-child () "Fixe real (pixel) coordinates in float coordinates for children in the current child" (when (frame-p *current-child*) (dolist (child (frame-child *current-child*)) (fixe-real-size child *current-child*)))) (defun find-child (to-find root) "Find to-find in root or in its children" (with-all-children (root child) (when (child-equal-p child to-find) (return-from find-child t)))) (defmacro with-find-in-all-frames (test &optional return-value) `(let (ret) (block return-block (with-all-frames (root frame) (when ,test (if first-foundp (return-from return-block (or ,return-value frame)) (setf ret frame)))) (or ,return-value ret)))) (defun find-parent-frame (to-find &optional (root *root-frame*) first-foundp) "Return the parent frame of to-find" (with-find-in-all-frames (child-member to-find (frame-child frame)))) (defun find-frame-window (window &optional (root *root-frame*) first-foundp) "Return the frame with the window window" (with-find-in-all-frames (xlib:window-equal window (frame-window frame)))) (defun find-frame-by-name (name &optional (root *root-frame*) first-foundp) "Find a frame from its name" (when name (with-find-in-all-frames (string-equal name (frame-name frame))))) (defun find-frame-by-number (number &optional (root *root-frame*) first-foundp) "Find a frame from its number" (when (numberp number) (with-find-in-all-frames (= number (frame-number frame))))) (defun find-child-in-parent (child base) "Return t if child is in base or in its parents" (labels ((rec (base) (when (child-equal-p child base) (return-from find-child-in-parent t)) (let ((parent (find-parent-frame base))) (when parent (rec parent))))) (rec base))) (defun get-all-windows (&optional (root *root-frame*)) "Return all windows in root and in its children" (let ((acc nil)) (with-all-windows (root window) (push window acc)) acc)) (defun get-hidden-windows () "Return all hiddens windows" (let ((all-windows (get-all-windows)) (hidden-windows (remove-if-not #'window-hidden-p (copy-list (xlib:query-tree *root*))))) (set-difference hidden-windows all-windows))) ;;; Current window utilities (defun get-current-window () (typecase *current-child* (xlib:window *current-child*) (frame (frame-selected-child *current-child*)))) (defmacro with-current-window (&body body) "Bind 'window' to the current window" `(let ((window (get-current-window))) (when (xlib:window-p window) ,@body))) (defun get-first-window () (typecase *current-child* (xlib:window *current-child*) (frame (or (first (frame-child *current-child*)) *current-child*)))) (defun display-frame-info (frame) (when (frame-p frame) (let ((dy (+ (xlib:max-char-ascent *default-font*) (xlib:max-char-descent *default-font*)))) (with-slots (name number gc window child hidden-children) frame (setf (xlib:gcontext-background gc) (get-color *frame-background*) (xlib:window-background window) (get-color *frame-background*)) (clear-pixmap-buffer window gc) (setf (xlib:gcontext-foreground gc) (get-color (if (and (child-equal-p frame *current-root*) (child-equal-p frame *current-child*)) *frame-foreground-root* *frame-foreground*))) (xlib:draw-glyphs *pixmap-buffer* gc 5 dy (format nil "Frame: ~A~A" number (if name (format nil " - ~A" name) ""))) (let ((pos dy)) (when (child-equal-p frame *current-root*) (when *child-selection* (xlib:draw-glyphs *pixmap-buffer* gc 5 (incf pos dy) (with-output-to-string (str) (format str " Selection: ") (dolist (child *child-selection*) (typecase child (xlib:window (format str " ~A " (xlib:wm-name child))) (frame (format str " frame:~A[~A] " (frame-number child) (aif (frame-name child) it ""))))))))) (dolist (ch child) (xlib:draw-glyphs *pixmap-buffer* gc 5 (incf pos dy) (format nil " ~A" (ensure-printable (child-fullname ch)))))) (copy-pixmap-buffer window gc) (values t t))))) (defun display-all-frame-info (&optional (root *current-root*)) (with-all-frames (root frame) (display-frame-info frame))) (defun get-parent-layout (child parent) (if (child-equal-p child *current-root*) (get-fullscreen-size) (if (or (frame-p child) (managed-window-p child parent)) (if (frame-p parent) (aif (frame-layout parent) (funcall it child parent) (no-layout child parent)) (get-fullscreen-size)) (values (xlib:drawable-x child) (xlib:drawable-y child) (xlib:drawable-width child) (xlib:drawable-height child))))) (defgeneric adapt-child-to-parent (child parent)) (defmethod adapt-child-to-parent ((window xlib:window) parent) (when (managed-window-p window parent) (multiple-value-bind (nx ny nw nh) (get-parent-layout window parent) (setf nw (max nw 1) nh (max nh 1)) (let ((change (or (/= (xlib:drawable-x window) nx) (/= (xlib:drawable-y window) ny) (/= (xlib:drawable-width window) nw) (/= (xlib:drawable-height window) nh)))) (when change (setf (xlib:drawable-x window) nx (xlib:drawable-y window) ny (xlib:drawable-width window) nw (xlib:drawable-height window) nh)) change)))) (defmethod adapt-child-to-parent ((frame frame) parent) (declare (ignore parent)) (with-slots (rx ry rw rh window) frame (let ((change (or (/= (xlib:drawable-x window) rx) (/= (xlib:drawable-y window) ry) (/= (xlib:drawable-width window) rw) (/= (xlib:drawable-height window) rh)))) (when change (setf (xlib:drawable-x window) rx (xlib:drawable-y window) ry (xlib:drawable-width window) rw (xlib:drawable-height window) rh)) change))) (defmethod adapt-child-to-parent (child parent) (declare (ignore child parent)) nil) (defgeneric set-child-stack-order (window child) (:documentation "Raise window if child is NIL else put window just below child")) (defmethod set-child-stack-order (window (child xlib:window)) (lower-window window child)) (defmethod set-child-stack-order (window (child frame)) (lower-window window (frame-window child))) (defmethod set-child-stack-order (window child) (declare (ignore child)) (raise-window window)) (defgeneric show-child (child parent previous)) (defmethod show-child ((frame frame) parent previous) (declare (ignore parent)) (with-slots (window show-window-p) frame (if (and show-window-p (or *show-root-frame-p* (not (child-equal-p frame *current-root*)))) (progn (map-window window) (set-child-stack-order window previous) (display-frame-info frame)) (hide-window window)))) (defun hide-unmanaged-window-p (parent) (let ((action (frame-data-slot parent :unmanaged-window-action))) (case action (:hide t) (:show nil) (t *hide-unmanaged-window*)))) (defmethod show-child ((window xlib:window) parent previous) (if (or (managed-window-p window parent) (child-equal-p window *current-child*) (not (hide-unmanaged-window-p parent)) (child-equal-p parent *current-child*)) (progn (map-window window) (set-child-stack-order window previous)) (hide-window window))) (defmethod show-child (child parent raise-p) (declare (ignore child parent raise-p)) ()) (defgeneric hide-child (child)) (defmethod hide-child ((frame frame)) (with-slots (window) frame (xlib:unmap-window window))) (defmethod hide-child ((window xlib:window)) (hide-window window)) (defmethod hide-child (child) (declare (ignore child)) ()) (defgeneric select-child (child selected)) (labels ((get-selected-color (child selected-p) (get-color (cond ((child-equal-p child *current-child*) *color-selected*) (selected-p *color-maybe-selected*) (t *color-unselected*))))) (defmethod select-child ((frame frame) selected-p) (when (and (frame-p frame) (frame-window frame)) (setf (xlib:window-border (frame-window frame)) (get-selected-color frame selected-p)))) (defmethod select-child ((window xlib:window) selected-p) (setf (xlib:window-border window) (get-selected-color window selected-p))) (defmethod select-child (child selected) (declare (ignore child selected)) ())) (defun select-current-frame (selected) (select-child *current-child* selected)) (defun unselect-all-frames () (with-all-children (*current-root* child) (select-child child nil))) (defun set-focus-to-current-child () (labels ((rec (child) (typecase child (xlib:window (focus-window child)) (frame (rec (frame-selected-child child)))))) (no-focus) (rec *current-child*))) (defun adapt-frame-to-parent (frame parent) (multiple-value-bind (nx ny nw nh) (get-parent-layout frame parent) (with-slots (rx ry rw rh window) frame (setf rx nx ry ny rw (max nw 1) rh (max nh 1))))) (defun adapt-child-to-rect (rect) (let ((window (typecase (child-rect-child rect) (xlib:window (when (managed-window-p (child-rect-child rect) (child-rect-parent rect)) (child-rect-child rect))) (frame (frame-window (child-rect-child rect)))))) (when window (let ((change (or (/= (xlib:drawable-x window) (child-rect-x rect)) (/= (xlib:drawable-y window) (child-rect-y rect)) (/= (xlib:drawable-width window) (child-rect-w rect)) (/= (xlib:drawable-height window) (child-rect-h rect))))) (when change (setf (xlib:drawable-x window) (child-rect-x rect) (xlib:drawable-y window) (child-rect-y rect) (xlib:drawable-width window) (child-rect-w rect) (xlib:drawable-height window) (child-rect-h rect))) change)))) (defun show-all-children (&optional (from-root-frame nil)) "Show all children from *current-root*. When from-root-frame is true Display all children from root frame and hide those not in *current-root*" (let ((geometry-change nil) (displayed-child nil) (hidden-child nil)) (labels ((in-displayed-list (child) (member child displayed-child :test (lambda (c rect) (child-equal-p c (child-rect-child rect))))) (add-in-hidden-list (child) (pushnew child hidden-child :test #'child-equal-p)) (set-geometry (child parent in-current-root child-current-root-p) (if (or in-current-root child-current-root-p) (when (frame-p child) (adapt-frame-to-parent child (if child-current-root-p nil parent))) (add-in-hidden-list child))) (recurse-on-frame-child (child in-current-root child-current-root-p selected-p) (let ((selected-child (frame-selected-child child))) (dolist (sub-child (frame-child child)) (rec sub-child child (and selected-p (child-equal-p sub-child selected-child)) (or in-current-root child-current-root-p))))) (hidden-child-p (rect) (dolist (r displayed-child) (when (rect-hidden-p r rect) (return t)))) (select-and-display (child parent selected-p) (multiple-value-bind (nx ny nw nh) (get-parent-layout child parent) (let ((rect (make-child-rect :child child :parent parent :selected-p selected-p :x nx :y ny :w nw :h nh))) (if (hidden-child-p rect) (add-in-hidden-list child) (push rect displayed-child))))) (display-displayed-child () (let ((previous nil)) (dolist (rect (nreverse displayed-child)) (when (adapt-child-to-rect rect) (setf geometry-change t)) (select-child (child-rect-child rect) (child-rect-selected-p rect)) (show-child (child-rect-child rect) (child-rect-parent rect) previous) (setf previous (child-rect-child rect))))) (rec (child parent selected-p in-current-root) (let ((child-current-root-p (child-equal-p child *current-root*))) (unless (in-displayed-list child) (set-geometry child parent in-current-root child-current-root-p)) (when (frame-p child) (recurse-on-frame-child child in-current-root child-current-root-p selected-p)) (when (and (or in-current-root child-current-root-p) (not (in-displayed-list child))) (select-and-display child parent selected-p))))) (rec (if from-root-frame *root-frame* *current-root*) nil t (child-equal-p *current-root* *root-frame*)) (display-displayed-child) (dolist (child hidden-child) (hide-child child)) (set-focus-to-current-child) (xlib:display-finish-output *display*) geometry-change))) (defun hide-all-children (root &optional except) "Hide all root children" (when (and (frame-p root) (not (child-equal-p root except))) (dolist (child (frame-child root)) (hide-all child except)))) (defun hide-all (root &optional except) "Hide root and all its children" (unless (child-equal-p root except) (hide-child root)) (hide-all-children root except)) (defun focus-child (child parent) "Focus child - Return true if something has change" (when (and (frame-p parent) (child-member child (frame-child parent))) (when (not (child-equal-p child (frame-selected-child parent))) (with-slots ((parent-child child) selected-pos) parent (setf parent-child (nth-insert selected-pos child (child-remove child parent-child)))) t))) (defun focus-child-rec (child parent) "Focus child and its parents - Return true if something has change" (let ((change nil)) (labels ((rec (child parent) (when (focus-child child parent) (setf change t)) (when parent (rec parent (find-parent-frame parent))))) (rec child parent)) change)) (defun set-current-child-generic (child) (unless (child-equal-p *current-child* child) (setf *current-child* child) t)) (defgeneric set-current-child (child parent window-parent)) (defmethod set-current-child ((child xlib:window) parent window-parent) (set-current-child-generic (if window-parent parent child))) (defmethod set-current-child ((child frame) parent window-parent) (declare (ignore parent window-parent)) (set-current-child-generic child)) (defmethod set-current-child (child parent window-parent) (declare (ignore child parent window-parent)) ()) (defun set-current-root (child parent window-parent) "Set current root if parent is not in current root" (when (and window-parent (not (child-equal-p child *current-root*)) (not (find-child parent *current-root*))) (setf *current-root* parent) t)) (defun focus-all-children (child parent &optional (window-parent t)) "Focus child and its parents - For window: set current child to window or its parent according to window-parent" (let ((new-focus (focus-child-rec child parent)) (new-current-child (set-current-child child parent window-parent)) (new-root (set-current-root child parent window-parent))) (or new-focus new-current-child new-root))) (defun select-next-level () "Select the next level in frame" (select-current-frame :maybe) (when (frame-p *current-child*) (awhen (frame-selected-child *current-child*) (setf *current-child* it))) (show-all-children)) (defun select-previous-level () "Select the previous level in frame" (unless (child-equal-p *current-child* *current-root*) (select-current-frame :maybe) (awhen (find-parent-frame *current-child*) (setf *current-child* it)) (show-all-children))) (defun enter-frame () "Enter in the selected frame - ie make it the root frame" (setf *current-root* *current-child*) (show-all-children t)) (defun leave-frame () "Leave the selected frame - ie make its parent the root frame" (unless (child-equal-p *current-root* *root-frame*) (hide-all *current-root* (get-first-window)) (awhen (find-parent-frame *current-root*) (when (frame-p it) (setf *current-root* it))) (show-all-children))) ;;; Other actions (select-next-child, select-next-brother...) are in ;;; clfswm-circulate-mode.lisp (defun frame-lower-child () "Lower the child in the current frame" (when (frame-p *current-child*) (with-slots (child selected-pos) *current-child* (unless (>= selected-pos (length child)) (when (nth (1+ selected-pos) child) (rotatef (nth selected-pos child) (nth (1+ selected-pos) child))) (incf selected-pos))) (show-all-children))) (defun frame-raise-child () "Raise the child in the current frame" (when (frame-p *current-child*) (with-slots (child selected-pos) *current-child* (unless (< selected-pos 1) (when (nth (1- selected-pos) child) (rotatef (nth selected-pos child) (nth (1- selected-pos) child))) (decf selected-pos))) (show-all-children))) (defun frame-select-next-child () "Select the next child in the current frame" (when (frame-p *current-child*) (with-slots (child selected-pos) *current-child* (unless (>= selected-pos (length child)) (incf selected-pos))) (show-all-children))) (defun frame-select-previous-child () "Select the previous child in the current frame" (when (frame-p *current-child*) (with-slots (child selected-pos) *current-child* (unless (< selected-pos 1) (decf selected-pos))) (show-all-children))) (defun switch-to-root-frame (&key (show-later nil)) "Switch to the root frame" (setf *current-root* *root-frame*) (unless show-later (show-all-children t))) (defun switch-and-select-root-frame (&key (show-later nil)) "Switch and select the root frame" (setf *current-root* *root-frame*) (setf *current-child* *current-root*) (unless show-later (show-all-children t))) (defun toggle-show-root-frame () "Show/Hide the root frame" (setf *show-root-frame-p* (not *show-root-frame-p*)) (show-all-children)) (defun prevent-current-*-equal-child (child) " Prevent current-root and current-child equal to child" (when (child-equal-p child *current-root*) (setf *current-root* (find-parent-frame child))) (when (child-equal-p child *current-child*) (setf *current-child* *current-root*))) (defun remove-child-in-frame (child frame) "Remove the child in frame" (when (frame-p frame) (setf (frame-child frame) (child-remove child (frame-child frame))))) (defun remove-child-in-frames (child root) "Remove child in the frame root and in all its children" (with-all-frames (root frame) (remove-child-in-frame child frame))) (defun remove-child-in-all-frames (child) "Remove child in all frames from *root-frame*" (prevent-current-*-equal-child child) (remove-child-in-frames child *root-frame*)) (defun delete-child-in-frames (child root) "Delete child in the frame root and in all its children Warning:frame window and gc are freeed." (with-all-frames (root frame) (remove-child-in-frame child frame) (unless (find-frame-window (frame-window frame)) (awhen (frame-gc frame) (xlib:free-gcontext it) (setf it nil)) (awhen (frame-window frame) (xlib:destroy-window it) (setf it nil)))) (when (xlib:window-p child) (netwm-remove-in-client-list child))) (defun delete-child-in-all-frames (child) "Delete child in all frames from *root-frame*" (prevent-current-*-equal-child child) (delete-child-in-frames child *root-frame*)) (defun delete-child-and-children-in-frames (child root) "Delete child and its children in the frame root and in all its children Warning:frame window and gc are freeed." (when (and (frame-p child) (frame-child child)) (dolist (ch (frame-child child)) (delete-child-and-children-in-frames ch root))) (delete-child-in-frames child root)) (defun delete-child-and-children-in-all-frames (child &optional (close-methode 'delete-window)) "Delete child and its children in all frames from *root-frame*" (prevent-current-*-equal-child child) (delete-child-and-children-in-frames child *root-frame*) (when (xlib:window-p child) (funcall close-methode child)) (show-all-children)) (defun clean-windows-in-all-frames () "Remove all xlib:windows present in *root-frame* and not in the xlib tree" (let ((x-tree (xlib:query-tree *root*))) (with-all-frames (*root-frame* frame) (dolist (child (frame-child frame)) (when (xlib:window-p child) (unless (member child x-tree :test #'xlib:window-equal) (prevent-current-*-equal-child child) (setf (frame-child frame) (child-remove child (frame-child frame))))))))) (defun place-window-from-hints (window) "Place a window from its hints" (let* ((hints (xlib:wm-normal-hints window)) (min-width (or (and hints (xlib:wm-size-hints-min-width hints)) 0)) (min-height (or (and hints (xlib:wm-size-hints-min-height hints)) 0)) (max-width (or (and hints (xlib:wm-size-hints-max-width hints)) (xlib:drawable-width *root*))) (max-height (or (and hints (xlib:wm-size-hints-max-height hints)) (xlib:drawable-height *root*))) (rwidth (or (and hints (or (xlib:wm-size-hints-width hints) (xlib:wm-size-hints-base-width hints))) (xlib:drawable-width window))) (rheight (or (and hints (or (xlib:wm-size-hints-height hints) (xlib:wm-size-hints-base-height hints))) (xlib:drawable-height window)))) (setf (xlib:drawable-width window) (min (max min-width rwidth *default-window-width*) max-width) (xlib:drawable-height window) (min (max min-height rheight *default-window-height*) max-height)) (with-placement (*unmanaged-window-placement* x y (xlib:drawable-width window) (xlib:drawable-height window)) (setf (xlib:drawable-x window) x (xlib:drawable-y window) y)) (xlib:display-finish-output *display*))) (defun do-all-frames-nw-hook (window) "Call nw-hook of each frame." (catch 'nw-hook-loop (let ((found nil)) (with-all-frames (*root-frame* frame) (awhen (frame-nw-hook frame) (setf found (call-hook it (list frame window))))) found))) (defun process-new-window (window) "When a new window is created (or when we are scanning initial windows), this function dresses the window up and gets it ready to be managed." (setf (xlib:window-event-mask window) *window-events*) (set-window-state window +normal-state+) (setf (xlib:drawable-border-width window) (case (window-type window) (:normal *border-size*) (:maxsize *border-size*) (:transient *border-size*) (t *border-size*))) (grab-all-buttons window) (unless (never-managed-window-p window) (unless (do-all-frames-nw-hook window) (call-hook *default-nw-hook* (list *root-frame* window)))) (netwm-add-in-client-list window)) (defun hide-existing-windows (screen) "Hide all existing windows in screen" (dolist (win (xlib:query-tree (xlib:screen-root screen))) (hide-window win))) (defun process-existing-windows (screen) "Windows present when clfswm starts up must be absorbed by clfswm." (setf *in-process-existing-windows* t) (let ((id-list nil) (all-windows (get-all-windows))) (dolist (win (xlib:query-tree (xlib:screen-root screen))) (unless (child-member win all-windows) (let ((map-state (xlib:window-map-state win)) (wm-state (window-state win))) (unless (or (eql (xlib:window-override-redirect win) :on) (eql win *no-focus-window*) (is-notify-window-p win)) (when (or (eql map-state :viewable) (eql wm-state +iconic-state+)) (format t "Processing ~S: type=~A ~S~%" (xlib:wm-name win) (window-type win) win) (unhide-window win) (process-new-window win) (map-window win) (raise-window win) (pushnew (xlib:window-id win) id-list)))))) (netwm-set-client-list id-list)) (setf *in-process-existing-windows* nil)) ;;; Child order manipulation functions (defun put-child-on-top (child parent) "Put the child on top of its parent children" (when (frame-p parent) (setf (frame-child parent) (cons child (child-remove child (frame-child parent))) (frame-selected-pos parent) 0))) (defun put-child-on-bottom (child parent) "Put the child at the bottom of its parent children" (when (frame-p parent) (setf (frame-child parent) (append (child-remove child (frame-child parent)) (list child)) (frame-selected-pos parent) 0))) clfswm-20111015.git51b0a02/src/clfswm-keys.lisp000066400000000000000000000222741164636077000206630ustar00rootroot00000000000000;;; -------------------------------------------------------------------------- ;;; CLFSWM - FullScreen Window Manager ;;; ;;; -------------------------------------------------------------------------- ;;; Documentation: Keys functions definition ;;; -------------------------------------------------------------------------- ;;; ;;; (C) 2011 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;; ;;; -------------------------------------------------------------------------- (in-package :clfswm) (defparameter *fun-press* #'first) (defparameter *fun-release* #'second) (defun with-capslock () (pushnew :lock *default-modifiers*)) (defun without-capslock () (setf *default-modifiers* (remove :lock *default-modifiers*))) (defun with-numlock () (pushnew :mod-2 *default-modifiers*)) (defun without-numlock () (setf *default-modifiers* (remove :mod-2 *default-modifiers*))) ;;; CONFIG - Key mode names (defmacro define-init-hash-table-key (hash-table name) (let ((init-name (create-symbol "init-" (format nil "~A" hash-table)))) `(progn (defun ,init-name () (setf ,hash-table (make-hash-table :test 'equal)) (setf (gethash 'name ,hash-table) ,name)) (,init-name)))) (define-init-hash-table-key *main-keys* "Main mode keys") (define-init-hash-table-key *main-mouse* "Mouse buttons actions in main mode") (define-init-hash-table-key *second-keys* "Second mode keys") (define-init-hash-table-key *second-mouse* "Mouse buttons actions in second mode") (define-init-hash-table-key *info-keys* "Info mode keys") (define-init-hash-table-key *info-mouse* "Mouse buttons actions in info mode") (define-init-hash-table-key *query-keys* "Query mode keys") (define-init-hash-table-key *circulate-keys* "Circulate mode keys") (define-init-hash-table-key *circulate-keys-release* "Circulate mode release keys") (define-init-hash-table-key *expose-keys* "Expose windows mode keys") (define-init-hash-table-key *expose-mouse* "Mouse buttons actions in expose windows mode") (defun unalias-modifiers (list) (dolist (mod *modifier-alias*) (setf list (substitute (second mod) (first mod) list))) list) (defun key->list (key) (list (first key) (modifiers->state (append (unalias-modifiers (rest key)) (unalias-modifiers *default-modifiers*))))) (defmacro define-define-key (name hashtable) (let ((name-key-fun (create-symbol "define-" name "-key-fun")) (name-key (create-symbol "define-" name "-key")) (undefine-name-fun (create-symbol "undefine-" name "-key-fun")) (undefine-name (create-symbol "undefine-" name "-key")) (undefine-multi-name (create-symbol "undefine-" name "-multi-keys"))) `(progn (defun ,name-key-fun (key function &rest args) "Define a new key, a key is '(char modifier1 modifier2...))" (setf (gethash (key->list key) ,hashtable) (list function args))) (defmacro ,name-key ((key &rest modifiers) function &rest args) `(,',name-key-fun (list ,key ,@modifiers) ,function ,@args)) (defun ,undefine-name-fun (key) "Undefine a new key, a key is '(char modifier1 modifier2...))" (remhash (key->list key) ,hashtable)) (defmacro ,undefine-name ((key &rest modifiers)) `(,',undefine-name-fun (list ,key ,@modifiers))) (defmacro ,undefine-multi-name (&rest keys) `(progn ,@(loop for k in keys collect `(,',undefine-name ,k))))))) (defmacro define-define-mouse (name hashtable) (let ((name-mouse-fun (create-symbol "define-" name "-fun")) (name-mouse (create-symbol "define-" name)) (undefine-name (create-symbol "undefine-" name))) `(progn (defun ,name-mouse-fun (button function-press &optional function-release &rest args) "Define a new mouse button action, a button is '(button number '(modifier list))" (setf (gethash (key->list button) ,hashtable) (list function-press function-release args))) (defmacro ,name-mouse ((button &rest modifiers) function-press &optional function-release &rest args) `(,',name-mouse-fun (list ,button ,@modifiers) ,function-press ,function-release ,@args)) (defmacro ,undefine-name ((key &rest modifiers)) `(remhash (list ,key ,@modifiers) ,',hashtable))))) (define-define-key "main" *main-keys*) (define-define-key "second" *second-keys*) (define-define-key "info" *info-keys*) (define-define-key "query" *query-keys*) (define-define-key "circulate" *circulate-keys*) (define-define-key "circulate-release" *circulate-keys-release*) (define-define-key "expose" *expose-keys*) (define-define-mouse "main-mouse" *main-mouse*) (define-define-mouse "second-mouse" *second-mouse*) (define-define-mouse "info-mouse" *info-mouse*) (define-define-mouse "expose-mouse" *expose-mouse*) (defun add-in-state (state modifier) "Add a modifier in a state" (modifiers->state (append (state->modifiers state) (list modifier)))) (defmacro define-ungrab/grab (name function hashtable) `(defun ,name () (maphash #'(lambda (k v) (declare (ignore v)) (when (consp k) (handler-case (let* ((key (first k)) (modifiers (second k)) (keycode (typecase key (character (multiple-value-list (char->keycode key))) (number key) (string (let* ((keysym (keysym-name->keysym key)) (ret-keycode (multiple-value-list (xlib:keysym->keycodes *display* keysym)))) (let ((found nil)) (dolist (kc ret-keycode) (when (= keysym (xlib:keycode->keysym *display* kc 0)) (setf found t))) (unless found (setf modifiers (add-in-state modifiers :shift)))) ret-keycode))))) (if keycode (if (consp keycode) (dolist (kc (remove-duplicates keycode)) (,function *root* kc :modifiers modifiers)) (,function *root* keycode :modifiers modifiers)) (format t "~&Grabbing error: Can't find key '~A'~%" key))) (error (c) ;;(declare (ignore c)) (format t "~&Grabbing error: Can't grab key '~A' (~A)~%" k c))) (force-output))) ,hashtable))) (define-ungrab/grab grab-main-keys xlib:grab-key *main-keys*) (define-ungrab/grab ungrab-main-keys xlib:ungrab-key *main-keys*) (defun find-key-from-code (hash-table-key code state) "Return the function associated to code/state" (labels ((function-from (key &optional (new-state state)) (multiple-value-bind (function foundp) (gethash (list key new-state) hash-table-key) (when (and foundp (first function)) function))) (from-code () (function-from code)) (from-char () (let ((char (keycode->char code state))) (function-from char))) (from-string () (let ((string (keysym->keysym-name (xlib:keycode->keysym *display* code 0)))) (function-from string))) (from-string-shift () (let* ((modifiers (state->modifiers state)) (string (keysym->keysym-name (keycode->keysym code modifiers)))) (function-from string))) (from-string-no-shift () (let* ((modifiers (state->modifiers state)) (string (keysym->keysym-name (keycode->keysym code modifiers)))) (function-from string (modifiers->state (remove :shift modifiers)))))) (or (from-code) (from-char) (from-string) (from-string-shift) (from-string-no-shift)))) (defun funcall-key-from-code (hash-table-key code state &rest args) (let ((function (find-key-from-code hash-table-key code state))) (when function (apply (first function) (append args (second function))) t))) (defun funcall-button-from-code (hash-table-key code state window root-x root-y &optional (action *fun-press*) args) (let ((state (modifiers->state (set-difference (state->modifiers state) '(:button-1 :button-2 :button-3 :button-4 :button-5))))) (multiple-value-bind (function foundp) (gethash (list code state) hash-table-key) (if (and foundp (funcall action function)) (progn (apply (funcall action function) `(,window ,root-x ,root-y ,@(append args (third function)))) t) nil)))) (defun binding-substitute-modifier (to from &optional (hashtables (list *main-keys* *main-mouse* *second-keys* *second-mouse* *info-keys* *info-mouse* *query-keys* *circulate-keys* *circulate-keys-release* *expose-keys* *expose-mouse*))) "Utility to change modifiers after binding definition" (labels ((change (&optional (hashtable *main-keys*) to from) (maphash (lambda (k v) (when (consp k) (let ((state (modifiers->state (substitute to from (state->modifiers (second k)))))) (remhash k hashtable) (setf (gethash (list (first k) state) hashtable) v)))) hashtable))) (dolist (h hashtables) (change h to from)))) clfswm-20111015.git51b0a02/src/clfswm-layout.lisp000066400000000000000000000721461164636077000212300ustar00rootroot00000000000000;;; -------------------------------------------------------------------------- ;;; CLFSWM - FullScreen Window Manager ;;; ;;; -------------------------------------------------------------------------- ;;; Documentation: Layout functions ;;; -------------------------------------------------------------------------- ;;; ;;; (C) 2011 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;; ;;; -------------------------------------------------------------------------- (in-package :clfswm) ;;; CONFIG - Layout menu ;;; ;;; To add a new layout: ;;; 1- define your own layout: a method returning the real size of the ;;; child in screen size (integer) as 4 values (rx, ry, rw, rh). ;;; This method can use the float size of the child (x, y ,w , h). ;;; It can be specialized for xlib:window or frame ;;; 2- Define a setter function for your layout ;;; 3- Register your new layout with register-layout or create ;;; a sub menu for it with register-layout-sub-menu. (defparameter *layout-current-key* (1- (char-code #\a))) ;;; Generic functions (defun set-layout (layout) "Set the layout of the current child" (when (frame-p *current-child*) (setf (frame-layout *current-child*) layout) (leave-second-mode))) (defun set-layout-dont-leave (layout) "Set the layout of the current child" (when (frame-p *current-child*) (setf (frame-layout *current-child*) layout))) (defun set-layout-once (layout-name) (set-layout-dont-leave layout-name) (show-all-children) (fixe-real-size-current-child) (set-layout-dont-leave #'no-layout)) (defun get-managed-child (parent) "Return only the windows that are managed for tiling" (when (frame-p parent) (remove-if #'(lambda (x) (and (xlib:window-p x) (not (managed-window-p x parent)))) (frame-child parent)))) (defun next-layout-key () (code-char (incf *layout-current-key*))) (defun register-layout (layout) (add-menu-key 'frame-layout-menu (next-layout-key) layout)) (defun register-layout-sub-menu (name doc layout-list) (add-sub-menu 'frame-layout-menu (next-layout-key) name doc) (loop :for item :in layout-list :for i :from 0 :do (typecase item (cons (add-menu-key name (first item) (second item))) (string (add-menu-comment name item)) (t (add-menu-key name (number->char i) item))))) (defun layout-ask-size (msg slot &optional (min 80)) (when (frame-p *current-child*) (let ((new-size (/ (or (query-number msg (* (frame-data-slot *current-child* slot) 100)) min) 100))) (setf (frame-data-slot *current-child* slot) (max (min new-size 0.99) 0.01))))) (defun adjust-layout-size (slot inc) (when (frame-p *current-child*) (setf (frame-data-slot *current-child* slot) (max (min (+ (frame-data-slot *current-child* slot) inc) 0.99) 0.01)))) (defun inc-tile-layout-size () "Increase the tile layout size" (adjust-layout-size :tile-size 0.05) (show-all-children)) (defun dec-tile-layout-size () "Decrease the tile layout size" (adjust-layout-size :tile-size -0.05) (show-all-children)) (defun inc-slow-tile-layout-size () "Increase slowly the tile layout size" (adjust-layout-size :tile-size 0.01) (show-all-children)) (defun dec-slow-tile-layout-size () "Decrease slowly the tile layout size" (adjust-layout-size :tile-size -0.01) (show-all-children)) (defun fast-layout-switch () "Switch between two layouts" (when (frame-p *current-child*) (with-slots (layout) *current-child* (let* ((layout-list (frame-data-slot *current-child* :fast-layout)) (first-layout (ensure-function (first layout-list))) (second-layout (ensure-function (second layout-list)))) (setf layout (if (eql layout first-layout) second-layout first-layout)) (leave-second-mode))))) (defun push-in-fast-layout-list () "Push the current layout in the fast layout list" (when (frame-p *current-child*) (setf (frame-data-slot *current-child* :fast-layout) (list (frame-layout *current-child*) (first (frame-data-slot *current-child* :fast-layout)))) (leave-second-mode))) (register-layout-sub-menu 'frame-fast-layout-menu "Frame fast layout menu" '(("s" fast-layout-switch) ("p" push-in-fast-layout-list))) ;;; No layout (defgeneric no-layout (child parent) (:documentation "No layout: Maximize windows in their frame - Leave frames to their original size")) (defmethod no-layout ((child xlib:window) parent) (with-slots (rx ry rw rh) parent (values (adj-border-xy rx child) (adj-border-xy ry child) (adj-border-wh rw child) (adj-border-wh rh child)))) (defmethod no-layout ((child frame) parent) (values (adj-border-xy (x-fl->px (frame-x child) parent) child) (adj-border-xy (y-fl->px (frame-y child) parent) child) (adj-border-wh (w-fl->px (frame-w child) parent) child) (adj-border-wh (h-fl->px (frame-h child) parent) child))) (defun set-no-layout () "No layout: Maximize windows in their frame - Leave frames to their original size" (set-layout #'no-layout)) (register-layout 'set-no-layout) ;;; No layout remember size (defun set-no-layout-remember-size () "No layout: Maximize windows in their frame - Leave frames to their actual size" (fixe-real-size-current-child) (set-no-layout)) (register-layout 'set-no-layout-remember-size) ;;; Maximize layout (defgeneric maximize-layout (child parent) (:documentation "Maximize layout: Maximize windows and frames in their parent frame")) (defmethod maximize-layout (child parent) (with-slots (rx ry rw rh) parent (values (adj-border-xy rx child) (adj-border-xy ry child) (adj-border-wh rw child) (adj-border-wh rh child)))) (defun set-maximize-layout () "Maximize layout: Maximize windows and frames in their parent frame" (set-layout #'maximize-layout)) (register-layout 'set-maximize-layout) ;;; Tile layout (defun tile-layout-ask-keep-position () (when (frame-p *current-child*) (if (query-yes-or-no "Keep frame children positions?") (setf (frame-data-slot *current-child* :tile-layout-keep-position) :yes) (remove-frame-data-slot *current-child* :tile-layout-keep-position)))) (labels ((set-managed () (setf (frame-data-slot *current-child* :layout-managed-children) (copy-list (get-managed-child *current-child*))))) (defun set-layout-managed-children () (when (frame-p *current-child*) (set-managed) (tile-layout-ask-keep-position))) (defun update-layout-managed-children-position () "Update layout managed children position" (when (frame-p *current-child*) (set-managed) (leave-second-mode)))) (defun update-layout-managed-children-keep-position (child parent) (let ((managed-children (frame-data-slot parent :layout-managed-children)) (managed-in-parent (get-managed-child parent))) (dolist (ch managed-in-parent) (unless (child-member ch managed-children) (setf managed-children (append managed-children (list child))))) (setf managed-children (remove-if-not (lambda (x) (child-member x managed-in-parent)) managed-children)) (setf (frame-data-slot parent :layout-managed-children) managed-children) managed-children)) (defun update-layout-managed-children (child parent) (if (eql (frame-data-slot parent :tile-layout-keep-position) :yes) (update-layout-managed-children-keep-position child parent) (get-managed-child parent))) (defgeneric tile-layout (child parent) (:documentation "Tile child in its frame (vertical)")) (defmethod tile-layout (child parent) (let* ((managed-children (update-layout-managed-children child parent)) (pos (child-position child managed-children)) (len (length managed-children)) (nx (ceiling (sqrt len))) (ny (ceiling (/ len nx))) (dx (/ (frame-rw parent) nx)) (dy (/ (frame-rh parent) ny)) (dpos (- (* nx ny) len)) (width dx)) (when (plusp dpos) (if (zerop pos) (setf width (* dx (1+ dpos))) (incf pos dpos))) (values (round (adj-border-xy (+ (frame-rx parent) (truncate (* (mod pos nx) dx))) child)) (round (adj-border-xy (+ (frame-ry parent) (truncate (* (truncate (/ pos nx)) dy))) child)) (round (adj-border-wh width child)) (round (adj-border-wh dy child))))) (defun set-tile-layout () "Tile child in its frame (vertical)" (set-layout-managed-children) (set-layout #'tile-layout)) ;; Horizontal tiling layout (defgeneric tile-horizontal-layout (child parent) (:documentation "Tile child in its frame (horizontal)")) (defmethod tile-horizontal-layout (child parent) (let* ((managed-children (update-layout-managed-children child parent)) (pos (child-position child managed-children)) (len (length managed-children)) (ny (ceiling (sqrt len))) (nx (ceiling (/ len ny))) (dx (/ (frame-rw parent) nx)) (dy (/ (frame-rh parent) ny)) (dpos (- (* nx ny) len)) (height dy)) (when (plusp dpos) (if (zerop pos) (setf height (* dy (1+ dpos))) (incf pos dpos))) (values (round (adj-border-xy (+ (frame-rx parent) (truncate (* (truncate (/ pos ny)) dx))) child)) (round (adj-border-xy (+ (frame-ry parent) (truncate (* (mod pos ny) dy))) child)) (round (adj-border-wh dx child)) (round (adj-border-wh height child))))) (defun set-tile-horizontal-layout () "Tile child in its frame (horizontal)" (set-layout-managed-children) (set-layout #'tile-horizontal-layout)) ;; One column layout (defgeneric one-column-layout (child parent) (:documentation "One column layout")) (defmethod one-column-layout (child parent) (let* ((managed-children (update-layout-managed-children child parent)) (pos (child-position child managed-children)) (len (length managed-children)) (dy (/ (frame-rh parent) len))) (values (round (adj-border-xy (frame-rx parent) child)) (round (adj-border-xy (+ (frame-ry parent) (* pos dy)) child)) (round (adj-border-wh (frame-rw parent) child)) (round (adj-border-wh dy child))))) (defun set-one-column-layout () "One column layout" (set-layout-managed-children) (set-layout #'one-column-layout)) ;; One line layout (defgeneric one-line-layout (child parent) (:documentation "One line layout")) (defmethod one-line-layout (child parent) (let* ((managed-children (update-layout-managed-children child parent)) (pos (child-position child managed-children)) (len (length managed-children)) (dx (/ (frame-rw parent) len))) (values (round (adj-border-xy (+ (frame-rx parent) (* pos dx)) child)) (round (adj-border-xy (frame-ry parent) child)) (round (adj-border-wh dx child)) (round (adj-border-wh (frame-rh parent) child))))) (defun set-one-line-layout () "One line layout" (set-layout-managed-children) (set-layout #'one-line-layout)) ;;; Space layout (defun tile-space-layout (child parent) "Tile Space: tile child in its frame leaving spaces between them" (with-slots (rx ry rw rh) parent (let* ((managed-children (update-layout-managed-children child parent)) (pos (child-position child managed-children)) (len (length managed-children)) (n (ceiling (sqrt len))) (dx (/ rw n)) (dy (/ rh (ceiling (/ len n)))) (size (or (frame-data-slot parent :tile-space-size) 0.1))) (when (> size 0.5) (setf size 0.45)) (values (round (adj-border-xy (+ rx (truncate (* (mod pos n) dx)) (* dx size)) child)) (round (adj-border-xy (+ ry (truncate (* (truncate (/ pos n)) dy)) (* dy size)) child)) (round (adj-border-wh (- dx (* dx size 2)) child)) (round (adj-border-wh (- dy (* dy size 2)) child)))))) (defun set-tile-space-layout () "Tile Space: tile child in its frame leaving spaces between them" (layout-ask-size "Space size in percent (%)" :tile-space-size 0.01) (set-layout-managed-children) (set-layout #'tile-space-layout)) (register-layout-sub-menu 'frame-tile-layout-menu "Frame tile layout menu" '(("v" set-tile-layout) ("h" set-tile-horizontal-layout) ("c" set-one-column-layout) ("l" set-one-line-layout) ("s" set-tile-space-layout))) ;;; Tile Left (defun tile-left-layout (child parent) "Tile Left: main child on left and others on right" (with-slots (rx ry rw rh) parent (let* ((managed-children (update-layout-managed-children child parent)) (pos (child-position child managed-children)) (len (max (1- (length managed-children)) 1)) (dy (/ rh len)) (size (or (frame-data-slot parent :tile-size) 0.8))) (if (> (length managed-children) 1) (if (= pos 0) (values (adj-border-xy rx child) (adj-border-xy ry child) (adj-border-wh (round (* rw size)) child) (adj-border-wh rh child)) (values (adj-border-xy (round (+ rx (* rw size))) child) (adj-border-xy (round (+ ry (* dy (1- pos)))) child) (adj-border-wh (round (* rw (- 1 size))) child) (adj-border-wh (round dy) child))) (no-layout child parent))))) (defun set-tile-left-layout () "Tile Left: main child on left and others on right" (layout-ask-size "Tile size in percent (%)" :tile-size) (set-layout-managed-children) (set-layout #'tile-left-layout)) ;;; Tile right (defun tile-right-layout (child parent) "Tile Right: main child on right and others on left" (with-slots (rx ry rw rh) parent (let* ((managed-children (update-layout-managed-children child parent)) (pos (child-position child managed-children)) (len (max (1- (length managed-children)) 1)) (dy (/ rh len)) (size (or (frame-data-slot parent :tile-size) 0.8))) (if (> (length managed-children) 1) (if (= pos 0) (values (adj-border-xy (round (+ rx (* rw (- 1 size)))) child) (adj-border-xy ry child) (adj-border-wh (round (* rw size)) child) (adj-border-wh rh child)) (values (adj-border-xy rx child) (adj-border-xy (round (+ ry (* dy (1- pos)))) child) (adj-border-wh (round (* rw (- 1 size))) child) (adj-border-wh (round dy) child))) (no-layout child parent))))) (defun set-tile-right-layout () "Tile Right: main child on right and others on left" (layout-ask-size "Tile size in percent (%)" :tile-size) (set-layout-managed-children) (set-layout #'tile-right-layout)) ;;; Tile Top (defun tile-top-layout (child parent) "Tile Top: main child on top and others on bottom" (with-slots (rx ry rw rh) parent (let* ((managed-children (update-layout-managed-children child parent)) (pos (child-position child managed-children)) (len (max (1- (length managed-children)) 1)) (dx (/ rw len)) (size (or (frame-data-slot parent :tile-size) 0.8))) (if (> (length managed-children) 1) (if (= pos 0) (values (adj-border-xy rx child) (adj-border-xy ry child) (adj-border-wh rw child) (adj-border-wh (round (* rh size)) child)) (values (adj-border-xy (round (+ rx (* dx (1- pos)))) child) (adj-border-xy (round (+ ry (* rh size))) child) (adj-border-wh (round dx) child) (adj-border-wh (round (* rh (- 1 size))) child))) (no-layout child parent))))) (defun set-tile-top-layout () "Tile Top: main child on top and others on bottom" (layout-ask-size "Tile size in percent (%)" :tile-size) (set-layout-managed-children) (set-layout #'tile-top-layout)) ;;; Tile Bottom (defun tile-bottom-layout (child parent) "Tile Bottom: main child on bottom and others on top" (with-slots (rx ry rw rh) parent (let* ((managed-children (update-layout-managed-children child parent)) (pos (child-position child managed-children)) (len (max (1- (length managed-children)) 1)) (dx (/ rw len)) (size (or (frame-data-slot parent :tile-size) 0.8))) (if (> (length managed-children) 1) (if (= pos 0) (values (adj-border-xy rx child) (adj-border-xy (round (+ ry (* rh (- 1 size)))) child) (adj-border-wh rw child) (adj-border-wh (round (* rh size)) child)) (values (adj-border-xy (round (+ rx (* dx (1- pos)))) child) (adj-border-xy ry child) (adj-border-wh (round dx) child) (adj-border-wh (round (* rh (- 1 size))) child))) (no-layout child parent))))) (defun set-tile-bottom-layout () "Tile Bottom: main child on bottom and others on top" (layout-ask-size "Tile size in percent (%)" :tile-size) (set-layout-managed-children) (set-layout #'tile-bottom-layout)) (register-layout-sub-menu 'frame-tile-dir-layout-menu "Tile in one direction layout menu" '(("l" set-tile-left-layout) ("r" set-tile-right-layout) ("t" set-tile-top-layout) ("b" set-tile-bottom-layout))) ;;; Left and space layout: like left layout but leave a space on the left (defun layout-ask-space (msg slot &optional (default 100)) (when (frame-p *current-child*) (let ((new-space (or (query-number msg (or (frame-data-slot *current-child* slot) default)) default))) (setf (frame-data-slot *current-child* slot) new-space)))) (defun tile-left-space-layout (child parent) "Tile Left Space: main child on left and others on right. Leave some space (in pixels) on the left." (with-slots (rx ry rw rh) parent (let* ((managed-children (update-layout-managed-children child parent)) (pos (child-position child managed-children)) (len (max (1- (length managed-children)) 1)) (dy (/ rh len)) (size (or (frame-data-slot parent :tile-size) 0.8)) (space (or (frame-data-slot parent :tile-left-space) 100))) (if (> (length managed-children) 1) (if (= pos 0) (values (adj-border-xy (+ rx space) child) (adj-border-xy ry child) (adj-border-wh (- (round (* rw size)) space) child) (adj-border-wh rh child)) (values (adj-border-xy (round (+ rx (* rw size))) child) (adj-border-xy (round (+ ry (* dy (1- pos)))) child) (adj-border-wh (round (* rw (- 1 size))) child) (adj-border-wh (round dy) child))) (multiple-value-bind (rnx rny rnw rnh) (no-layout child parent) (values (+ rnx space) rny (- rnw space) rnh)))))) (defun set-tile-left-space-layout () "Tile Left Space: main child on left and others on right. Leave some space on the left." (layout-ask-size "Tile size in percent (%)" :tile-size) (layout-ask-space "Tile space (in pixels)" :tile-left-space) (set-layout-managed-children) (set-layout #'tile-left-space-layout)) (register-layout-sub-menu 'frame-tile-space-layout-menu "Tile with some space on one side menu" '(set-tile-left-space-layout)) ;;; Main windows layout - A possible GIMP layout ;;; The windows in the main list are tiled on the frame ;;; others windows are on one side of the frame. (defun main-window-right-layout (child parent) "Main window right: Main windows on the right. Others on the left." (with-slots (rx ry rw rh) parent (let* ((main-windows (frame-data-slot parent :main-window-list)) (len (length main-windows)) (size (or (frame-data-slot parent :tile-size) 0.8))) (if (zerop len) (no-layout child parent) (if (child-member child main-windows) (let* ((dy (/ rh len)) (pos (child-position child main-windows))) (values (adj-border-xy (round (+ rx (* rw (- 1 size)))) child) (adj-border-xy (round (+ ry (* dy pos))) child) (adj-border-wh (round (* rw size)) child) (adj-border-wh (round dy) child))) (values (adj-border-xy rx child) (adj-border-xy ry child) (adj-border-wh (round (* rw (- 1 size))) child) (adj-border-wh rh child))))))) (defun set-main-window-right-layout () "Main window right: Main windows on the right. Others on the left." (layout-ask-size "Split size in percent (%)" :tile-size) (set-layout #'main-window-right-layout)) (defun main-window-left-layout (child parent) "Main window left: Main windows on the left. Others on the right." (with-slots (rx ry rw rh) parent (let* ((main-windows (frame-data-slot parent :main-window-list)) (len (length main-windows)) (size (or (frame-data-slot parent :tile-size) 0.8))) (if (zerop len) (no-layout child parent) (if (child-member child main-windows) (let* ((dy (/ rh len)) (pos (child-position child main-windows))) (values (adj-border-xy rx child) (adj-border-xy (round (+ ry (* dy pos))) child) (adj-border-wh (round (* rw size)) child) (adj-border-wh (round dy) child))) (values (adj-border-xy (round (+ rx (* rw size))) child) (adj-border-xy ry child) (adj-border-wh (round (* rw (- 1 size))) child) (adj-border-wh rh child))))))) (defun set-main-window-left-layout () "Main window left: Main windows on the left. Others on the right." (layout-ask-size "Split size in percent (%)" :tile-size) (set-layout #'main-window-left-layout)) (defun main-window-top-layout (child parent) "Main window top: Main windows on the top. Others on the bottom." (with-slots (rx ry rw rh) parent (let* ((main-windows (frame-data-slot parent :main-window-list)) (len (length main-windows)) (size (or (frame-data-slot parent :tile-size) 0.8))) (if (zerop len) (no-layout child parent) (if (child-member child main-windows) (let* ((dx (/ rw len)) (pos (child-position child main-windows))) (values (adj-border-xy (round (+ rx (* dx pos))) child) (adj-border-xy ry child) (adj-border-wh (round dx) child) (adj-border-wh (round (* rh size)) child))) (values (adj-border-xy rx child) (adj-border-xy (round (+ ry (* rh size))) child) (adj-border-wh rw child) (adj-border-wh (round (* rh (- 1 size))) child))))))) (defun set-main-window-top-layout () "Main window top: Main windows on the top. Others on the bottom." (layout-ask-size "Split size in percent (%)" :tile-size) (set-layout #'main-window-top-layout)) (defun main-window-bottom-layout (child parent) "Main window bottom: Main windows on the bottom. Others on the top." (with-slots (rx ry rw rh) parent (let* ((main-windows (frame-data-slot parent :main-window-list)) (len (length main-windows)) (size (or (frame-data-slot parent :tile-size) 0.8))) (if (zerop len) (no-layout child parent) (if (child-member child main-windows) (let* ((dx (/ rw len)) (pos (child-position child main-windows))) (values (adj-border-xy (round (+ rx (* dx pos))) child) (adj-border-xy (round (+ ry (* rh (- 1 size)))) child) (adj-border-wh (round dx) child) (adj-border-wh (round (* rh size)) child))) (values (adj-border-xy rx child) (adj-border-xy ry child) (adj-border-wh rw child) (adj-border-wh (round (* rh (- 1 size))) child))))))) (defun set-main-window-bottom-layout () "Main window bottom: Main windows on the bottom. Others on the top." (layout-ask-size "Split size in percent (%)" :tile-size) (set-layout #'main-window-bottom-layout)) (defun add-in-main-window-list () "Add the current window in the main window list" (when (frame-p *current-child*) (with-current-window (when (child-member window (get-managed-child *current-child*)) (pushnew window (frame-data-slot *current-child* :main-window-list))))) (leave-second-mode)) (defun remove-in-main-window-list () "Remove the current window from the main window list" (when (frame-p *current-child*) (with-current-window (when (child-member window (get-managed-child *current-child*)) (setf (frame-data-slot *current-child* :main-window-list) (child-remove window (frame-data-slot *current-child* :main-window-list)))))) (leave-second-mode)) (defun clear-main-window-list () "Clear the main window list" (when (frame-p *current-child*) (setf (frame-data-slot *current-child* :main-window-list) nil)) (leave-second-mode)) (register-layout-sub-menu 'frame-main-window-layout-menu "Main window layout menu" '(("r" set-main-window-right-layout) ("l" set-main-window-left-layout) ("t" set-main-window-top-layout) ("b" set-main-window-bottom-layout) "-=- Actions on main windows list -=-" ("a" add-in-main-window-list) ("v" remove-in-main-window-list) ("c" clear-main-window-list))) ;;; GIMP layout specifics functions ;;; (defconfig *gimp-layout-notify-window-delay* 30 'gimp-layout "Time to display the GIMP layout notify window help") (defun select-next/previous-child-no-main-window (fun-rotate) "Select the next/previous child - Skip windows in main window list" (when (frame-p *current-child*) (with-slots (child) *current-child* (let* ((main-windows (frame-data-slot *current-child* :main-window-list)) (to-skip? (not (= (length main-windows) (length child))))) (labels ((rec () (setf child (funcall fun-rotate child)) (when (and to-skip? (child-member (frame-selected-child *current-child*) main-windows)) (rec)))) (unselect-all-frames) (rec) (show-all-children)))))) (defun select-next-child-no-main-window () "Select the next child - Skip windows in main window list" (select-next/previous-child-no-main-window #'rotate-list)) (defun select-previous-child-no-main-window () "Select the previous child - Skip windows in main window list" (select-next/previous-child-no-main-window #'anti-rotate-list)) (defun mouse-click-to-focus-and-move-no-main-window (window root-x root-y) "Move and focus the current frame or focus the current window parent. Or do actions on corners - Skip windows in main window list" (unless (do-corner-action root-x root-y *corner-main-mode-left-button*) (if (and (frame-p *current-child*) (child-member window (frame-data-slot *current-child* :main-window-list))) (replay-button-event) (mouse-click-to-focus-generic root-x root-y #'move-frame)))) (let ((help-text-list `(("-=- Help on The GIMP layout -=-" ,*info-color-title*) "" "The GIMP layout is a main-window-layout with a sloppy focus policy." "You can change the main windows direction with the layout menu." "" "Press Alt+F8 to add a window to the main windows list." "Press Alt+F9 to remove a window from the main windows list." "Press Alt+F10 to clear the main windows list." "" "You can select a main window with the right mouse button." "" "Use the layout menu to restore the previous layout and keybinding."))) (defun help-on-gimp-layout () "Help on the GIMP layout" (info-mode help-text-list) (leave-second-mode)) (defun set-gimp-layout () "The GIMP Layout" (when (frame-p *current-child*) ;; Note: There is no need to ungrab/grab keys because this ;; is done when leaving the second mode. (define-main-key ("F8" :mod-1) 'add-in-main-window-list) (define-main-key ("F9" :mod-1) 'remove-in-main-window-list) (define-main-key ("F10" :mod-1) 'clear-main-window-list) (define-main-key ("Tab" :mod-1) 'select-next-child-no-main-window) (define-main-key ("Tab" :mod-1 :shift) 'select-previous-child-no-main-window) (define-main-mouse (1) 'mouse-click-to-focus-and-move-no-main-window) (setf (frame-data-slot *current-child* :focus-policy-save) (frame-focus-policy *current-child*)) (setf (frame-focus-policy *current-child*) :sloppy) (setf (frame-data-slot *current-child* :layout-save) (frame-layout *current-child*)) (open-notify-window help-text-list) (add-timer *gimp-layout-notify-window-delay* #'close-notify-window) ;; Set the default layout and leave the second mode. (set-main-window-right-layout)))) (defun set-previous-layout () "Restore the previous layout" (undefine-main-key ("F8" :mod-1)) (undefine-main-key ("F9" :mod-1)) (undefine-main-key ("F10" :mod-1)) (define-main-key ("Tab" :mod-1) 'select-next-child) (define-main-key ("Tab" :mod-1 :shift) 'select-previous-child) (define-main-mouse (1) 'mouse-click-to-focus-and-move) (setf (frame-focus-policy *current-child*) (frame-data-slot *current-child* :focus-policy-save)) (setf (frame-layout *current-child*) (frame-data-slot *current-child* :layout-save)) (leave-second-mode)) (register-layout-sub-menu 'frame-gimp-layout-menu "The GIMP layout menu" '(("g" set-gimp-layout) ("p" set-previous-layout) ("h" help-on-gimp-layout) "-=- Main window layout -=-" ("r" set-main-window-right-layout) ("l" set-main-window-left-layout) ("t" set-main-window-top-layout) ("b" set-main-window-bottom-layout) "-=- Actions on main windows list -=-" ("a" add-in-main-window-list) ("v" remove-in-main-window-list) ("c" clear-main-window-list))) clfswm-20111015.git51b0a02/src/clfswm-menu.lisp000066400000000000000000000135351164636077000206540ustar00rootroot00000000000000;;; -------------------------------------------------------------------------- ;;; CLFSWM - FullScreen Window Manager ;;; ;;; -------------------------------------------------------------------------- ;;; Documentation: Menu functions ;;; -------------------------------------------------------------------------- ;;; ;;; (C) 2011 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;; ;;; -------------------------------------------------------------------------- (in-package :clfswm) (defmacro with-all-menu ((menu item) &body body) (let ((rec (gensym)) (subm (gensym))) `(labels ((,rec (,item) ,@body (when (menu-p ,item) (dolist (,subm (menu-item ,item)) (,rec ,subm))) (when (and (menu-item-p ,item) (menu-p (menu-item-value ,item))) (,rec (menu-item-value ,item))))) (,rec ,menu)))) (defun add-item (item &optional (menu *menu*)) (setf (menu-item menu) (nconc (menu-item menu) (list item)))) (defun del-item (item &optional (menu *menu*)) (setf (menu-item menu) (remove item (menu-item menu)))) ;;; Finding functions (defun find-menu (name &optional (root *menu*)) (with-all-menu (root item) (when (and (menu-p item) (equal name (menu-name item))) (return-from find-menu item)))) (defun find-toplevel-menu (name &optional (root *menu*)) (when (menu-p root) (dolist (item (menu-item root)) (when (and (menu-item-p item) (menu-p (menu-item-value item))) (when (equal name (menu-name (menu-item-value item))) (return (menu-item-value item))))))) (defun find-item-by-key (key &optional (root *menu*)) (with-all-menu (root item) (when (and (menu-item-p item) (equal (menu-item-key item) key)) (return-from find-item-by-key item)))) (defun find-item-by-value (value &optional (root *menu*)) (with-all-menu (root item) (when (and (menu-item-p item) (equal (menu-item-value item) value)) (return-from find-item-by-value item)))) (defun del-item-by-key (key &optional (menu *menu*)) (del-item (find-item-by-key key menu) menu)) (defun del-item-by-value (value &optional (menu *menu*)) (del-item (find-item-by-value value menu) menu)) ;;; Convenient functions (defun find-next-menu-key (key menu) "key is :next for the next free key in menu or a string" (if (eql key :next) (string (number->char (length (menu-item menu)))) key)) (defun add-menu-key (menu-name key value &optional (root *menu*)) (let ((menu (find-menu menu-name root))) (add-item (make-menu-item :key (find-next-menu-key key menu) :value value) (find-menu menu-name root)))) (defun add-sub-menu (menu-or-name key sub-menu-name &optional (doc "Sub menu") (root *menu*)) (let ((menu (if (or (stringp menu-or-name) (symbolp menu-or-name)) (find-menu menu-or-name root) menu-or-name)) (submenu (make-menu :name sub-menu-name :doc doc))) (add-item (make-menu-item :key (find-next-menu-key key menu) :value submenu) menu) submenu)) (defun del-menu-key (menu-name key &optional (root *menu*)) (del-item-by-key key (find-menu menu-name root))) (defun del-menu-value (menu-name value &optional (root *menu*)) (del-item-by-value value (find-menu menu-name root))) (defun del-sub-menu (menu-name sub-menu-name &optional (root *menu*)) (del-item-by-value (find-menu sub-menu-name) (find-menu menu-name root))) (defun clear-sub-menu (menu-name sub-menu-name &optional (root *menu*)) (setf (menu-item (find-menu sub-menu-name (find-menu menu-name root))) nil)) (defun add-menu-comment (menu-name &optional (comment "---") (root *menu*)) (add-item (make-menu-item :key nil :value comment) (find-menu menu-name root))) (defun init-menu () (setf *menu* (make-menu :name 'main :doc "Main menu"))) ;;; Display menu functions (defun open-menu-do-action (action menu parent) (typecase action (menu (open-menu action (cons menu parent))) (null (awhen (first parent) (open-menu it (rest parent)))) (t (when (fboundp action) (funcall action))))) (defun open-menu (&optional (menu *menu*) (parent nil)) "Open the main menu" (let ((action nil) (old-info-keys (copy-hash-table *info-keys*))) (labels ((populate-menu () (let ((info-list nil)) (dolist (item (menu-item menu)) (let ((value (menu-item-value item))) (push (typecase value (menu (list (list (format nil "~A" (menu-item-key item)) *menu-color-menu-key*) (list (format nil ": < ~A >" (menu-doc value)) *menu-color-submenu*))) (string (list (list (format nil "~A" (menu-item-value item)) *menu-color-comment*))) (t (list (list (format nil "~A" (menu-item-key item)) *menu-color-key*) (format nil ": ~A" (documentation value 'function))))) info-list) (when (menu-item-key item) (define-info-key-fun (list (menu-item-key item)) (lambda (&optional args) (declare (ignore args)) (setf action value) (leave-info-mode nil)))))) (nreverse info-list)))) (let ((selected-item (info-mode (populate-menu)))) (setf *info-keys* old-info-keys) (when selected-item (awhen (nth selected-item (menu-item menu)) (setf action (menu-item-value it))))) (open-menu-do-action action menu parent)))) clfswm-20111015.git51b0a02/src/clfswm-nw-hooks.lisp000066400000000000000000000217331164636077000214540ustar00rootroot00000000000000;;; -------------------------------------------------------------------------- ;;; CLFSWM - FullScreen Window Manager ;;; ;;; -------------------------------------------------------------------------- ;;; Documentation: New window Hooks ;;; ;;; Those hooks can be set for each frame to manage new window when they are ;;; mapped. ;;; -------------------------------------------------------------------------- ;;; ;;; (C) 2011 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;; ;;; -------------------------------------------------------------------------- (in-package :clfswm) ;;; CONFIG - New window menu ;;; ;;; To add a new window hook (nw-hook): ;;; 1- define your own nw-hook ;;; 2- Define a seter function for your new hook ;;; 3- Register your new hook with register-nw-hook. (defparameter *nw-hook-current-key* (char-code #\a)) (defparameter *permanent-nw-hook-frames* nil) (defun set-nw-hook (hook) "Set the hook of the current child" (let ((frame (if (xlib:window-p *current-child*) (find-parent-frame *current-child*) *current-child*))) (unless (child-member frame *permanent-nw-hook-frames*) (setf (frame-nw-hook frame) hook) (leave-second-mode)))) (defun register-nw-hook (hook) (add-menu-key 'frame-nw-hook-menu (code-char *nw-hook-current-key*) hook) (incf *nw-hook-current-key*)) (defun default-window-placement (frame window) (if (managed-window-p window frame) (adapt-child-to-parent window frame) (place-window-from-hints window))) (defun leave-if-not-frame (child) "Leave the child if it's not a frame" (unless (frame-p child) (leave-frame) (select-previous-level))) (defun clear-nw-hook (frame) "Clear the frame new window hook" (unless (child-member frame *permanent-nw-hook-frames*) (setf (frame-nw-hook frame) nil))) (defun clear-all-nw-hooks () "Clear all new window hooks for all frames" (with-all-frames (*root-frame* frame) (clear-nw-hook frame))) (defun make-permanent-nw-hook-frame (frame) "Prevent to add or delete a new window hook for this frame" (when (frame-p frame) (push frame *permanent-nw-hook-frames*))) ;;; Default frame new window hook (defun default-frame-nw-hook (frame window) "Open the next window in the current frame" (declare (ignore frame)) (leave-if-not-frame *current-child*) (when (frame-p *current-child*) (pushnew window (frame-child *current-child*))) (default-window-placement *current-child* window) t) (defun set-default-frame-nw-hook () "Open the next window in the current frame" (set-nw-hook #'default-frame-nw-hook)) (register-nw-hook 'set-default-frame-nw-hook) ;;; Open new window in current root hook (defun open-in-current-root-nw-hook (frame window) "Open the next window in the current root" (clear-nw-hook frame) (leave-if-not-frame *current-root*) (pushnew window (frame-child *current-root*)) (setf *current-child* (frame-selected-child *current-root*)) (default-window-placement *current-root* window) t) (defun set-open-in-current-root-nw-hook () "Open the next window in the current root" (set-nw-hook #'open-in-current-root-nw-hook)) (register-nw-hook 'set-open-in-current-root-nw-hook) ;;; Open new window in a new frame in the current root hook (defun open-in-new-frame-in-current-root-nw-hook (frame window) "Open the next window in a new frame in the current root" (clear-nw-hook frame) (leave-if-not-frame *current-root*) (let ((new-frame (create-frame))) (pushnew new-frame (frame-child *current-root*)) (pushnew window (frame-child new-frame)) (setf *current-child* new-frame) (default-window-placement new-frame window)) t) (defun set-open-in-new-frame-in-current-root-nw-hook () "Open the next window in a new frame in the current root" (set-nw-hook #'open-in-new-frame-in-current-root-nw-hook)) (register-nw-hook 'set-open-in-new-frame-in-current-root-nw-hook) ;;; Open new window in a new frame in the root frame hook (defun open-in-new-frame-in-root-frame-nw-hook (frame window) "Open the next window in a new frame in the root frame" (clear-nw-hook frame) (let ((new-frame (create-frame))) (pushnew new-frame (frame-child *root-frame*)) (pushnew window (frame-child new-frame)) (switch-to-root-frame :show-later t) (setf *current-child* *current-root*) (set-layout-once #'tile-space-layout) (setf *current-child* new-frame) (default-window-placement new-frame window)) t) (defun set-open-in-new-frame-in-root-frame-nw-hook () "Open the next window in a new frame in the root frame" (set-nw-hook #'open-in-new-frame-in-root-frame-nw-hook)) (register-nw-hook 'set-open-in-new-frame-in-root-frame-nw-hook) ;;; Open new window in a new frame in the parent frame hook (defun open-in-new-frame-in-parent-frame-nw-hook (frame window) "Open the next window in a new frame in the parent frame" (clear-nw-hook frame) (let ((new-frame (create-frame)) (parent (find-parent-frame frame))) (when parent (pushnew new-frame (frame-child parent)) (pushnew window (frame-child new-frame)) (setf *current-root* parent *current-child* parent) (set-layout-once #'tile-space-layout) (setf *current-child* new-frame) (default-window-placement new-frame window) (show-all-children t) t))) (defun set-open-in-new-frame-in-parent-frame-nw-hook () "Open the next window in a new frame in the parent frame" (set-nw-hook #'open-in-new-frame-in-parent-frame-nw-hook)) (register-nw-hook 'set-open-in-new-frame-in-parent-frame-nw-hook) ;;; Open a new window but leave the focus on the current child (defun leave-focus-frame-nw-hook (frame window) "Open the next window in the current frame and leave the focus on the current child" (clear-nw-hook frame) (leave-if-not-frame *current-child*) (when (frame-p *current-child*) (with-slots (child) *current-child* (pushnew window child) (setf child (rotate-list child)))) (default-window-placement *current-child* window) t) (defun set-leave-focus-frame-nw-hook () "Open the next window in the current frame and leave the focus on the current child" (set-nw-hook #'leave-focus-frame-nw-hook)) (register-nw-hook 'set-leave-focus-frame-nw-hook) (defun nw-hook-open-in-frame (window frame) (when (frame-p frame) (pushnew window (frame-child frame)) (unless (find-child frame *current-root*) (setf *current-root* frame)) (setf *current-child* frame) (focus-all-children window frame) (default-window-placement frame window) (show-all-children t) t)) ;;; Open a new window in a named frame (defun named-frame-nw-hook (frame window) (clear-nw-hook frame) (let* ((frame-name (ask-frame-name "Open the next window in frame named:")) (new-frame (find-frame-by-name frame-name))) (nw-hook-open-in-frame window new-frame)) t) (defun set-named-frame-nw-hook () "Open the next window in a named frame" (set-nw-hook #'named-frame-nw-hook)) (register-nw-hook 'set-named-frame-nw-hook) ;;; Open a new window in a numbered frame (defun numbered-frame-nw-hook (frame window) (clear-nw-hook frame) (let ((new-frame (find-frame-by-number (query-number "Open a new frame in the group numbered:")))) (nw-hook-open-in-frame window new-frame)) t) (defun set-numbered-frame-nw-hook () "Open the next window in a numbered frame" (set-nw-hook #'numbered-frame-nw-hook)) (register-nw-hook 'set-numbered-frame-nw-hook) ;;; Absorb window. ;;; The frame absorb the new window if it match the nw-absorb-test ;;; frame data slot. (defun absorb-window-nw-hook (frame window) (let ((absorb-nw-test (frame-data-slot frame :nw-absorb-test))) (when (and absorb-nw-test (funcall absorb-nw-test window)) (pushnew window (frame-child frame)) (unless *in-process-existing-windows* (unless (find-child frame *current-root*) (setf *current-root* frame)) (setf *current-child* frame) (focus-all-children window frame) (default-window-placement frame window) (show-all-children t)) (throw 'nw-hook-loop t))) nil) (defun set-absorb-window-nw-hook () "Open the window in this frame if it match nw-absorb-test" (set-nw-hook #'absorb-window-nw-hook)) (register-nw-hook 'set-absorb-window-nw-hook) (defun nw-absorb-test-class (class-string) (lambda (c) (and (xlib:window-p c) (string-equal (xlib:get-wm-class c) class-string)))) clfswm-20111015.git51b0a02/src/clfswm-pack.lisp000066400000000000000000000311321164636077000206170ustar00rootroot00000000000000;;; -------------------------------------------------------------------------- ;;; CLFSWM - FullScreen Window Manager ;;; ;;; -------------------------------------------------------------------------- ;;; Documentation: Tile, pack and fill functions ;;; -------------------------------------------------------------------------- ;;; ;;; (C) 2011 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;; ;;; -------------------------------------------------------------------------- (in-package :clfswm) ;;;,----- ;;;| Edges functions ;;;`----- (defun frame-x2 (frame) (+ (frame-x frame) (frame-w frame))) (defun frame-y2 (frame) (+ (frame-y frame) (frame-h frame))) (defun find-edge-up (current-frame parent) (let ((y-found 0)) (dolist (frame (frame-child parent)) (when (and (frame-p frame) (not (equal frame current-frame)) (<= (frame-y2 frame) (frame-y current-frame)) (>= (frame-x2 frame) (frame-x current-frame)) (<= (frame-x frame) (frame-x2 current-frame))) (setf y-found (max y-found (frame-y2 frame))))) y-found)) (defun find-edge-down (current-frame parent) (let ((y-found 1)) (dolist (frame (frame-child parent)) (when (and (frame-p frame) (not (equal frame current-frame)) (>= (frame-y frame) (frame-y2 current-frame)) (>= (frame-x2 frame) (frame-x current-frame)) (<= (frame-x frame) (frame-x2 current-frame))) (setf y-found (min y-found (frame-y frame))))) y-found)) (defun find-edge-right (current-frame parent) (let ((x-found 1)) (dolist (frame (frame-child parent)) (when (and (frame-p frame) (not (equal frame current-frame)) (>= (frame-x frame) (frame-x2 current-frame)) (>= (frame-y2 frame) (frame-y current-frame)) (<= (frame-y frame) (frame-y2 current-frame))) (setf x-found (min x-found (frame-x frame))))) x-found)) (defun find-edge-left (current-frame parent) (let ((x-found 0)) (dolist (frame (frame-child parent)) (when (and (frame-p frame) (not (equal frame current-frame)) (<= (frame-x2 frame) (frame-x current-frame)) (>= (frame-y2 frame) (frame-y current-frame)) (<= (frame-y frame) (frame-y2 current-frame))) (setf x-found (max x-found (frame-x2 frame))))) x-found)) ;;;,----- ;;;| Pack functions ;;;`----- (defun pack-frame-up (frame parent) "Pack frame to up" (let ((y-found (find-edge-up frame parent))) (setf (frame-y frame) y-found))) (defun pack-frame-down (frame parent) "Pack frame to down" (let ((y-found (find-edge-down frame parent))) (setf (frame-y frame) (- y-found (frame-h frame))))) (defun pack-frame-right (frame parent) "Pack frame to right" (let ((x-found (find-edge-right frame parent))) (setf (frame-x frame) (- x-found (frame-w frame))))) (defun pack-frame-left (frame parent) "Pack frame to left" (let ((x-found (find-edge-left frame parent))) (setf (frame-x frame) x-found))) (defun center-frame (frame) "Center frame" (setf (frame-x frame) (/ (- 1 (frame-w frame)) 2) (frame-y frame) (/ (- 1 (frame-h frame)) 2))) ;;;,----- ;;;| Fill functions ;;;`----- (defun fill-frame-up (frame parent) "Fill a frame up" (let* ((y-found (find-edge-up frame parent)) (dy (- (frame-y frame) y-found))) (setf (frame-y frame) y-found (frame-h frame) (+ (frame-h frame) dy)))) (defun fill-frame-down (frame parent) "Fill a frame down" (let* ((y-found (find-edge-down frame parent)) (dy (- y-found (frame-y2 frame)))) (setf (frame-h frame) (+ (frame-h frame) dy)))) (defun fill-frame-left (frame parent) "Fill a frame left" (let* ((x-found (find-edge-left frame parent)) (dx (- (frame-x frame) x-found))) (setf (frame-x frame) x-found (frame-w frame) (+ (frame-w frame) dx)))) (defun fill-frame-right (frame parent) "Fill a frame rigth" (let* ((x-found (find-edge-right frame parent)) (dx (- x-found (frame-x2 frame)))) (setf (frame-w frame) (+ (frame-w frame) dx)))) ;;;,----- ;;;| Lower functions ;;;`----- (defun resize-frame-down (frame) "Resize down a frame" (when (> (frame-w frame) 0.1) (setf (frame-x frame) (+ (frame-x frame) 0.01) (frame-w frame) (max (- (frame-w frame) 0.02) 0.01))) (when (> (frame-h frame) 0.1) (setf (frame-y frame) (+ (frame-y frame) 0.01) (frame-h frame) (max (- (frame-h frame) 0.02) 0.01)))) (defun resize-minimal-frame (frame) "Resize down a frame to its minimal size" (dotimes (i 100) (resize-frame-down frame))) (defun resize-half-width-left (frame) (setf (frame-w frame)(/ (frame-w frame) 2))) (defun resize-half-width-right (frame) (let* ((new-size (/ (frame-w frame) 2)) (dx (- (frame-w frame) new-size))) (setf (frame-w frame) new-size) (incf (frame-x frame) (max dx 0)))) (defun resize-half-height-up (frame) (setf (frame-h frame) (/ (frame-h frame) 2))) (defun resize-half-height-down (frame) (let* ((new-size (/ (frame-h frame) 2)) (dy (- (frame-h frame) new-size))) (setf (frame-h frame) new-size) (incf (frame-y frame) (max dy 0)))) ;;;;;,----- ;;;;;| Explode/Implode functions ;;;;;`----- (defun explode-frame (frame) "Create a new frame for each window in frame" (when (frame-p frame) (let ((windows (loop :for child :in (frame-child frame) :when (xlib:window-p child) :collect child))) (dolist (win windows) (add-frame (create-frame :child (list win)) frame) (remove-child-in-frame win frame))))) (defun explode-current-frame () "Create a new frame for each window in frame" (explode-frame *current-child*) (leave-second-mode)) (defun implode-frame (frame) "Absorb all frames subchildren in frame (explode frame opposite)" (when (frame-p frame) (dolist (child (frame-child frame)) (when (frame-p child) (dolist (subchild (frame-child child)) (setf (frame-child frame) (append (frame-child frame) (list subchild)))) (hide-child child) (remove-child-in-frame child frame))))) (defun implode-current-frame () "Absorb all frames subchildren in frame (explode frame opposite)" (implode-frame *current-child*) (leave-second-mode)) ;;;;;,----- ;;;;;| Constrained move/resize frames ;;;;;`----- (labels ((readjust-all-frames-fl-size (parent) (dolist (child (frame-child parent)) (when (frame-p child) (setf (frame-x child) (x-px->fl (xlib:drawable-x (frame-window child)) parent) (frame-y child) (y-px->fl (xlib:drawable-y (frame-window child)) parent) (frame-w child) (w-px->fl (anti-adj-border-wh (xlib:drawable-width (frame-window child)) parent) parent) (frame-h child) (h-px->fl (anti-adj-border-wh (xlib:drawable-height (frame-window child)) parent) parent)))))) (defun move-frame-constrained (frame parent orig-x orig-y) (when (and frame parent (not (child-equal-p frame *current-root*))) (hide-all-children frame) (with-slots (window) frame (let ((lx orig-x) (ly orig-y)) (readjust-all-frames-fl-size parent) (move-window window orig-x orig-y (lambda () (let ((move-x t) (move-y t)) (setf (frame-x frame) (x-px->fl (xlib:drawable-x window) parent) (frame-y frame) (y-px->fl (xlib:drawable-y window) parent)) (multiple-value-bind (x y) (xlib:query-pointer *root*) (when (> x lx) (let ((x-found (x-fl->px (find-edge-right frame parent) parent))) (when (< (abs (- x-found (window-x2 window))) *snap-size*) (setf (xlib:drawable-x window) (- x-found (adj-border-xy (xlib:drawable-width window) window)) (frame-x frame) (x-px->fl (xlib:drawable-x window) parent) move-x nil)))) (when (< x lx) (let ((x-found (x-fl->px (find-edge-left frame parent) parent))) (when (< (abs (- x-found (xlib:drawable-x window))) *snap-size*) (setf (xlib:drawable-x window) (adj-border-xy x-found window) (frame-x frame) (x-px->fl (xlib:drawable-x window) parent) move-x nil)))) (when (> y ly) (let ((y-found (y-fl->px (find-edge-down frame parent) parent))) (when (< (abs (- y-found (window-y2 window))) *snap-size*) (setf (xlib:drawable-y window) (- y-found (adj-border-xy (xlib:drawable-height window) window)) (frame-y frame) (y-px->fl (xlib:drawable-y window) parent) move-y nil)))) (when (< y ly) (let ((y-found (y-fl->px (find-edge-up frame parent) parent))) (when (< (abs (- y-found (xlib:drawable-y window))) *snap-size*) (setf (xlib:drawable-y window) (adj-border-xy y-found window) (frame-y frame) (y-px->fl (xlib:drawable-y window) parent) move-y nil)))) (display-frame-info frame) (when move-x (setf lx x)) (when move-y (setf ly y)) (values move-x move-y))))))) (show-all-children))) (defun resize-frame-constrained (frame parent orig-x orig-y) (when (and frame parent (not (child-equal-p frame *current-root*))) (hide-all-children frame) (with-slots (window) frame (let ((lx orig-x) (ly orig-y)) (readjust-all-frames-fl-size parent) (resize-window window orig-x orig-y (lambda () (let ((resize-w t) (resize-h t)) (multiple-value-bind (x y) (xlib:query-pointer *root*) (setf (frame-w frame) (w-px->fl (anti-adj-border-wh (xlib:drawable-width window) parent) parent) (frame-h frame) (h-px->fl (anti-adj-border-wh (xlib:drawable-height window) parent) parent)) (when (> x lx) (let ((x-found (x-fl->px (find-edge-right frame parent) parent))) (when (< (abs (- x-found (window-x2 window))) *snap-size*) (setf (xlib:drawable-width window) (+ (xlib:drawable-width window) (- x-found (adj-border-xy (window-x2 window) parent))) (frame-w frame) (w-px->fl (anti-adj-border-wh (xlib:drawable-width window) parent) parent) resize-w nil)))) (when (> y ly) (let ((y-found (y-fl->px (find-edge-down frame parent) parent))) (when (< (abs (- y-found (window-y2 window))) *snap-size*) (setf (xlib:drawable-height window) (+ (xlib:drawable-height window) (- y-found (adj-border-xy (window-y2 window) parent))) (frame-h frame) (h-px->fl (anti-adj-border-wh (xlib:drawable-height window) parent) parent) resize-h nil)))) (display-frame-info frame) (when resize-w (setf lx x)) (when resize-h (setf ly y)) (values resize-w resize-h))))))) (show-all-children)))) clfswm-20111015.git51b0a02/src/clfswm-placement.lisp000066400000000000000000000137011164636077000216530ustar00rootroot00000000000000;;; -------------------------------------------------------------------------- ;;; CLFSWM - FullScreen Window Manager ;;; ;;; -------------------------------------------------------------------------- ;;; Documentation: Placement functions ;;; -------------------------------------------------------------------------- ;;; ;;; (C) 2011 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;; ;;; -------------------------------------------------------------------------- (in-package :clfswm) (defun get-placement-values (placement &optional (width 0) (height 0)) (typecase placement (list (values (first placement) (second placement))) (function (funcall placement width height)) (symbol (if (fboundp placement) (funcall placement width height) (values 0 0))) (t (values 0 0)))) (defmacro with-placement ((placement x y &optional (width 0) (height 0)) &body body) `(multiple-value-bind (,x ,y) (get-placement-values ,placement ,width ,height) ,@body)) ;;;; Test functions ;; ;;(defun fun-placement (&optional width height) ;; (declare (ignore width height)) ;; (values 30 40)) ;; ;;(defparameter *placement-test* (list 10 20)) ;;;;(defparameter *placement-test* #'fun-placement) ;;;;(defparameter *placement-test* 'fun-placement) ;; ;;(defun toto () ;; (with-placement (*placement-test* x y) ;; (format t "X=~A Y=~A~%" x y))) ;;; ;;; Absolute placement ;;; (defun top-left-placement (&optional (width 0) (height 0)) (declare (ignore width height)) (values 0 0)) (defun top-middle-placement (&optional (width 0) (height 0)) (declare (ignore height)) (values (truncate (/ (- (xlib:screen-width *screen*) width) 2)) 0)) (defun top-right-placement (&optional (width 0) (height 0)) (declare (ignore height)) (values (- (xlib:screen-width *screen*) width (* *border-size* 2)) 0)) (defun middle-left-placement (&optional (width 0) (height 0)) (declare (ignore width)) (values 0 (truncate (/ (- (xlib:screen-height *screen*) height) 2)))) (defun middle-middle-placement (&optional (width 0) (height 0)) (values (truncate (/ (- (xlib:screen-width *screen*) width) 2)) (truncate (/ (- (xlib:screen-height *screen*) height) 2)))) (defun middle-right-placement (&optional (width 0) (height 0)) (values (- (xlib:screen-width *screen*) width (* *border-size* 2)) (truncate (/ (- (xlib:screen-height *screen*) height) 2)))) (defun bottom-left-placement (&optional (width 0) (height 0)) (declare (ignore width)) (values 0 (- (xlib:screen-height *screen*) height (* *border-size* 2)))) (defun bottom-middle-placement (&optional (width 0) (height 0)) (values (truncate (/ (- (xlib:screen-width *screen*) width) 2)) (- (xlib:screen-height *screen*) height (* *border-size* 2)))) (defun bottom-right-placement (&optional (width 0) (height 0)) (values (- (xlib:screen-width *screen*) width (* *border-size* 2)) (- (xlib:screen-height *screen*) height (* *border-size* 2)))) ;;; ;;; Current child placement ;;; (defun current-child-coord () (typecase *current-child* (xlib:window (values (xlib:drawable-x *current-child*) (xlib:drawable-y *current-child*) (xlib:drawable-width *current-child*) (xlib:drawable-height *current-child*))) (frame (values (frame-rx *current-child*) (frame-ry *current-child*) (frame-rw *current-child*) (frame-rh *current-child*))) (t (values 0 0 10 10)))) (defmacro with-current-child-coord ((x y w h) &body body) `(multiple-value-bind (,x ,y ,w ,h) (current-child-coord) ,@body)) (defun top-left-child-placement (&optional (width 0) (height 0)) (declare (ignore width height)) (with-current-child-coord (x y w h) (declare (ignore w h)) (values (+ x 2) (+ y 2)))) (defun top-middle-child-placement (&optional (width 0) (height 0)) (declare (ignore height)) (with-current-child-coord (x y w h) (declare (ignore h)) (values (+ x (truncate (/ (- w width) 2))) (+ y 2)))) (defun top-right-child-placement (&optional (width 0) (height 0)) (declare (ignore height)) (with-current-child-coord (x y w h) (declare (ignore h)) (values (+ x (- w width 2)) (+ y 2)))) (defun middle-left-child-placement (&optional (width 0) (height 0)) (declare (ignore width)) (with-current-child-coord (x y w h) (declare (ignore w)) (values (+ x 2) (+ y (truncate (/ (- h height) 2)))))) (defun middle-middle-child-placement (&optional (width 0) (height 0)) (with-current-child-coord (x y w h) (values (+ x (truncate (/ (- w width) 2))) (+ y (truncate (/ (- h height) 2)))))) (defun middle-right-child-placement (&optional (width 0) (height 0)) (with-current-child-coord (x y w h) (values (+ x (- w width 2)) (+ y (truncate (/ (- h height) 2)))))) (defun bottom-left-child-placement (&optional (width 0) (height 0)) (declare (ignore width)) (with-current-child-coord (x y w h) (declare (ignore w)) (values (+ x 2) (+ y (- h height 2))))) (defun bottom-middle-child-placement (&optional (width 0) (height 0)) (with-current-child-coord (x y w h) (values (+ x (truncate (/ (- w width) 2))) (+ y (- h height 2))))) (defun bottom-right-child-placement (&optional (width 0) (height 0)) (with-current-child-coord (x y w h) (values (+ x (- w width 2)) (+ y (- h height 2))))) clfswm-20111015.git51b0a02/src/clfswm-query.lisp000066400000000000000000000272111164636077000210510ustar00rootroot00000000000000;;; -------------------------------------------------------------------------- ;;; CLFSWM - FullScreen Window Manager ;;; ;;; -------------------------------------------------------------------------- ;;; Documentation: Query utility ;;; -------------------------------------------------------------------------- ;;; ;;; (C) 2011 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;; ;;; -------------------------------------------------------------------------- (in-package :clfswm) (defparameter *query-window* nil) (defparameter *query-font* nil) (defparameter *query-gc* nil) (defparameter *query-history* nil) (defparameter *query-complet-list* nil) (defparameter *query-message* nil) (defparameter *query-string* nil) (defparameter *query-pos* nil) (defparameter *query-return* nil) (defun query-show-paren (orig-string pos dec) "Replace matching parentheses with brackets" (let ((string (copy-seq orig-string))) (labels ((have-to-find-right? () (and (< pos (length string)) (char= (aref string pos) #\())) (have-to-find-left? () (and (> (1- pos) 0) (char= (aref string (1- pos)) #\)))) (pos-right () (loop :for p :from (1+ pos) :below (length string) :with level = 1 :for c = (aref string p) :do (when (char= c #\() (incf level)) (when (char= c #\)) (decf level)) (when (= level 0) (return p)))) (pos-left () (loop :for p :from (- pos 2) :downto 0 :with level = 1 :for c = (aref string p) :do (when (char= c #\() (decf level)) (when (char= c #\)) (incf level)) (when (= level 0) (return p)))) (draw-bloc (p &optional (color *query-parent-color*)) (setf (xlib:gcontext-foreground *query-gc*) (get-color color)) (xlib:draw-rectangle *pixmap-buffer* *query-gc* (+ 10 (* p (xlib:max-char-width *query-font*)) dec) (+ (xlib:max-char-ascent *query-font*) (xlib:max-char-descent *query-font*) 7) (xlib:max-char-width *query-font*) (+ (xlib:max-char-ascent *query-font*) (xlib:max-char-descent *query-font*)) t))) (cond ((have-to-find-left?) (let ((p (pos-left))) (if p (progn (draw-bloc p) (draw-bloc (1- pos))) (draw-bloc (1- pos) *query-parent-error-color*)))) ((have-to-find-right?) (let ((p (pos-right))) (if p (progn (draw-bloc p) (draw-bloc pos)) (draw-bloc pos *query-parent-error-color*)))))))) (defun clear-query-history () "Clear the query-string history" (setf *query-history* nil)) (defun leave-query-mode (&optional (return :Escape)) "Leave the query mode" (setf *query-return* return) (throw 'exit-query-loop nil)) (defun leave-query-mode-valid () (leave-query-mode :Return)) (add-hook *binding-hook* 'init-*query-keys*) (defun query-find-complet-list () (remove-if-not (lambda (x) (zerop (or (search *query-string* x :test #'string-equal) -1))) *query-complet-list*)) (defun query-print-string () (let ((dec (min 0 (- (- (xlib:drawable-width *query-window*) 10) (+ 10 (* *query-pos* (xlib:max-char-width *query-font*))))))) (clear-pixmap-buffer *query-window* *query-gc*) (setf (xlib:gcontext-foreground *query-gc*) (get-color *query-message-color*)) (xlib:draw-glyphs *pixmap-buffer* *query-gc* 5 (+ (xlib:max-char-ascent *query-font*) 5) (format nil "~A ~{~A~^, ~}" *query-message* (query-find-complet-list))) (when (< *query-pos* 0) (setf *query-pos* 0)) (when (> *query-pos* (length *query-string*)) (setf *query-pos* (length *query-string*))) (query-show-paren *query-string* *query-pos* dec) (setf (xlib:gcontext-foreground *query-gc*) (get-color *query-foreground*)) (xlib:draw-glyphs *pixmap-buffer* *query-gc* (+ 10 dec) (+ (* 2 (+ (xlib:max-char-ascent *query-font*) (xlib:max-char-descent *query-font*))) 5) *query-string*) (setf (xlib:gcontext-foreground *query-gc*) (get-color *query-cursor-color*)) (xlib:draw-line *pixmap-buffer* *query-gc* (+ 10 (* *query-pos* (xlib:max-char-width *query-font*)) dec) (+ (* 2 (+ (xlib:max-char-ascent *query-font*) (xlib:max-char-descent *query-font*))) 6) (+ 10 (* *query-pos* (xlib:max-char-width *query-font*)) dec) (+ (* 1 (+ (xlib:max-char-ascent *query-font*) (xlib:max-char-descent *query-font*))) 7)) (copy-pixmap-buffer *query-window* *query-gc*))) (defun query-enter-function () (setf *query-font* (xlib:open-font *display* *query-font-string*)) (let ((width (- (xlib:screen-width *screen*) 2)) (height (* 3 (+ (xlib:max-char-ascent *query-font*) (xlib:max-char-descent *query-font*))))) (with-placement (*query-mode-placement* x y width height) (setf *query-window* (xlib:create-window :parent *root* :x x :y y :width width :height height :background (get-color *query-background*) :border-width *border-size* :border (get-color *query-border*) :colormap (xlib:screen-default-colormap *screen*) :event-mask '(:exposure :key-press)) *query-gc* (xlib:create-gcontext :drawable *query-window* :foreground (get-color *query-foreground*) :background (get-color *query-background*) :font *query-font* :line-style :solid)) (map-window *query-window*) (query-print-string) (wait-no-key-or-button-press)))) (defun query-leave-function () (xlib:destroy-window *query-window*) (xlib:close-font *query-font*) (wait-no-key-or-button-press)) (defun query-loop-function () (raise-window *query-window*)) (labels ((generic-backspace (del-pos) (when (>= del-pos 0) (setf *query-string* (concatenate 'string (subseq *query-string* 0 del-pos) (subseq *query-string* *query-pos*)) *query-pos* del-pos)))) (defun query-backspace () "Delete a character backward" (generic-backspace (1- *query-pos*))) (defun query-backspace-word () "Delete a word backward" (generic-backspace (or (position #\Space *query-string* :from-end t :end *query-pos*) 0)))) (labels ((generic-delete (del-pos) (when (<= del-pos (length *query-string*)) (setf *query-string* (concatenate 'string (subseq *query-string* 0 *query-pos*) (subseq *query-string* del-pos)))))) (defun query-delete () "Delete a character forward" (generic-delete (1+ *query-pos*))) (defun query-delete-word () "Delete a word forward" (generic-delete (1+ (or (position #\Space *query-string* :start *query-pos*) (1- (length *query-string*))))))) (defun query-home () "Move cursor to line begining" (setf *query-pos* 0)) (defun query-end () "Move cursor to line end" (setf *query-pos* (length *query-string*))) (defun query-left () "Move cursor to left" (when (> *query-pos* 0) (setf *query-pos* (1- *query-pos*)))) (defun query-left-word () "Move cursor to left word" (when (> *query-pos* 0) (setf *query-pos* (let ((p (position #\Space *query-string* :end (min (1- *query-pos*) (length *query-string*)) :from-end t))) (if p p 0))))) (defun query-right () "Move cursor to right" (when (< *query-pos* (length *query-string*)) (setf *query-pos* (1+ *query-pos*)))) (defun query-right-word () "Move cursor to right word" (when (< *query-pos* (length *query-string*)) (setf *query-pos* (let ((p (position #\Space *query-string* :start (min (1+ *query-pos*) (length *query-string*))))) (if p p (length *query-string*)))))) (defun query-previous-history () "Circulate backward in history" (setf *query-string* (first *query-history*) *query-pos* (length *query-string*) *query-history* (rotate-list *query-history*))) (defun query-next-history () "Circulate forward in history" (setf *query-string* (first *query-history*) *query-pos* (length *query-string*) *query-history* (anti-rotate-list *query-history*))) (defun query-delete-eof () "Delete the end of the line" (setf *query-string* (subseq *query-string* 0 *query-pos*))) (defun query-mode-complet () (setf *query-string* (find-common-string *query-string* (query-find-complet-list))) (let ((complet (query-find-complet-list))) (when (= (length complet) 1) (setf *query-string* (first complet)))) (query-end)) (add-hook *binding-hook* 'set-default-query-keys) (defun set-default-query-keys () (define-query-key ("Return") 'leave-query-mode-valid) (define-query-key ("Escape") 'leave-query-mode) (define-query-key ("g" :control) 'leave-query-mode) (define-query-key ("Tab") 'query-mode-complet) (define-query-key ("BackSpace") 'query-backspace) (define-query-key ("BackSpace" :control) 'query-backspace-word) (define-query-key ("Delete") 'query-delete) (define-query-key ("Delete" :control) 'query-delete-word) (define-query-key ("Home") 'query-home) (define-query-key ("End") 'query-end) (define-query-key ("Left") 'query-left) (define-query-key ("Left" :control) 'query-left-word) (define-query-key ("Right") 'query-right) (define-query-key ("Right" :control) 'query-right-word) (define-query-key ("Up") 'query-previous-history) (define-query-key ("Down") 'query-next-history) (define-query-key ("k" :control) 'query-delete-eof)) (defun add-in-query-string (code state) (let* ((modifiers (state->modifiers state)) (keysym (keycode->keysym code modifiers)) (char (xlib:keysym->character *display* keysym state))) (when (and char (characterp char)) (setf *query-string* (concatenate 'string (when (<= *query-pos* (length *query-string*)) (subseq *query-string* 0 *query-pos*)) (string char) (when (< *query-pos* (length *query-string*)) (subseq *query-string* *query-pos*)))) (incf *query-pos*)))) (define-handler query-mode :key-press (code state) (unless (funcall-key-from-code *query-keys* code state) (add-in-query-string code state)) (query-print-string)) (defun query-string (message &optional (default "") complet-list) "Query a string from the keyboard. Display msg as prompt" (let ((grab-keyboard-p (xgrab-keyboard-p)) (grab-pointer-p (xgrab-pointer-p))) (setf *query-message* message *query-string* default *query-pos* (length default) *query-complet-list* complet-list) (xgrab-pointer *root* 92 93) (unless grab-keyboard-p (ungrab-main-keys) (xgrab-keyboard *root*)) (generic-mode 'query-mode 'exit-query-loop :enter-function #'query-enter-function :loop-function #'query-loop-function :leave-function #'query-leave-function :original-mode '(main-mode)) (unless grab-keyboard-p (xungrab-keyboard) (grab-main-keys)) (if grab-pointer-p (xgrab-pointer *root* 66 67) (xungrab-pointer))) (when (equal *query-return* :Return) (pushnew default *query-history* :test #'equal) (push *query-string* *query-history*)) (values *query-string* *query-return*)) (defun query-number (msg &optional (default 0)) "Query a number from the query input" (parse-integer (or (query-string msg (format nil "~A" default)) "") :junk-allowed t)) clfswm-20111015.git51b0a02/src/clfswm-second-mode.lisp000066400000000000000000000131121164636077000220740ustar00rootroot00000000000000;;; -------------------------------------------------------------------------- ;;; CLFSWM - FullScreen Window Manager ;;; ;;; -------------------------------------------------------------------------- ;;; Documentation: Second mode functions ;;; -------------------------------------------------------------------------- ;;; ;;; (C) 2011 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;; ;;; -------------------------------------------------------------------------- (in-package :clfswm) (defparameter *sm-window* nil) (defparameter *sm-font* nil) (defparameter *sm-gc* nil) (defparameter *second-mode-leave-function* nil "Execute the function if not nil") (defun draw-second-mode-window () (raise-window *sm-window*) (clear-pixmap-buffer *sm-window* *sm-gc*) (let* ((text (format nil "Second mode")) (len (length text))) (xlib:draw-glyphs *pixmap-buffer* *sm-gc* (truncate (/ (- *sm-width* (* (xlib:max-char-width *sm-font*) len)) 2)) (truncate (/ (+ *sm-height* (- (xlib:font-ascent *sm-font*) (xlib:font-descent *sm-font*))) 2)) text)) (copy-pixmap-buffer *sm-window* *sm-gc*)) ;;; Second mode handlers (define-handler second-mode :key-press (code state) (funcall-key-from-code *second-keys* code state) (draw-second-mode-window)) (define-handler second-mode :enter-notify () (draw-second-mode-window)) (define-handler second-mode :motion-notify (window root-x root-y) (unless (compress-motion-notify) (funcall-button-from-code *second-mouse* 'motion (modifiers->state *default-modifiers*) window root-x root-y *fun-press*))) (define-handler second-mode :button-press (window root-x root-y code state) (funcall-button-from-code *second-mouse* code state window root-x root-y *fun-press*) (draw-second-mode-window)) (define-handler second-mode :button-release (window root-x root-y code state) (funcall-button-from-code *second-mouse* code state window root-x root-y *fun-release*) (draw-second-mode-window)) (define-handler second-mode :configure-request () (apply #'handle-event-fun-main-mode-configure-request event-slots) (draw-second-mode-window)) (define-handler second-mode :configure-notify () (draw-second-mode-window)) (define-handler second-mode :destroy-notify () (apply #'handle-event-fun-main-mode-destroy-notify event-slots) (draw-second-mode-window)) (define-handler second-mode :map-request () (apply #'handle-event-fun-main-mode-map-request event-slots) (draw-second-mode-window)) (define-handler second-mode :unmap-notify () (apply #'handle-event-fun-main-mode-unmap-notify event-slots) (draw-second-mode-window)) (define-handler second-mode :exposure () (apply #'handle-event-fun-main-mode-exposure event-slots) (draw-second-mode-window)) (defun sm-enter-function () (with-placement (*second-mode-placement* x y *sm-width* *sm-height*) (setf *in-second-mode* t *sm-window* (xlib:create-window :parent *root* :x x :y y :width *sm-width* :height *sm-height* :background (get-color *sm-background-color*) :border-width *border-size* :border (get-color *sm-border-color*) :colormap (xlib:screen-default-colormap *screen*) :event-mask '(:exposure)) *sm-font* (xlib:open-font *display* *sm-font-string*) *sm-gc* (xlib:create-gcontext :drawable *sm-window* :foreground (get-color *sm-foreground-color*) :background (get-color *sm-background-color*) :font *sm-font* :line-style :solid))) (map-window *sm-window*) (draw-second-mode-window) (no-focus) (ungrab-main-keys) (xgrab-keyboard *root*) (xgrab-pointer *root* 66 67) (speed-mouse-reset)) (defun sm-loop-function () (raise-window *sm-window*)) (defun sm-leave-function () (xlib:free-gcontext *sm-gc*) (xlib:close-font *sm-font*) (xlib:destroy-window *sm-window*) (xungrab-keyboard) (xungrab-pointer) (grab-main-keys) (show-all-children) (display-all-frame-info) (wait-no-key-or-button-press) (setf *in-second-mode* nil)) (defun second-key-mode () "Switch to editing mode (second mode)" (generic-mode 'second-mode 'exit-second-loop :enter-function #'sm-enter-function :loop-function #'sm-loop-function :leave-function #'sm-leave-function) (when *second-mode-leave-function* (funcall *second-mode-leave-function*) (setf *second-mode-leave-function* nil))) (defun leave-second-mode () "Leave second mode" (cond (*in-second-mode* (setf *in-second-mode* nil) (throw 'exit-second-loop nil)) (t (setf *in-second-mode* nil) (show-all-children)))) (defun sm-delete-focus-window () "Close focus window: Delete the focus window in all frames and workspaces" (setf *second-mode-leave-function* 'delete-focus-window) (leave-second-mode)) (defun sm-ask-close/kill-current-window () "Close or kill the current window (ask before doing anything)" (setf *second-mode-leave-function* #'ask-close/kill-current-window) (leave-second-mode)) clfswm-20111015.git51b0a02/src/clfswm-util.lisp000066400000000000000000001523131164636077000206630ustar00rootroot00000000000000;;; -------------------------------------------------------------------------- ;;; CLFSWM - FullScreen Window Manager ;;; ;;; -------------------------------------------------------------------------- ;;; Documentation: Utility ;;; -------------------------------------------------------------------------- ;;; ;;; (C) 2011 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;; ;;; -------------------------------------------------------------------------- (in-package :clfswm) ;;; Configuration file (defun xdg-config-home () (aif (getenv "XDG_CONFIG_HOME") (pathname-directory (concatenate 'string it "/")) (append (pathname-directory (user-homedir-pathname)) '(".config")))) (let ((saved-conf-name nil)) (defun conf-file-name (&optional alternate-name) (unless (and saved-conf-name (not alternate-name)) (let* ((user-conf (probe-file (merge-pathnames (user-homedir-pathname) #p".clfswmrc"))) (etc-conf (probe-file #p"/etc/clfswmrc")) (config-user-conf (probe-file (make-pathname :directory (append (xdg-config-home) '("clfswm")) :name "clfswmrc"))) (alternate-conf (and alternate-name (probe-file alternate-name)))) (setf saved-conf-name (or alternate-conf config-user-conf user-conf etc-conf)))) (print saved-conf-name) saved-conf-name)) (defun load-contrib (file) "Load a file in the contrib directory" (let ((truename (merge-pathnames file *contrib-dir*))) (format t "Loading contribution file: ~A~%" truename) (when (probe-file truename) (load truename :verbose nil)))) (defun reload-clfswm () "Reload clfswm" (format t "~&-*- Reloading CLFSWM -*-~%") (asdf:oos 'asdf:load-op :clfswm) (reset-clfswm)) (defun query-yes-or-no (formatter &rest args) (let ((rep (query-string (apply #'format nil formatter args) "" '("yes" "no")))) (or (string= rep "") (char= (char rep 0) #\y) (char= (char rep 0) #\Y)))) (defun rename-current-child () "Rename the current child" (let ((name (query-string (format nil "New child name: (last: ~A)" (child-name *current-child*)) (child-name *current-child*)))) (rename-child *current-child* name) (leave-second-mode))) (defun renumber-current-frame () "Renumber the current frame" (when (frame-p *current-child*) (let ((number (query-number (format nil "New child number: (last: ~A)" (frame-number *current-child*)) (frame-number *current-child*)))) (setf (frame-number *current-child*) number) (leave-second-mode)))) (defun add-default-frame () "Add a default frame in the current frame" (when (frame-p *current-child*) (let ((name (query-string "Frame name"))) (push (create-frame :name name) (frame-child *current-child*)))) (leave-second-mode)) (defun add-frame-in-parent-frame () "Add a frame in the parent frame (and reorganize parent frame)" (let ((new-frame (create-frame)) (parent (find-parent-frame *current-child*))) (when parent (pushnew new-frame (frame-child parent)) (setf *current-root* parent *current-child* parent) (set-layout-once #'tile-space-layout) (setf *current-child* new-frame) (leave-second-mode)))) (defun add-placed-frame () "Add a placed frame in the current frame" (when (frame-p *current-child*) (let ((name (query-string "Frame name")) (x (/ (query-number "Frame x in percent (%)") 100)) (y (/ (query-number "Frame y in percent (%)") 100)) (w (/ (query-number "Frame width in percent (%)" 100) 100)) (h (/ (query-number "Frame height in percent (%)" 100) 100))) (push (create-frame :name name :x x :y y :w w :h h) (frame-child *current-child*)))) (leave-second-mode)) (defun delete-focus-window-generic (close-fun) (with-focus-window (window) (when (child-equal-p window *current-child*) (setf *current-child* *current-root*)) (delete-child-and-children-in-all-frames window close-fun))) (defun delete-focus-window () "Close focus window: Delete the focus window in all frames and workspaces" (delete-focus-window-generic 'delete-window)) (defun destroy-focus-window () "Kill focus window: Destroy the focus window in all frames and workspaces" (delete-focus-window-generic 'destroy-window)) (defun remove-focus-window () "Remove the focus window from the current frame" (with-focus-window (window) (setf *current-child* *current-root*) (hide-child window) (remove-child-in-frame window (find-parent-frame window)) (show-all-children))) (defun unhide-all-windows-in-current-child () "Unhide all hidden windows into the current child" (dolist (window (get-hidden-windows)) (unhide-window window) (process-new-window window) (map-window window)) (show-all-children)) (defun find-window-under-mouse (x y) "Return the child window under the mouse" (let ((win *root*)) (with-all-windows-frames-and-parent (*current-root* child parent) (when (and (or (managed-window-p child parent) (child-equal-p parent *current-child*)) (in-window child x y)) (setf win child)) (when (in-frame child x y) (setf win (frame-window child)))) win)) (defun find-child-under-mouse-in-never-managed-windows (x y) "Return the child under mouse from never managed windows" (let ((ret nil)) (dolist (win (xlib:query-tree *root*)) (unless (window-hidden-p win) (multiple-value-bind (never-managed raise) (never-managed-window-p win) (when (and never-managed raise (in-window win x y)) (setf ret win))))) ret)) (defun find-child-under-mouse-in-child-tree (x y &optional first-foundp) "Return the child under the mouse" (let ((ret nil)) (with-all-windows-frames-and-parent (*current-root* child parent) (when (and (not (window-hidden-p child)) (or (managed-window-p child parent) (child-equal-p parent *current-child*)) (in-window child x y)) (if first-foundp (return-from find-child-under-mouse-in-child-tree child) (setf ret child))) (when (in-frame child x y) (if first-foundp (return-from find-child-under-mouse-in-child-tree child) (setf ret child)))) ret)) (defun find-child-under-mouse (x y &optional first-foundp also-never-managed) "Return the child under the mouse" (or (and also-never-managed (find-child-under-mouse-in-never-managed-windows x y)) (find-child-under-mouse-in-child-tree x y first-foundp))) ;;; Selection functions (defun clear-selection () "Clear the current selection" (setf *child-selection* nil) (display-frame-info *current-root*)) (defun copy-current-child () "Copy the current child to the selection" (pushnew *current-child* *child-selection*) (display-frame-info *current-root*)) (defun cut-current-child (&optional (show-now t)) "Cut the current child to the selection" (unless (child-equal-p *current-child* *current-root*) (let ((parent (find-parent-frame *current-child*))) (hide-all *current-child*) (copy-current-child) (remove-child-in-frame *current-child* (find-parent-frame *current-child* *current-root*)) (when parent (setf *current-child* parent)) (when show-now (show-all-children t)) *current-child*))) (defun remove-current-child () "Remove the current child from its parent frame" (unless (child-equal-p *current-child* *current-root*) (let ((parent (find-parent-frame *current-child*))) (hide-all *current-child*) (remove-child-in-frame *current-child* (find-parent-frame *current-child* *current-root*)) (when parent (setf *current-child* parent)) (show-all-children t) (leave-second-mode)))) (defun delete-current-child () "Delete the current child and its children in all frames" (hide-all *current-child*) (delete-child-and-children-in-all-frames *current-child*) (show-all-children t) (leave-second-mode)) (defun paste-selection-no-clear () "Paste the selection in the current frame - Do not clear the selection after paste" (when (frame-p *current-child*) (dolist (child *child-selection*) (unless (find-child-in-parent child *current-child*) (pushnew child (frame-child *current-child*) :test #'child-equal-p))) (show-all-children))) (defun paste-selection () "Paste the selection in the current frame" (when (frame-p *current-child*) (paste-selection-no-clear) (setf *child-selection* nil) (display-frame-info *current-root*))) (defun copy-focus-window () "Copy the focus window to the selection" (with-focus-window (window) (let ((*current-child* window)) (copy-current-child)))) (defun cut-focus-window () "Cut the focus window to the selection" (with-focus-window (window) (setf *current-child* (let ((*current-child* window)) (cut-current-child nil))) (show-all-children t))) ;;; Maximize function (defun frame-toggle-maximize () "Maximize/Unmaximize the current frame in its parent frame" (when (frame-p *current-child*) (let ((unmaximized-coords (frame-data-slot *current-child* :unmaximized-coords))) (if unmaximized-coords (with-slots (x y w h) *current-child* (destructuring-bind (nx ny nw nh) unmaximized-coords (setf (frame-data-slot *current-child* :unmaximized-coords) nil x nx y ny w nw h nh))) (with-slots (x y w h) *current-child* (setf (frame-data-slot *current-child* :unmaximized-coords) (list x y w h) x 0 y 0 w 1 h 1)))) (show-all-children) (leave-second-mode))) ;;; CONFIG - Identify mode (defun identify-key () "Identify a key" (let* ((done nil) (font (xlib:open-font *display* *identify-font-string*)) (window (xlib:create-window :parent *root* :x 0 :y 0 :width (- (xlib:screen-width *screen*) (* *border-size* 2)) :height (* 5 (+ (xlib:max-char-ascent font) (xlib:max-char-descent font))) :background (get-color *identify-background*) :border-width *border-size* :border (get-color *identify-border*) :colormap (xlib:screen-default-colormap *screen*) :event-mask '(:exposure))) (gc (xlib:create-gcontext :drawable window :foreground (get-color *identify-foreground*) :background (get-color *identify-background*) :font font :line-style :solid))) (labels ((print-doc (msg hash-table-key pos code state) (let ((function (find-key-from-code hash-table-key code state))) (when (and function (fboundp (first function))) (xlib:draw-glyphs *pixmap-buffer* gc 10 (+ (* pos (+ (xlib:max-char-ascent font) (xlib:max-char-descent font))) 5) (format nil "~A ~A" msg (documentation (first function) 'function)))))) (print-key (code state keysym key modifiers) (clear-pixmap-buffer window gc) (setf (xlib:gcontext-foreground gc) (get-color *identify-foreground*)) (xlib:draw-glyphs *pixmap-buffer* gc 5 (+ (xlib:max-char-ascent font) 5) (format nil "Press a key to identify. Press 'q' to stop the identify loop.")) (when code (xlib:draw-glyphs *pixmap-buffer* gc 10 (+ (* 2 (+ (xlib:max-char-ascent font) (xlib:max-char-descent font))) 5) (format nil "Code=~A KeySym=~S Key=~S Modifiers=~A" code keysym key modifiers)) (print-doc "Main mode : " *main-keys* 3 code state) (print-doc "Second mode: " *second-keys* 4 code state)) (copy-pixmap-buffer window gc)) (handle-identify-key (&rest event-slots &key root code state &allow-other-keys) (declare (ignore event-slots root)) (let* ((modifiers (state->modifiers state)) (key (keycode->char code state)) (keysym (keysym->keysym-name (keycode->keysym code modifiers)))) (setf done (and (equal key #\q) (equal modifiers *default-modifiers*))) (dbg code keysym key modifiers) (print-key code state keysym key modifiers) (force-output))) (handle-identify (&rest event-slots &key display event-key &allow-other-keys) (declare (ignore display)) (case event-key (:key-press (apply #'handle-identify-key event-slots) t) (:exposure (print-key nil nil nil nil nil))) t)) (xgrab-pointer *root* 92 93) (map-window window) (format t "~&Press 'q' to stop the identify loop~%") (print-key nil nil nil nil nil) (force-output) (unwind-protect (loop until done do (when (xlib:event-listen *display* *loop-timeout*) (xlib:process-event *display* :handler #'handle-identify)) (xlib:display-finish-output *display*)) (xlib:destroy-window window) (xlib:close-font font) (xgrab-pointer *root* 66 67))))) (defun eval-from-query-string () "Eval a lisp form from the query input" (let ((form (query-string (format nil "Eval Lisp - ~A" (package-name *package*)))) (result nil)) (when (and form (not (equal form ""))) (let ((printed-result (with-output-to-string (*standard-output*) (setf result (handler-case (loop for i in (multiple-value-list (eval (read-from-string form))) collect (format nil "~S" i)) (error (condition) (format nil "~A" condition))))))) (info-mode (expand-newline (append (ensure-list (format nil "> ~A" form)) (ensure-list printed-result) (ensure-list result))) :width (- (xlib:screen-width *screen*) 2)) (eval-from-query-string))))) (defun run-program-from-query-string () "Run a program from the query input" (multiple-value-bind (program return) (query-string "Run:") (when (and (equal return :return) program (not (equal program ""))) (setf *second-mode-leave-function* (let ((cmd (concatenate 'string "cd $HOME && " program))) (lambda () (do-shell cmd)))) (leave-second-mode)))) ;;; Frame name actions (defun ask-frame-name (msg) "Ask a frame name" (let ((all-frame-name nil)) (with-all-frames (*root-frame* frame) (awhen (frame-name frame) (push it all-frame-name))) (query-string msg "" all-frame-name))) ;;; Focus by functions (defun focus-frame-by (frame) (when (frame-p frame) (focus-all-children frame (or (find-parent-frame frame *current-root*) (find-parent-frame frame) *root-frame*)) (show-all-children t))) (defun focus-frame-by-name () "Focus a frame by name" (focus-frame-by (find-frame-by-name (ask-frame-name "Focus frame:"))) (leave-second-mode)) (defun focus-frame-by-number () "Focus a frame by number" (focus-frame-by (find-frame-by-number (query-number "Focus frame by number:"))) (leave-second-mode)) ;;; Open by functions (defun open-frame-by (frame) (when (frame-p frame) (push (create-frame :name (query-string "Frame name")) (frame-child frame)) (show-all-children))) (defun open-frame-by-name () "Open a new frame in a named frame" (open-frame-by (find-frame-by-name (ask-frame-name "Open a new frame in: "))) (leave-second-mode)) (defun open-frame-by-number () "Open a new frame in a numbered frame" (open-frame-by (find-frame-by-number (query-number "Open a new frame in the group numbered:"))) (leave-second-mode)) ;;; Delete by functions (defun delete-frame-by (frame) (unless (child-equal-p frame *root-frame*) (when (child-equal-p frame *current-root*) (setf *current-root* *root-frame*)) (when (child-equal-p frame *current-child*) (setf *current-child* *current-root*)) (remove-child-in-frame frame (find-parent-frame frame))) (show-all-children t)) (defun delete-frame-by-name () "Delete a frame by name" (delete-frame-by (find-frame-by-name (ask-frame-name "Delete frame: "))) (leave-second-mode)) (defun delete-frame-by-number () "Delete a frame by number" (delete-frame-by (find-frame-by-number (query-number "Delete frame by number:"))) (leave-second-mode)) ;;; Move by function (defun move-child-to (child frame-dest) (when (and child (frame-p frame-dest)) (remove-child-in-frame child (find-parent-frame child)) (pushnew child (frame-child frame-dest)) (focus-all-children child frame-dest) (show-all-children t))) (defun move-current-child-by-name () "Move current child in a named frame" (move-child-to *current-child* (find-frame-by-name (ask-frame-name (format nil "Move '~A' to frame: " (child-name *current-child*))))) (leave-second-mode)) (defun move-current-child-by-number () "Move current child in a numbered frame" (move-child-to *current-child* (find-frame-by-number (query-number (format nil "Move '~A' to frame numbered:" (child-name *current-child*))))) (leave-second-mode)) ;;; Copy by function (defun copy-child-to (child frame-dest) (when (and child (frame-p frame-dest)) (pushnew child (frame-child frame-dest)) (focus-all-children child frame-dest) (show-all-children t))) (defun copy-current-child-by-name () "Copy current child in a named frame" (copy-child-to *current-child* (find-frame-by-name (ask-frame-name (format nil "Copy '~A' to frame: " (child-name *current-child*))))) (leave-second-mode)) (defun copy-current-child-by-number () "Copy current child in a numbered frame" (copy-child-to *current-child* (find-frame-by-number (query-number (format nil "Copy '~A' to frame numbered:" (child-name *current-child*))))) (leave-second-mode)) ;;; Show frame info (defun show-all-frames-info () "Show all frames info windows" (let ((*show-root-frame-p* t)) (show-all-children) (with-all-frames (*current-root* frame) (raise-window (frame-window frame)) (display-frame-info frame)))) (defun hide-all-frames-info () "Hide all frames info windows" (with-all-windows (*current-root* window) (raise-window window)) (hide-child *current-root*) (show-all-children)) (defun show-all-frames-info-key () "Show all frames info windows until a key is release" (show-all-frames-info) (wait-no-key-or-button-press) (hide-all-frames-info)) (defun move-frame (frame parent orig-x orig-y) (when (and frame parent (not (child-equal-p frame *current-root*))) (hide-all-children frame) (with-slots (window) frame (move-window window orig-x orig-y #'display-frame-info (list frame)) (setf (frame-x frame) (x-px->fl (xlib:drawable-x window) parent) (frame-y frame) (y-px->fl (xlib:drawable-y window) parent))) (show-all-children))) (defun resize-frame (frame parent orig-x orig-y) (when (and frame parent (not (child-equal-p frame *current-root*))) (hide-all-children frame) (with-slots (window) frame (resize-window window orig-x orig-y #'display-frame-info (list frame)) (setf (frame-w frame) (w-px->fl (xlib:drawable-width window) parent) (frame-h frame) (h-px->fl (xlib:drawable-height window) parent))) (show-all-children))) (defun mouse-click-to-focus-generic (root-x root-y mouse-fn) "Focus the current frame or focus the current window parent mouse-fun is #'move-frame or #'resize-frame" (let* ((to-replay t) (child (find-child-under-mouse root-x root-y)) (parent (find-parent-frame child)) (root-p (child-equal-p child *current-root*))) (labels ((add-new-frame () (when (frame-p child) (setf child (create-frame) parent *current-root* mouse-fn #'resize-frame *current-child* child) (place-frame child parent root-x root-y 10 10) (map-window (frame-window child)) (pushnew child (frame-child *current-root*))))) (when (or (not root-p) *create-frame-on-root*) (when root-p (add-new-frame)) (when (and (frame-p child) (not (child-equal-p child *current-root*))) (funcall mouse-fn child parent root-x root-y)) (when (and child parent (not root-p) (focus-all-children child parent (not (and (child-equal-p *current-child* *current-root*) (xlib:window-p *current-root*))))) (when (show-all-children) (setf to-replay nil)))) (if to-replay (replay-button-event) (stop-button-event))))) (defun mouse-click-to-focus-and-move (window root-x root-y) "Move and focus the current frame or focus the current window parent. Or do actions on corners" (declare (ignore window)) (or (do-corner-action root-x root-y *corner-main-mode-left-button*) (mouse-click-to-focus-generic root-x root-y #'move-frame))) (defun mouse-click-to-focus-and-resize (window root-x root-y) "Resize and focus the current frame or focus the current window parent. Or do actions on corners" (declare (ignore window)) (or (do-corner-action root-x root-y *corner-main-mode-right-button*) (mouse-click-to-focus-generic root-x root-y #'resize-frame))) (defun mouse-middle-click (window root-x root-y) "Do actions on corners" (declare (ignore window)) (or (do-corner-action root-x root-y *corner-main-mode-middle-button*) (replay-button-event))) (defun mouse-focus-move/resize-generic (root-x root-y mouse-fn window-parent) "Focus the current frame or focus the current window parent mouse-fun is #'move-frame or #'resize-frame. Focus child and its parents - For window: set current child to window or its parent according to window-parent" (labels ((move/resize-managed (child) (let ((parent (find-parent-frame child))) (when (and (child-equal-p child *current-root*) (frame-p *current-root*)) (setf child (create-frame) parent *current-root* mouse-fn #'resize-frame) (place-frame child parent root-x root-y 10 10) (map-window (frame-window child)) (pushnew child (frame-child *current-root*))) (focus-all-children child parent window-parent) (show-all-children) (typecase child (xlib:window (if (managed-window-p child parent) (funcall mouse-fn parent (find-parent-frame parent) root-x root-y) (funcall (cond ((or (eql mouse-fn #'move-frame) (eql mouse-fn #'move-frame-constrained)) #'move-window) ((or (eql mouse-fn #'resize-frame) (eql mouse-fn #'resize-frame-constrained)) #'resize-window)) child root-x root-y))) (frame (funcall mouse-fn child parent root-x root-y))) (show-all-children))) (move/resize-never-managed (child raise-fun) (funcall raise-fun child) (funcall (cond ((eql mouse-fn #'move-frame) #'move-window) ((eql mouse-fn #'resize-frame) #'resize-window)) child root-x root-y))) (let ((child (find-child-under-mouse root-x root-y nil t))) (multiple-value-bind (never-managed raise-fun) (never-managed-window-p child) (if (and (xlib:window-p child) never-managed raise-fun) (move/resize-never-managed child raise-fun) (move/resize-managed child)))))) (defun test-mouse-binding (window root-x root-y) (dbg window root-x root-y) (replay-button-event)) (defun mouse-select-next-level (window root-x root-y) "Select the next level in frame" (declare (ignore root-x root-y)) (let ((frame (find-frame-window window))) (when (or frame (xlib:window-equal window *root*)) (select-next-level)) (replay-button-event))) (defun mouse-select-previous-level (window root-x root-y) "Select the previous level in frame" (declare (ignore root-x root-y)) (let ((frame (find-frame-window window))) (when (or frame (xlib:window-equal window *root*)) (select-previous-level)) (replay-button-event))) (defun mouse-enter-frame (window root-x root-y) "Enter in the selected frame - ie make it the root frame" (declare (ignore root-x root-y)) (let ((frame (find-frame-window window))) (when (or frame (xlib:window-equal window *root*)) (enter-frame)) (replay-button-event))) (defun mouse-leave-frame (window root-x root-y) "Leave the selected frame - ie make its parent the root frame" (declare (ignore root-x root-y)) (let ((frame (find-frame-window window))) (when (or frame (xlib:window-equal window *root*)) (leave-frame)) (replay-button-event))) ;;;;;,----- ;;;;;| Various definitions ;;;;;`----- (defun show-help (&optional (browser "dillo") (tempfile "/tmp/clfswm.html")) "Show current keys and buttons bindings" (ignore-errors (produce-doc-html-in-file tempfile)) (sleep 1) (do-shell (format nil "~A ~A" browser tempfile))) ;;; Bind or jump functions (let ((key-slots (make-array 10 :initial-element nil)) (current-slot 1)) (defun bind-on-slot (&optional (slot current-slot)) "Bind current child to slot" (setf (aref key-slots slot) *current-child*)) (defun remove-binding-on-slot () "Remove binding on slot" (setf (aref key-slots current-slot) nil)) (defun jump-to-slot () "Jump to slot" (let ((jump-child (aref key-slots current-slot))) (when (find-child jump-child *root-frame*) (setf *current-root* jump-child *current-child* *current-root*) (focus-all-children *current-child* *current-child*) (show-all-children t)))) (defun bind-or-jump (n) "Bind or jump to a slot (a frame or a window)" (setf current-slot (- n 1)) (let ((default-bind `("b" bind-on-slot ,(format nil "Bind slot ~A on child: ~A" n (child-fullname *current-child*))))) (info-mode-menu (aif (aref key-slots current-slot) `(,default-bind ("BackSpace" remove-binding-on-slot ,(format nil "Remove slot ~A binding on child: ~A" n (child-fullname *current-child*))) (" - " nil " -") ("Tab" jump-to-slot ,(format nil "Jump to child: ~A" (aif (aref key-slots current-slot) (child-fullname it) "Not set - Please, bind it with 'b'"))) ("Return" jump-to-slot "Same thing") ("space" jump-to-slot "Same thing")) (list default-bind)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Useful function for the second mode ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmacro with-movement (&body body) `(when (frame-p *current-child*) ,@body (show-all-children) (display-all-frame-info) (draw-second-mode-window) (open-menu (find-menu 'frame-movement-menu)))) ;;; Pack (defun current-frame-pack-up () "Pack the current frame up" (with-movement (pack-frame-up *current-child* (find-parent-frame *current-child* *current-root*)))) (defun current-frame-pack-down () "Pack the current frame down" (with-movement (pack-frame-down *current-child* (find-parent-frame *current-child* *current-root*)))) (defun current-frame-pack-left () "Pack the current frame left" (with-movement (pack-frame-left *current-child* (find-parent-frame *current-child* *current-root*)))) (defun current-frame-pack-right () "Pack the current frame right" (with-movement (pack-frame-right *current-child* (find-parent-frame *current-child* *current-root*)))) ;;; Center (defun center-current-frame () "Center the current frame" (with-movement (center-frame *current-child*))) ;;; Fill (defun current-frame-fill-up () "Fill the current frame up" (with-movement (fill-frame-up *current-child* (find-parent-frame *current-child* *current-root*)))) (defun current-frame-fill-down () "Fill the current frame down" (with-movement (fill-frame-down *current-child* (find-parent-frame *current-child* *current-root*)))) (defun current-frame-fill-left () "Fill the current frame left" (with-movement (fill-frame-left *current-child* (find-parent-frame *current-child* *current-root*)))) (defun current-frame-fill-right () "Fill the current frame right" (with-movement (fill-frame-right *current-child* (find-parent-frame *current-child* *current-root*)))) (defun current-frame-fill-all-dir () "Fill the current frame in all directions" (with-movement (let ((parent (find-parent-frame *current-child* *current-root*))) (fill-frame-up *current-child* parent) (fill-frame-down *current-child* parent) (fill-frame-left *current-child* parent) (fill-frame-right *current-child* parent)))) (defun current-frame-fill-vertical () "Fill the current frame vertically" (with-movement (let ((parent (find-parent-frame *current-child* *current-root*))) (fill-frame-up *current-child* parent) (fill-frame-down *current-child* parent)))) (defun current-frame-fill-horizontal () "Fill the current frame horizontally" (with-movement (let ((parent (find-parent-frame *current-child* *current-root*))) (fill-frame-left *current-child* parent) (fill-frame-right *current-child* parent)))) ;;; Resize (defun current-frame-resize-up () "Resize the current frame up to its half height" (with-movement (resize-half-height-up *current-child*))) (defun current-frame-resize-down () "Resize the current frame down to its half height" (with-movement (resize-half-height-down *current-child*))) (defun current-frame-resize-left () "Resize the current frame left to its half width" (with-movement (resize-half-width-left *current-child*))) (defun current-frame-resize-right () "Resize the current frame right to its half width" (with-movement (resize-half-width-right *current-child*))) (defun current-frame-resize-all-dir () "Resize down the current frame" (with-movement (resize-frame-down *current-child*))) (defun current-frame-resize-all-dir-minimal () "Resize down the current frame to its minimal size" (with-movement (resize-minimal-frame *current-child*))) ;;; Children navigation (defun with-movement-select-next-brother () "Select the next brother frame" (with-movement (select-next-brother-simple))) (defun with-movement-select-previous-brother () "Select the previous brother frame" (with-movement (select-previous-brother-simple))) (defun with-movement-select-next-level () "Select the next level" (with-movement (select-next-level))) (defun with-movement-select-previous-level () "Select the previous levelframe" (with-movement (select-previous-level))) (defun with-movement-select-next-child () "Select the next child" (with-movement (select-next-child-simple))) ;;; Adapt frame functions (defun adapt-current-frame-to-window-hints-generic (width-p height-p) "Adapt the current frame to the current window minimal size hints" (when (frame-p *current-child*) (let ((window (first (frame-child *current-child*)))) (when (xlib:window-p window) (let* ((hints (xlib:wm-normal-hints window)) (min-width (and hints (xlib:wm-size-hints-min-width hints))) (min-height (and hints (xlib:wm-size-hints-min-height hints)))) (when (and width-p min-width) (setf (frame-rw *current-child*) min-width)) (when (and height-p min-height) (setf (frame-rh *current-child*) min-height)) (fixe-real-size *current-child* (find-parent-frame *current-child*)) (leave-second-mode)))))) (defun adapt-current-frame-to-window-hints () "Adapt the current frame to the current window minimal size hints" (adapt-current-frame-to-window-hints-generic t t)) (defun adapt-current-frame-to-window-width-hint () "Adapt the current frame to the current window minimal width hint" (adapt-current-frame-to-window-hints-generic t nil)) (defun adapt-current-frame-to-window-height-hint () "Adapt the current frame to the current window minimal height hint" (adapt-current-frame-to-window-hints-generic nil t)) ;;; Managed window type functions (defun current-frame-manage-window-type-generic (type-list) (when (frame-p *current-child*) (setf (frame-managed-type *current-child*) type-list (frame-forced-managed-window *current-child*) nil (frame-forced-unmanaged-window *current-child*) nil)) (leave-second-mode)) (defun current-frame-manage-window-type () "Change window types to be managed by a frame" (when (frame-p *current-child*) (let* ((type-str (query-string "Managed window type: (all, normal, transient, maxsize, desktop, dock, toolbar, menu, utility, splash, dialog)" (format nil "~{~:(~A~) ~}" (frame-managed-type *current-child*)))) (type-list (loop :for type :in (split-string type-str) :collect (intern (string-upcase type) :keyword)))) (current-frame-manage-window-type-generic type-list)))) (defun current-frame-manage-all-window-type () "Manage all window type" (current-frame-manage-window-type-generic '(:all))) (defun current-frame-manage-only-normal-window-type () "Manage only normal window type" (current-frame-manage-window-type-generic '(:normal))) (defun current-frame-manage-no-window-type () "Do not manage any window type" (current-frame-manage-window-type-generic nil)) ;;; Force window functions (defun force-window-in-frame () "Force the current window to move in the frame (Useful only for unmanaged windows)" (with-current-window (let ((parent (find-parent-frame window))) (setf (xlib:drawable-x window) (frame-rx parent) (xlib:drawable-y window) (frame-ry parent)) (xlib:display-finish-output *display*))) (leave-second-mode)) (defun force-window-center-in-frame () "Force the current window to move in the center of the frame (Useful only for unmanaged windows)" (with-current-window (let ((parent (find-parent-frame window))) (setf (xlib:drawable-x window) (truncate (+ (frame-rx parent) (/ (- (frame-rw parent) (xlib:drawable-width window)) 2))) (xlib:drawable-y window) (truncate (+ (frame-ry parent) (/ (- (frame-rh parent) (xlib:drawable-height window)) 2)))) (xlib:display-finish-output *display*))) (leave-second-mode)) (defun display-current-window-info () "Display information on the current window" (with-current-window (info-mode (list (format nil "Window: ~A" window) (format nil "Window name: ~A" (xlib:wm-name window)) (format nil "Window class: ~A" (xlib:get-wm-class window)) (format nil "Window type: ~:(~A~)" (window-type window)) (format nil "Window id: 0x~X" (xlib:window-id window))))) (leave-second-mode)) (defun manage-current-window () "Force to manage the current window by its parent frame" (with-current-window (let ((parent (find-parent-frame window))) (with-slots ((managed forced-managed-window) (unmanaged forced-unmanaged-window)) parent (setf unmanaged (child-remove window unmanaged) unmanaged (remove (xlib:wm-name window) unmanaged :test #'string-equal-p)) (pushnew window managed)))) (leave-second-mode)) (defun unmanage-current-window () "Force to not manage the current window by its parent frame" (with-current-window (let ((parent (find-parent-frame window))) (with-slots ((managed forced-managed-window) (unmanaged forced-unmanaged-window)) parent (setf managed (child-remove window managed) managed (remove (xlib:wm-name window) managed :test #'string-equal-p)) (pushnew window unmanaged)))) (leave-second-mode)) ;;; Moving child with the mouse button (defun mouse-move-child-over-frame (window root-x root-y) "Move the child under the mouse cursor to another frame" (declare (ignore window)) (let ((child (find-child-under-mouse root-x root-y))) (unless (child-equal-p child *current-root*) (hide-all child) (remove-child-in-frame child (find-parent-frame child)) (wait-mouse-button-release 50 51) (multiple-value-bind (x y) (xlib:query-pointer *root*) (let ((dest (find-child-under-mouse x y))) (when (xlib:window-p dest) (setf dest (find-parent-frame dest))) (unless (child-equal-p child dest) (move-child-to child dest) (show-all-children)))))) (stop-button-event)) ;;; Hide/Show frame window functions (defun hide/show-frame-window (frame value) "Hide/show the frame window" (when (frame-p frame) (setf (frame-show-window-p *current-child*) value) (show-all-children)) (leave-second-mode)) (defun hide-current-frame-window () "Hide the current frame window" (hide/show-frame-window *current-child* nil)) (defun show-current-frame-window () "Show the current frame window" (hide/show-frame-window *current-child* t)) ;;; Hide/Unhide current child (defun hide-current-child () "Hide the current child" (unless (child-equal-p *current-child* *current-root*) (let ((parent (find-parent-frame *current-child*))) (when (frame-p parent) (with-slots (child hidden-children) parent (hide-all *current-child*) (setf child (child-remove *current-child* child)) (pushnew *current-child* hidden-children) (setf *current-child* parent)) (show-all-children))) (leave-second-mode))) (defun frame-unhide-child (hidden frame-src frame-dest) "Unhide a hidden child from frame-src in frame-dest" (with-slots (hidden-children) frame-src (setf hidden-children (child-remove hidden hidden-children))) (with-slots (child) frame-dest (pushnew hidden child))) (defun unhide-a-child () "Unhide a child in the current frame" (when (frame-p *current-child*) (with-slots (child hidden-children) *current-child* (info-mode-menu (loop :for i :from 0 :for hidden :in hidden-children :collect (list (code-char (+ (char-code #\a) i)) (let ((lhd hidden)) (lambda () (frame-unhide-child lhd *current-child* *current-child*))) (format nil "Unhide ~A" (child-fullname hidden)))))) (show-all-children)) (leave-second-mode)) (defun unhide-all-children () "Unhide all current frame hidden children" (when (frame-p *current-child*) (with-slots (child hidden-children) *current-child* (dolist (c hidden-children) (pushnew c child)) (setf hidden-children nil)) (show-all-children)) (leave-second-mode)) (defun unhide-a-child-from-all-frames () "Unhide a child from all frames in the current frame" (when (frame-p *current-child*) (let ((acc nil) (keynum -1)) (with-all-frames (*root-frame* frame) (when (frame-hidden-children frame) (push (format nil "~A" (child-fullname frame)) acc) (dolist (hidden (frame-hidden-children frame)) (push (list (code-char (+ (char-code #\a) (incf keynum))) (let ((lhd hidden)) (lambda () (frame-unhide-child lhd frame *current-child*))) (format nil "Unhide ~A" (child-fullname hidden))) acc)))) (info-mode-menu (nreverse acc))) (show-all-children)) (leave-second-mode)) (let ((last-child nil)) (defun init-last-child () (setf last-child nil)) (defun switch-to-last-child () "Store the current child and switch to the previous one" (let ((current-child *current-child*)) (when last-child (setf *current-root* last-child *current-child* *current-root*) (focus-all-children *current-child* *current-child*) (show-all-children t)) (setf last-child current-child)) (leave-second-mode))) ;;; Focus policy functions (defun set-focus-policy-generic (focus-policy) (when (frame-p *current-child*) (setf (frame-focus-policy *current-child*) focus-policy)) (leave-second-mode)) (defun current-frame-set-click-focus-policy () "Set a click focus policy for the current frame." (set-focus-policy-generic :click)) (defun current-frame-set-sloppy-focus-policy () "Set a sloppy focus policy for the current frame." (set-focus-policy-generic :sloppy)) (defun current-frame-set-sloppy-strict-focus-policy () "Set a (strict) sloppy focus policy only for windows in the current frame." (set-focus-policy-generic :sloppy-strict)) (defun current-frame-set-sloppy-select-policy () "Set a sloppy select policy for the current frame." (set-focus-policy-generic :sloppy-select)) (defun set-focus-policy-generic-for-all (focus-policy) (with-all-frames (*root-frame* frame) (setf (frame-focus-policy frame) focus-policy)) (leave-second-mode)) (defun all-frames-set-click-focus-policy () "Set a click focus policy for all frames." (set-focus-policy-generic-for-all :click)) (defun all-frames-set-sloppy-focus-policy () "Set a sloppy focus policy for all frames." (set-focus-policy-generic-for-all :sloppy)) (defun all-frames-set-sloppy-strict-focus-policy () "Set a (strict) sloppy focus policy for all frames." (set-focus-policy-generic-for-all :sloppy-strict)) (defun all-frames-set-sloppy-select-policy () "Set a sloppy select policy for all frames." (set-focus-policy-generic-for-all :sloppy-select)) ;;; Ensure unique name/number functions (defun extract-number-from-name (name) (when (stringp name) (let* ((pos (1+ (or (position #\. name :from-end t) -1))) (number (parse-integer name :junk-allowed t :start pos))) (values number (if number (subseq name 0 (1- pos)) name))))) (defun ensure-unique-name () "Ensure that all children names are unique" (with-all-children (*root-frame* child) (multiple-value-bind (num1 name1) (extract-number-from-name (child-name child)) (declare (ignore num1)) (when name1 (let ((acc nil)) (with-all-children (*root-frame* c) (unless (child-equal-p child c)) (multiple-value-bind (num2 name2) (extract-number-from-name (child-name c)) (when (string-equal name1 name2) (push num2 acc)))) (dbg acc) (when (> (length acc) 1) (setf (child-name child) (format nil "~A.~A" name1 (1+ (find-free-number (loop for i in acc when i collect (1- i))))))))))) (leave-second-mode)) (defun ensure-unique-number () "Ensure that all children numbers are unique" (let ((num -1)) (with-all-frames (*root-frame* frame) (setf (frame-number frame) (incf num)))) (leave-second-mode)) ;;; Standard menu functions - Based on the XDG specifications (defconfig *xdg-section-list* (append '(TextEditor FileManager WebBrowser) '(AudioVideo Audio Video Development Education Game Graphics Network Office Settings System Utility) '(TerminalEmulator Archlinux Screensaver)) 'Menu "Standard menu sections") (defun um-create-xdg-section-list (menu) (dolist (section *xdg-section-list*) (add-sub-menu menu :next section (format nil "~A" section) menu))) (defun um-find-submenu (menu section-list) (let ((acc nil)) (dolist (section section-list) (awhen (find-toplevel-menu (intern (string-upcase section) :clfswm) menu) (push it acc))) (if acc acc (list (find-toplevel-menu 'Utility menu))))) (defun um-extract-value (line) (second (split-string line #\=))) (defun um-add-desktop (desktop menu) (let (name exec categories comment) (when (probe-file desktop) (with-open-file (stream desktop :direction :input) (loop for line = (read-line stream nil nil) while line do (cond ((first-position "Name=" line) (setf name (um-extract-value line))) ((first-position "Exec=" line) (setf exec (um-extract-value line))) ((first-position "Categories=" line) (setf categories (um-extract-value line))) ((first-position "Comment=" line) (setf comment (um-extract-value line)))) (when (and name exec categories) (let* ((sub-menu (um-find-submenu menu (split-string categories #\;))) (fun-name (intern name :clfswm))) (setf (symbol-function fun-name) (let ((do-exec exec)) (lambda () (do-shell do-exec) (leave-second-mode))) (documentation fun-name 'function) (format nil "~A~A" name (if comment (format nil " - ~A" comment) ""))) (dolist (m sub-menu) (add-menu-key (menu-name m) :next fun-name m))) (setf name nil exec nil categories nil comment nil))))))) (defun update-menus (&optional (menu (make-menu :name 'main :doc "Main menu"))) (um-create-xdg-section-list menu) (let ((count 0) (found (make-hash-table :test #'equal))) (dolist (dir (remove-duplicates (split-string (getenv "XDG_DATA_DIRS") #\:) :test #'string-equal)) (dolist (desktop (directory (concatenate 'string dir "/applications/**/*.desktop"))) (unless (gethash (file-namestring desktop) found) (setf (gethash (file-namestring desktop) found) t) (um-add-desktop desktop menu) (incf count)))) menu)) ;;; Close/Kill focused window (defun ask-close/kill-current-window () "Close or kill the current window (ask before doing anything)" (let ((window (xlib:input-focus *display*)) (*info-mode-placement* *ask-close/kill-placement*)) (info-mode-menu (if (and window (not (xlib:window-equal window *no-focus-window*))) `(,(format nil "Focus window: ~A" (xlib:wm-name window)) (#\s delete-focus-window "Close the focus window") (#\k destroy-focus-window "Kill the focus window") (#\x cut-focus-window) (#\c copy-focus-window) (#\v paste-selection)) `(,(format nil "Focus window: None") (#\v paste-selection)))) t)) ;;; Other window manager functions (defun get-proc-list () (let ((proc (do-shell "ps x -o pid=" nil t)) (proc-list nil)) (loop for line = (read-line proc nil nil) while line do (push line proc-list)) (dbg proc-list) proc-list)) (defun run-other-window-manager () (let ((proc-start (get-proc-list))) (do-shell *other-window-manager* nil t :terminal) (let* ((proc-end (get-proc-list)) (proc-diff (set-difference proc-end proc-start :test #'equal))) (dbg 'killing-sigterm proc-diff) (do-shell (format nil "kill ~{ ~A ~} 2> /dev/null" proc-diff) nil t :terminal) (dbg 'killing-sigkill proc-diff) (do-shell (format nil "kill -9 ~{ ~A ~} 2> /dev/null" proc-diff) nil t :terminal) (sleep 1)) (setf *other-window-manager* nil))) (defun do-run-other-window-manager (window-manager) (setf *other-window-manager* window-manager) (throw 'exit-main-loop nil)) (defmacro def-run-other-window-manager (name &optional definition) (let ((definition (or definition name))) `(defun ,(create-symbol "run-" name) () ,(format nil "Run ~A" definition) (do-run-other-window-manager ,(format nil "~A" name))))) (def-run-other-window-manager "xterm") (def-run-other-window-manager "icewm") (def-run-other-window-manager "twm") (def-run-other-window-manager "gnome-session" "Gnome") (def-run-other-window-manager "startkde" "KDE") (def-run-other-window-manager "xfce4-session" "XFCE") (defun run-lxde () "Run LXDE" (do-run-other-window-manager "( lxsession & ); xterm -e \"echo ' /----------------------------------\\' ; echo ' | CLFSWM Note: |' ; echo ' | Close this window when done. |' ; echo ' \\----------------------------------/'; echo; echo; $SHELL\"")) (defun run-xfce4 () "Run LXDE (xterm)" (do-run-other-window-manager "( xfce4-session &) ; xterm -e \"echo ' /----------------------------------\\' ; echo ' | CLFSWM Note: |' ; echo ' | Close this window when done. |' ; echo ' \\----------------------------------/'; echo; echo; $SHELL\"")) (defun run-prompt-wm () "Prompt for an other window manager" (let ((wm (query-string "Run an other window manager:" "icewm"))) (do-run-other-window-manager wm))) ;;; Hide or show unmanaged windows utility. (defun set-hide-unmanaged-window () "Hide unmanaged windows when frame is not selected" (when (frame-p *current-child*) (setf (frame-data-slot *current-child* :unmanaged-window-action) :hide) (leave-second-mode))) (defun set-show-unmanaged-window () "Show unmanaged windows when frame is not selected" (when (frame-p *current-child*) (setf (frame-data-slot *current-child* :unmanaged-window-action) :show) (leave-second-mode))) (defun set-default-hide-unmanaged-window () "Set default behaviour to hide or not unmanaged windows when frame is not selected" (when (frame-p *current-child*) (setf (frame-data-slot *current-child* :unmanaged-window-action) nil) (leave-second-mode))) (defun set-globally-hide-unmanaged-window () "Hide unmanaged windows by default. This is overriden by functions above" (setf *hide-unmanaged-window* t) (leave-second-mode)) (defun set-globally-show-unmanaged-window () "Show unmanaged windows by default. This is overriden by functions above" (setf *hide-unmanaged-window* nil) (leave-second-mode)) ;;; Speed mouse movement. (let (minx miny maxx maxy history lx ly) (labels ((middle (x1 x2) (round (/ (+ x1 x2) 2))) (reset-if-moved (x y) (when (or (/= x (or lx x)) (/= y (or ly y))) (speed-mouse-reset))) (add-in-history (x y) (push (list x y) history))) (defun speed-mouse-reset () "Reset speed mouse coordinates" (setf minx nil miny nil maxx nil maxy nil history nil lx nil ly nil)) (defun speed-mouse-left () "Speed move mouse to left" (with-x-pointer (reset-if-moved x y) (setf maxx x) (add-in-history x y) (setf lx (middle (or minx 0) maxx)) (xlib:warp-pointer *root* lx y))) (defun speed-mouse-right () "Speed move mouse to right" (with-x-pointer (reset-if-moved x y) (setf minx x) (add-in-history x y) (setf lx (middle minx (or maxx (xlib:screen-width *screen*)))) (xlib:warp-pointer *root* lx y))) (defun speed-mouse-up () "Speed move mouse to up" (with-x-pointer (reset-if-moved x y) (setf maxy y) (add-in-history x y) (setf ly (middle (or miny 0) maxy)) (xlib:warp-pointer *root* x ly))) (defun speed-mouse-down () "Speed move mouse to down" (with-x-pointer (reset-if-moved x y) (setf miny y) (add-in-history x y) (setf ly (middle miny (or maxy (xlib:screen-height *screen*)))) (xlib:warp-pointer *root* x ly))) (defun speed-mouse-undo () "Undo last speed mouse move" (when history (let ((h (pop history))) (when h (destructuring-bind (bx by) h (setf lx bx ly by minx nil maxx nil miny nil maxy nil) (xlib:warp-pointer *root* lx ly)))))) (defun speed-mouse-first-history () "Revert to the first speed move mouse" (when history (let ((h (first (last history)))) (when h (setf lx (first h) ly (second h)) (xlib:warp-pointer *root* lx ly))))))) ;;; Notify window functions (let (font window gc width height text current-child) (labels ((text-string (tx) (typecase tx (cons (first tx)) (t tx))) (text-color (tx) (get-color (typecase tx (cons (second tx)) (t *notify-window-foreground*))))) (defun is-notify-window-p (win) (when (and (xlib:window-p win) (xlib:window-p window)) (xlib:window-equal win window))) (defun refresh-notify-window () (add-timer 0.1 #'refresh-notify-window :refresh-notify-window) (raise-window window) (let ((text-height (- (xlib:font-ascent font) (xlib:font-descent font)))) (loop for tx in text for i from 1 do (setf (xlib:gcontext-foreground gc) (text-color tx)) (xlib:draw-glyphs window gc (truncate (/ (- width (* (xlib:max-char-width font) (length (text-string tx)))) 2)) (* text-height i 2) (text-string tx))))) (defun close-notify-window () (erase-timer :refresh-notify-window) (setf *never-managed-window-list* (remove (list #'is-notify-window-p 'raise-window) *never-managed-window-list* :test #'equal)) (when gc (xlib:free-gcontext gc)) (when window (xlib:destroy-window window)) (when font (xlib:close-font font)) (xlib:display-finish-output *display*) (setf window nil gc nil font nil)) (defun open-notify-window (text-list) (close-notify-window) (setf font (xlib:open-font *display* *notify-window-font-string*)) (let ((text-height (- (xlib:font-ascent font) (xlib:font-descent font)))) (setf text text-list) (setf width (* (xlib:max-char-width font) (+ (loop for tx in text-list maximize (length (text-string tx))) 2)) height (+ (* text-height (length text-list) 2) text-height)) (with-placement (*notify-window-placement* x y width height) (setf window (xlib:create-window :parent *root* :x x :y y :width width :height height :background (get-color *notify-window-background*) :border-width *border-size* :border (get-color *notify-window-border*) :colormap (xlib:screen-default-colormap *screen*) :event-mask '(:exposure :key-press)) gc (xlib:create-gcontext :drawable window :foreground (get-color *notify-window-foreground*) :background (get-color *notify-window-background*) :font font :line-style :solid)) (when (frame-p *current-child*) (setf current-child *current-child*) (push (list #'is-notify-window-p 'raise-window) *never-managed-window-list*)) (map-window window) (refresh-notify-window) (xlib:display-finish-output *display*)))))) (defun display-hello-window () (open-notify-window '(("Welcome to CLFSWM" "yellow") "Press Alt+F1 for help")) (add-timer *notify-window-delay* #'close-notify-window)) ;;; Run or raise functions (defun run-or-raise (raisep run-fn &key (maximized nil)) (let ((window (with-all-windows (*root-frame* win) (when (funcall raisep win) (return win))))) (if window (let ((parent (find-parent-frame window))) (setf *current-child* parent) (put-child-on-top window parent) (when maximized (setf *current-root* parent)) (focus-all-children window parent) (show-all-children t)) (funcall run-fn)))) clfswm-20111015.git51b0a02/src/clfswm.lisp000066400000000000000000000253631164636077000177140ustar00rootroot00000000000000;;; -------------------------------------------------------------------------- ;;; CLFSWM - FullScreen Window Manager ;;; ;;; -------------------------------------------------------------------------- ;;; Documentation: Main functions ;;; -------------------------------------------------------------------------- ;;; ;;; (C) 2011 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;; ;;; -------------------------------------------------------------------------- (in-package :clfswm) (define-handler main-mode :key-press (code state) (funcall-key-from-code *main-keys* code state)) (define-handler main-mode :button-press (code state window root-x root-y) (unless (funcall-button-from-code *main-mouse* code state window root-x root-y *fun-press*) (replay-button-event))) (define-handler main-mode :button-release (code state window root-x root-y) (unless (funcall-button-from-code *main-mouse* code state window root-x root-y *fun-release*) (replay-button-event))) (define-handler main-mode :motion-notify (window root-x root-y) (unless (compress-motion-notify) (funcall-button-from-code *main-mouse* 'motion (modifiers->state *default-modifiers*) window root-x root-y *fun-press*))) (define-handler main-mode :configure-request (stack-mode window x y width height border-width value-mask) (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))) (adjust-from-request () (when (has-x value-mask) (setf (xlib:drawable-x window) x)) (when (has-y value-mask) (setf (xlib:drawable-y window) y)) (when (has-h value-mask) (setf (xlib:drawable-height window) height)) (when (has-w value-mask) (setf (xlib:drawable-width window) width)))) (xlib:with-state (window) (when (has-bw value-mask) (setf (xlib:drawable-border-width window) border-width)) (if (find-child window *current-root*) (let ((parent (find-parent-frame window *current-root*))) (if (and parent (managed-window-p window parent)) (adapt-child-to-parent window parent) (adjust-from-request))) (adjust-from-request)) (send-configuration-notify window (xlib:drawable-x window) (xlib:drawable-y window) (xlib:drawable-width window) (xlib:drawable-height window) (xlib:drawable-border-width window)) (when (has-stackmode value-mask) (case stack-mode (:above (unless (null-size-window-p window) (when (or (child-equal-p window *current-child*) (is-in-current-child-p window)) (raise-window window) (focus-window window) (focus-all-children window (find-parent-frame window *current-root*)))))))))) (define-handler main-mode :map-request (window send-event-p) (unless send-event-p (unhide-window window) (process-new-window window) (map-window window) (unless (null-size-window-p window) (multiple-value-bind (never-managed raise) (never-managed-window-p window) (unless (and never-managed raise) (show-all-children)))))) (define-handler main-mode :unmap-notify (send-event-p event-window window) (unless (and (not send-event-p) (not (xlib:window-equal window event-window))) (when (find-child window *root-frame*) (clean-windows-in-all-frames) (show-all-children) (delete-child-in-all-frames window) (show-all-children)))) (define-handler main-mode :destroy-notify (send-event-p event-window window) (unless (or send-event-p (xlib:window-equal window event-window)) (when (find-child window *root-frame*) (clean-windows-in-all-frames) (show-all-children) (delete-child-in-all-frames window) (show-all-children)))) (define-handler main-mode :enter-notify (window root-x root-y) (unless (and (> root-x (- (xlib:screen-width *screen*) 3)) (> root-y (- (xlib:screen-height *screen*) 3))) (case (if (frame-p *current-child*) (frame-focus-policy *current-child*) *default-focus-policy*) (:sloppy (focus-window window)) (:sloppy-strict (when (and (frame-p *current-child*) (child-member window (frame-child *current-child*))) (focus-window window))) (:sloppy-select (let* ((child (find-child-under-mouse root-x root-y)) (parent (find-parent-frame child))) (unless (or (child-equal-p child *current-root*) (equal (typecase child (xlib:window parent) (t child)) *current-child*)) (focus-all-children child parent) (show-all-children))))))) (define-handler main-mode :exposure (window) (awhen (find-frame-window window *current-root*) (display-frame-info it))) (defun error-handler (display error-key &rest key-vals &key asynchronous &allow-other-keys) "Handle X errors" (cond ;; ignore asynchronous window errors ((and asynchronous (find error-key '(xlib:window-error xlib:drawable-error xlib:match-error))) (format t "Ignoring XLib asynchronous error: ~s~%" error-key)) ((eq error-key 'xlib:access-error) (write-line "Another window manager is running.") (throw 'exit-clfswm nil)) ;; all other asynchronous errors are printed. (asynchronous (format t "Caught Asynchronous X Error: ~s ~s" error-key key-vals)) (t (apply 'error error-key :display display :error-key error-key key-vals)))) (defun main-loop () (loop (call-hook *loop-hook*) (process-timers) (with-xlib-protect (when (xlib:event-listen *display* *loop-timeout*) (xlib:process-event *display* :handler #'handle-event)) (xlib:display-finish-output *display*)))) (defun open-display (display-str protocol) (multiple-value-bind (host display-num) (parse-display-string display-str) (setf *display* (xlib:open-display host :display display-num :protocol protocol) (xlib:display-error-handler *display*) 'error-handler (getenv "DISPLAY") display-str))) (defun default-init-hook () (let ((frame (add-frame (create-frame :name "Default" :layout nil :x 0.05 :y 0.05 :w 0.9 :h 0.9) *root-frame*))) (setf *current-child* frame))) (defun init-display () (fill-handle-event-fun-symbols) (assoc-keyword-handle-event 'main-mode) (setf *screen* (first (xlib:display-roots *display*)) *root* (xlib:screen-root *screen*) *no-focus-window* (xlib:create-window :parent *root* :x 0 :y 0 :width 1 :height 1) *default-font* (xlib:open-font *display* *default-font-string*) *pixmap-buffer* (xlib:create-pixmap :width (xlib:screen-width *screen*) :height (xlib:screen-height *screen*) :depth (xlib:screen-root-depth *screen*) :drawable *root*) *in-second-mode* nil) (init-modifier-list) (xgrab-init-pointer) (xgrab-init-keyboard) (init-last-child) (call-hook *binding-hook*) (clear-timers) (map-window *no-focus-window*) (dbg *display*) (setf (xlib:window-event-mask *root*) (xlib:make-event-mask :substructure-redirect :substructure-notify :property-change :exposure :button-press :button-release :pointer-motion)) ;;(intern-atoms *display*) (netwm-set-properties) (xlib:display-force-output *display*) (setf *child-selection* nil) (setf *root-frame* (create-frame :name "Root" :number 0) *current-root* *root-frame* *current-child* *current-root*) (call-hook *init-hook*) (process-existing-windows *screen*) (show-all-children) (grab-main-keys) (xlib:display-finish-output *display*)) (defun read-conf-file () (let* ((conf (conf-file-name))) (if conf (handler-case (load conf) (error (c) (format t "~2%*** Error loading configuration file: ~A ***~&~A~%" conf c) (values nil (format nil "~s" c) conf)) (:no-error (&rest args) (declare (ignore args)) (values t nil conf))) (values t nil nil)))) (defun exit-clfswm () "Exit clfswm" (throw 'exit-clfswm nil)) (defun reset-clfswm () "Reset clfswm" (throw 'exit-main-loop nil)) (defun main-unprotected (&key (display (or (getenv "DISPLAY") ":0")) protocol (base-dir (asdf:system-source-directory :clfswm)) (read-conf-file-p t) (alternate-conf nil) error-msg) (setf *contrib-dir* (merge-pathnames "contrib/" base-dir)) (conf-file-name alternate-conf) (when read-conf-file-p (read-conf-file)) (create-configuration-menu :clear t) (call-hook *main-entrance-hook*) (handler-case (open-display display protocol) (xlib:access-error (c) (format t "~&~A~&Maybe another window manager is running. [1]~%" c) (force-output) (exit-clfswm))) (handler-case (init-display) (xlib:access-error (c) (ungrab-main-keys) (xlib:destroy-window *no-focus-window*) (xlib:close-display *display*) (format t "~&~A~&Maybe another window manager is running. [2]~%" c) (force-output) (exit-clfswm))) (when error-msg (info-mode error-msg)) (catch 'exit-main-loop (unwind-protect (main-loop) (ungrab-main-keys) (xlib:destroy-window *no-focus-window*) (xlib:free-pixmap *pixmap-buffer*) (destroy-all-frames-window) (call-hook *close-hook*) (xlib:close-display *display*) #+:event-debug (format t "~2&Unhandled events: ~A~%" *unhandled-events*)))) (defun main (&key (display (or (getenv "DISPLAY") ":0")) protocol (base-dir (asdf:system-source-directory :clfswm)) (read-conf-file-p t) (alternate-conf nil)) (let (error-msg) (catch 'exit-clfswm (loop (handler-case (if *other-window-manager* (run-other-window-manager) (main-unprotected :display display :protocol protocol :base-dir base-dir :read-conf-file-p read-conf-file-p :alternate-conf alternate-conf :error-msg error-msg)) (error (c) (let ((msg (format nil "CLFSWM Error: ~A." c))) (format t "~&~A~%Reinitializing...~%" msg) (setf error-msg (list (list msg *info-color-title*) "Reinitializing..."))))))))) clfswm-20111015.git51b0a02/src/config.lisp000066400000000000000000000277661164636077000176770ustar00rootroot00000000000000;;; -------------------------------------------------------------------------- ;;; CLFSWM - FullScreen Window Manager ;;; ;;; -------------------------------------------------------------------------- ;;; Documentation: Configuration file ;;; ;;; Change this file to your own needs or update some of this variables in ;;; your ~/.clfswmrc ;;; Some simple hack can be done in the code begining with the word CONFIG ;;; (you can do a 'grep CONFIG *.lisp' to see what you can configure) ;;; -------------------------------------------------------------------------- ;;; ;;; (C) 2011 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;; ;;; -------------------------------------------------------------------------- (in-package :clfswm) ;;; CONFIG - Default modifiers (defconfig *default-modifiers* '() nil "Default modifiers list to append to explicit modifiers Example: :mod-2 for num_lock, :lock for Caps_lock...") (defun-equal-wm-class equal-wm-class-rox-pinboard "ROX-Pinboard") (defun-equal-wm-class equal-wm-class-xvkbd "xvkbd") ;;; CONFIG - Never managed window list (defconfig *never-managed-window-list* (list (list 'equal-wm-class-rox-pinboard nil) (list 'equal-wm-class-xvkbd 'raise-window) (list 'equal-clfswm-terminal 'raise-and-focus-window)) nil "CLFSWM will never manage windows of this type. A list of (list match-function handle-function)") (defconfig *hide-unmanaged-window* t nil "Hide or not unmanaged windows when a child is deselected.") (defconfig *snap-size* 20 nil "Snap size (in pixels) when move or resize frame is constrained") (defconfig *spatial-move-delay-before* 0.2 nil "Delay to display the current child before doing a spatial move") (defconfig *spatial-move-delay-after* 0.5 nil "Delay to display the new child after doing a spatial move") ;;; CONFIG - Screen size (defun get-fullscreen-size () "Return the size of root child (values rx ry rw rh) You can tweak this to what you want" (values (- *border-size*) (- *border-size*) (xlib:screen-width *screen*) (xlib:screen-height *screen*))) ;;(values -1 -1 (xlib:screen-width *screen*) (xlib:screen-height *screen*))) ;; (values -1 -1 1024 768)) ;; (values 100 100 800 600)) (defconfig *corner-size* 3 'Corner "The size of the corner square") ;;; CONFIG: Corner actions - See in clfswm-corner.lisp for ;;; allowed functions (defconfig *corner-main-mode-left-button* '((:top-left open-menu) (:top-right present-virtual-keyboard) (:bottom-right expose-windows-mode) (:bottom-left nil)) 'Corner "Actions on corners in the main mode with the left mouse button") (defconfig *corner-main-mode-middle-button* '((:top-left help-on-clfswm) (:top-right ask-close/kill-current-window) (:bottom-right nil) (:bottom-left nil)) 'Corner "Actions on corners in the main mode with the middle mouse button") (defconfig *corner-main-mode-right-button* '((:top-left present-clfswm-terminal) (:top-right ask-close/kill-current-window) (:bottom-right expose-all-windows-mode) (:bottom-left nil)) 'Corner "Actions on corners in the main mode with the right mouse button") (defconfig *corner-second-mode-left-button* '((:top-left nil) (:top-right nil) (:bottom-right expose-windows-mode) (:bottom-left nil)) 'Corner "Actions on corners in the second mode with the left mouse button") (defconfig *corner-second-mode-middle-button* '((:top-left help-on-clfswm) (:top-right nil) (:bottom-right nil) (:bottom-left nil)) 'Corner "Actions on corners in the second mode with the middle mouse button") (defconfig *corner-second-mode-right-button* '((:top-left nil) (:top-right nil) (:bottom-right expose-all-windows-mode) (:bottom-left nil)) 'Corner "Actions on corners in the second mode with the right mouse button") (defconfig *virtual-keyboard-cmd* "xvkbd" 'Corner "The command to display the virtual keybaord Here is an ~/.Xresources example for xvkbd: xvkbd.windowGeometry: 300x100-0-0 xvkbd*Font: 6x12 xvkbd.modalKeytop: true xvkbd.customization: -french xvkbd.keypad: false And make it always on top") (defconfig *clfswm-terminal-name* "clfswm-terminal" 'Corner "The clfswm terminal name") ;;(defparameter *clfswm-terminal-cmd* (format nil "xterm -T ~A -e /bin/bash --noprofile --norc" *clfswm-terminal-name*) ;;(defparameter *clfswm-terminal-cmd* (format nil "urxvt -name ~A" *clfswm-terminal-name*) (defconfig *clfswm-terminal-cmd* (format nil "xterm -T ~A" *clfswm-terminal-name*) 'Corner "The clfswm terminal command. This command must set the window title to *clfswm-terminal-name*") ;;; Hook definitions ;;; ;;; A hook is a function, a symbol or a list of functions with a rest ;;; arguments. ;;; ;;; This hooks are set in clfswm.lisp, you can overwrite them or extend ;;; them with a hook list. ;;; ;;; See clfswm.lisp for hooks examples. (defconfig *init-hook* '(default-init-hook display-hello-window) 'Hook "Init hook. This hook is run just after the first root frame is created") (defconfig *close-hook* '(close-notify-window close-clfswm-terminal close-virtual-keyboard) 'Hook "Close hook. This hook is run just before closing the display") (defconfig *default-nw-hook* 'default-frame-nw-hook 'Hook "Default action to do on newly created windows") ;;; CONFIG (defconfig *create-frame-on-root* nil nil "Create frame on root. Set this variable to true if you want to allow to create a new frame on the root window in the main mode with the mouse") ;;; CONFIG: Main mode colors (defconfig *color-selected* "Red" 'Main-mode "Color of selected window") (defconfig *color-unselected* "Blue" 'Main-mode "Color of unselected color") (defconfig *color-maybe-selected* "Yellow" 'Main-mode "Color of maybe selected windows") ;;; CONFIG: Frame colors (defconfig *frame-background* "Black" 'Frame-colors "Frame background") (defconfig *frame-foreground* "Green" 'Frame-colors "Frame foreground") (defconfig *frame-foreground-root* "Red" 'Frame-colors "Frame foreground when the frame is the root frame") (defconfig *frame-foreground-hidden* "Darkgreen" 'Frame-colors "Frame foreground for hidden windows") ;;; CONFIG: Default window size (defconfig *default-window-width* 400 nil "Default window width") (defconfig *default-window-height* 300 nil "Default window height") ;;; CONFIG: Second mode colors and fonts (defconfig *sm-border-color* "Green" 'Second-mode "Second mode window border color") (defconfig *sm-background-color* "Black" 'Second-mode "Second mode window background color") (defconfig *sm-foreground-color* "Red" 'Second-mode "Second mode window foreground color") (defconfig *sm-font-string* *default-font-string* 'Second-mode "Second mode window font string") (defconfig *sm-width* 300 'Second-mode "Second mode window width") (defconfig *sm-height* 25 'Second-mode "Second mode window height") ;;; CONFIG - Identify key colors (defconfig *identify-font-string* *default-font-string* 'Identify-key "Identify window font string") (defconfig *identify-background* "black" 'Identify-key "Identify window background color") (defconfig *identify-foreground* "green" 'Identify-key "Identify window foreground color") (defconfig *identify-border* "red" 'Identify-key "Identify window border color") ;;; CONFIG - Query string colors (defconfig *query-font-string* *default-font-string* 'Query-string "Query string window font string") (defconfig *query-background* "black" 'Query-string "Query string window background color") (defconfig *query-message-color* "yellow" 'Query-string "Query string window message color") (defconfig *query-foreground* "green" 'Query-string "Query string window foreground color") (defconfig *query-cursor-color* "white" 'Query-string "Query string window foreground cursor color") (defconfig *query-parent-color* "blue" 'Query-string "Query string window parenthesis color") (defconfig *query-parent-error-color* "red" 'Query-string "Query string window parenthesis color when no match") (defconfig *query-border* "red" 'Query-string "Query string window border color") ;;; CONFIG - Info mode (defconfig *info-background* "black" 'Info-mode "Info window background color") (defconfig *info-foreground* "green" 'Info-mode "Info window foreground color") (defconfig *info-border* "red" 'Info-mode "Info window border color") (defconfig *info-line-cursor* "white" 'Info-mode "Info window line cursor color color") (defconfig *info-selected-background* "blue" 'Info-mode "Info selected item background color") (defconfig *info-font-string* *default-font-string* 'Info-mode "Info window font string") (defconfig *info-click-to-select* t 'Info-mode "If true, click on info window select item. Otherwise, click to drag the menu") ;;; CONFIG - Circulate string colors (defconfig *circulate-font-string* *default-font-string* 'Circulate-mode "Circulate string window font string") (defconfig *circulate-background* "black" 'Circulate-mode "Circulate string window background color") (defconfig *circulate-foreground* "green" 'Circulate-mode "Circulate string window foreground color") (defconfig *circulate-border* "red" 'Circulate-mode "Circulate string window border color") (defconfig *circulate-width* 400 'Circulate-mode "Circulate mode window width") (defconfig *circulate-height* 15 'Circulate-mode "Circulate mode window height") (defconfig *circulate-text-limite* 30 'Circulate-mode "Maximum text limite in the circulate window") ;;; CONFIG - Expose string colors (defconfig *expose-font-string* *default-font-string* 'Expose-mode "Expose string window font string") (defconfig *expose-background* "black" 'Expose-mode "Expose string window background color") (defconfig *expose-foreground* "green" 'Expose-mode "Expose string window foreground color") (defconfig *expose-border* "red" 'Expose-mode "Expose string window border color") (defconfig *expose-valid-on-key* t 'Expose-mode "Valid expose mode when an accel key is pressed") (defconfig *expose-show-window-title* t 'Expose-mode "Show the window title on accel window") ;;; CONFIG - Show key binding colors (defconfig *info-color-title* "Magenta" 'Info-mode "Colored info title color") (defconfig *info-color-underline* "Yellow" 'Info-mode "Colored info underline color") (defconfig *info-color-first* "Cyan" 'Info-mode "Colored info first color") (defconfig *info-color-second* "lightblue" 'Info-mode "Colored info second color") ;;; CONFIG - Menu colors ;;; Set *info-foreground* to change the default menu foreground (defconfig *menu-color-submenu* "Cyan" 'Menu "Submenu color in menu") (defconfig *menu-color-comment* "Yellow" 'Menu "Comment color in menu") (defconfig *menu-color-key* "Magenta" 'Menu "Key color in menu") (defconfig *menu-color-menu-key* (->color #xFF9AFF) 'Menu "Menu key color in menu") ;;; CONFIG - Notify window string colors (defconfig *notify-window-font-string* *default-font-string* 'Notify-Window "Notify window font string") (defconfig *notify-window-background* "black" 'Notify-Window "Notify Window background color") (defconfig *notify-window-foreground* "green" 'Notify-Window "Notify Window foreground color") (defconfig *notify-window-border* "red" 'Notify-Window "Notify Window border color") (defconfig *notify-window-delay* 10 'Notify-Window "Notify Window display delay") clfswm-20111015.git51b0a02/src/keysyms.lisp000066400000000000000000003754431164636077000201340ustar00rootroot00000000000000;; Copyright (C) 2006 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 :clfswm) (defvar *keysym-name-translations* (make-hash-table)) (defvar *name-keysym-translations* (make-hash-table :test #'equal)) (defun cl-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)) (cl-define-keysym #xffffff "VoidSymbol") ;Void symbol (cl-define-keysym #xff08 "BackSpace") ;Back space, back char (cl-define-keysym #xff09 "Tab") (cl-define-keysym #xff0a "Linefeed") ;Linefeed, LF (cl-define-keysym #xff0b "Clear") (cl-define-keysym #xff0d "Return") ;Return, enter (cl-define-keysym #xff13 "Pause") ;Pause, hold (cl-define-keysym #xff14 "Scroll_Lock") (cl-define-keysym #xff15 "Sys_Req") (cl-define-keysym #xff1b "Escape") (cl-define-keysym #xffff "Delete") ;Delete, rubout (cl-define-keysym #xff20 "Multi_key") ;Multi-key character compose (cl-define-keysym #xff37 "Codeinput") (cl-define-keysym #xff3c "SingleCandidate") (cl-define-keysym #xff3d "MultipleCandidate") (cl-define-keysym #xff3e "PreviousCandidate") (cl-define-keysym #xff21 "Kanji") ;Kanji, Kanji convert (cl-define-keysym #xff22 "Muhenkan") ;Cancel Conversion (cl-define-keysym #xff23 "Henkan_Mode") ;Start/Stop Conversion (cl-define-keysym #xff23 "Henkan") ;Alias for Henkan_Mode (cl-define-keysym #xff24 "Romaji") ;to Romaji (cl-define-keysym #xff25 "Hiragana") ;to Hiragana (cl-define-keysym #xff26 "Katakana") ;to Katakana (cl-define-keysym #xff27 "Hiragana_Katakana") ;Hiragana/Katakana toggle (cl-define-keysym #xff28 "Zenkaku") ;to Zenkaku (cl-define-keysym #xff29 "Hankaku") ;to Hankaku (cl-define-keysym #xff2a "Zenkaku_Hankaku") ;Zenkaku/Hankaku toggle (cl-define-keysym #xff2b "Touroku") ;Add to Dictionary (cl-define-keysym #xff2c "Massyo") ;Delete from Dictionary (cl-define-keysym #xff2d "Kana_Lock") ;Kana Lock (cl-define-keysym #xff2e "Kana_Shift") ;Kana Shift (cl-define-keysym #xff2f "Eisu_Shift") ;Alphanumeric Shift (cl-define-keysym #xff30 "Eisu_toggle") ;Alphanumeric toggle (cl-define-keysym #xff37 "Kanji_Bangou") ;Codeinput (cl-define-keysym #xff3d "Zen_Koho") ;Multiple/All Candidate(s) (cl-define-keysym #xff3e "Mae_Koho") ;Previous Candidate (cl-define-keysym #xff50 "Home") (cl-define-keysym #xff51 "Left") ;Move left, left arrow (cl-define-keysym #xff52 "Up") ;Move up, up arrow (cl-define-keysym #xff53 "Right") ;Move right, right arrow (cl-define-keysym #xff54 "Down") ;Move down, down arrow (cl-define-keysym #xff55 "Prior") ;Prior, previous (cl-define-keysym #xff55 "Page_Up") (cl-define-keysym #xff56 "Next") ;Next (cl-define-keysym #xff56 "Page_Down") (cl-define-keysym #xff57 "End") ;EOL (cl-define-keysym #xff58 "Begin") ;BOL (cl-define-keysym #xff60 "Select") ;Select, mark (cl-define-keysym #xff61 "Print") (cl-define-keysym #xff62 "Execute") ;Execute, run, do (cl-define-keysym #xff63 "Insert") ;Insert, insert here (cl-define-keysym #xff65 "Undo") (cl-define-keysym #xff66 "Redo") ;Redo, again (cl-define-keysym #xff67 "Menu") (cl-define-keysym #xff68 "Find") ;Find, search (cl-define-keysym #xff69 "Cancel") ;Cancel, stop, abort, exit (cl-define-keysym #xff6a "Help") ;Help (cl-define-keysym #xff6b "Break") (cl-define-keysym #xff7e "Mode_switch") ;Character set switch (cl-define-keysym #xff7e "script_switch") ;Alias for mode_switch (cl-define-keysym #xff7f "Num_Lock") (cl-define-keysym #xff80 "KP_Space") ;Space (cl-define-keysym #xff89 "KP_Tab") (cl-define-keysym #xff8d "KP_Enter") ;Enter (cl-define-keysym #xff91 "KP_F1") ;PF1, KP_A, ... (cl-define-keysym #xff92 "KP_F2") (cl-define-keysym #xff93 "KP_F3") (cl-define-keysym #xff94 "KP_F4") (cl-define-keysym #xff95 "KP_Home") (cl-define-keysym #xff96 "KP_Left") (cl-define-keysym #xff97 "KP_Up") (cl-define-keysym #xff98 "KP_Right") (cl-define-keysym #xff99 "KP_Down") (cl-define-keysym #xff9a "KP_Prior") (cl-define-keysym #xff9a "KP_Page_Up") (cl-define-keysym #xff9b "KP_Next") (cl-define-keysym #xff9b "KP_Page_Down") (cl-define-keysym #xff9c "KP_End") (cl-define-keysym #xff9d "KP_Begin") (cl-define-keysym #xff9e "KP_Insert") (cl-define-keysym #xff9f "KP_Delete") (cl-define-keysym #xffbd "KP_Equal") ;Equals (cl-define-keysym #xffaa "KP_Multiply") (cl-define-keysym #xffab "KP_Add") (cl-define-keysym #xffac "KP_Separator") ;Separator, often comma (cl-define-keysym #xffad "KP_Subtract") (cl-define-keysym #xffae "KP_Decimal") (cl-define-keysym #xffaf "KP_Divide") (cl-define-keysym #xffb0 "KP_0") (cl-define-keysym #xffb1 "KP_1") (cl-define-keysym #xffb2 "KP_2") (cl-define-keysym #xffb3 "KP_3") (cl-define-keysym #xffb4 "KP_4") (cl-define-keysym #xffb5 "KP_5") (cl-define-keysym #xffb6 "KP_6") (cl-define-keysym #xffb7 "KP_7") (cl-define-keysym #xffb8 "KP_8") (cl-define-keysym #xffb9 "KP_9") (cl-define-keysym #xffbe "F1") (cl-define-keysym #xffbf "F2") (cl-define-keysym #xffc0 "F3") (cl-define-keysym #xffc1 "F4") (cl-define-keysym #xffc2 "F5") (cl-define-keysym #xffc3 "F6") (cl-define-keysym #xffc4 "F7") (cl-define-keysym #xffc5 "F8") (cl-define-keysym #xffc6 "F9") (cl-define-keysym #xffc7 "F10") (cl-define-keysym #xffc8 "F11") (cl-define-keysym #xffc8 "L1") (cl-define-keysym #xffc9 "F12") (cl-define-keysym #xffc9 "L2") (cl-define-keysym #xffca "F13") (cl-define-keysym #xffca "L3") (cl-define-keysym #xffcb "F14") (cl-define-keysym #xffcb "L4") (cl-define-keysym #xffcc "F15") (cl-define-keysym #xffcc "L5") (cl-define-keysym #xffcd "F16") (cl-define-keysym #xffcd "L6") (cl-define-keysym #xffce "F17") (cl-define-keysym #xffce "L7") (cl-define-keysym #xffcf "F18") (cl-define-keysym #xffcf "L8") (cl-define-keysym #xffd0 "F19") (cl-define-keysym #xffd0 "L9") (cl-define-keysym #xffd1 "F20") (cl-define-keysym #xffd1 "L10") (cl-define-keysym #xffd2 "F21") (cl-define-keysym #xffd2 "R1") (cl-define-keysym #xffd3 "F22") (cl-define-keysym #xffd3 "R2") (cl-define-keysym #xffd4 "F23") (cl-define-keysym #xffd4 "R3") (cl-define-keysym #xffd5 "F24") (cl-define-keysym #xffd5 "R4") (cl-define-keysym #xffd6 "F25") (cl-define-keysym #xffd6 "R5") (cl-define-keysym #xffd7 "F26") (cl-define-keysym #xffd7 "R6") (cl-define-keysym #xffd8 "F27") (cl-define-keysym #xffd8 "R7") (cl-define-keysym #xffd9 "F28") (cl-define-keysym #xffd9 "R8") (cl-define-keysym #xffda "F29") (cl-define-keysym #xffda "R9") (cl-define-keysym #xffdb "F30") (cl-define-keysym #xffdb "R10") (cl-define-keysym #xffdc "F31") (cl-define-keysym #xffdc "R11") (cl-define-keysym #xffdd "F32") (cl-define-keysym #xffdd "R12") (cl-define-keysym #xffde "F33") (cl-define-keysym #xffde "R13") (cl-define-keysym #xffdf "F34") (cl-define-keysym #xffdf "R14") (cl-define-keysym #xffe0 "F35") (cl-define-keysym #xffe0 "R15") (cl-define-keysym #xffe1 "Shift_L") ;Left shift (cl-define-keysym #xffe2 "Shift_R") ;Right shift (cl-define-keysym #xffe3 "Control_L") ;Left control (cl-define-keysym #xffe4 "Control_R") ;Right control (cl-define-keysym #xffe5 "Caps_Lock") ;Caps lock (cl-define-keysym #xffe6 "Shift_Lock") ;Shift lock (cl-define-keysym #xffe7 "Meta_L") ;Left meta (cl-define-keysym #xffe8 "Meta_R") ;Right meta (cl-define-keysym #xffe9 "Alt_L") ;Left alt (cl-define-keysym #xffea "Alt_R") ;Right alt (cl-define-keysym #xffeb "Super_L") ;Left super (cl-define-keysym #xffec "Super_R") ;Right super (cl-define-keysym #xffed "Hyper_L") ;Left hyper (cl-define-keysym #xffee "Hyper_R") ;Right hyper (cl-define-keysym #xfe01 "ISO_Lock") (cl-define-keysym #xfe02 "ISO_Level2_Latch") (cl-define-keysym #xfe03 "ISO_Level3_Shift") (cl-define-keysym #xfe04 "ISO_Level3_Latch") (cl-define-keysym #xfe05 "ISO_Level3_Lock") (cl-define-keysym #xff7e "ISO_Group_Shift") ;Alias for mode_switch (cl-define-keysym #xfe06 "ISO_Group_Latch") (cl-define-keysym #xfe07 "ISO_Group_Lock") (cl-define-keysym #xfe08 "ISO_Next_Group") (cl-define-keysym #xfe09 "ISO_Next_Group_Lock") (cl-define-keysym #xfe0a "ISO_Prev_Group") (cl-define-keysym #xfe0b "ISO_Prev_Group_Lock") (cl-define-keysym #xfe0c "ISO_First_Group") (cl-define-keysym #xfe0d "ISO_First_Group_Lock") (cl-define-keysym #xfe0e "ISO_Last_Group") (cl-define-keysym #xfe0f "ISO_Last_Group_Lock") (cl-define-keysym #xfe20 "ISO_Left_Tab") (cl-define-keysym #xfe21 "ISO_Move_Line_Up") (cl-define-keysym #xfe22 "ISO_Move_Line_Down") (cl-define-keysym #xfe23 "ISO_Partial_Line_Up") (cl-define-keysym #xfe24 "ISO_Partial_Line_Down") (cl-define-keysym #xfe25 "ISO_Partial_Space_Left") (cl-define-keysym #xfe26 "ISO_Partial_Space_Right") (cl-define-keysym #xfe27 "ISO_Set_Margin_Left") (cl-define-keysym #xfe28 "ISO_Set_Margin_Right") (cl-define-keysym #xfe29 "ISO_Release_Margin_Left") (cl-define-keysym #xfe2a "ISO_Release_Margin_Right") (cl-define-keysym #xfe2b "ISO_Release_Both_Margins") (cl-define-keysym #xfe2c "ISO_Fast_Cursor_Left") (cl-define-keysym #xfe2d "ISO_Fast_Cursor_Right") (cl-define-keysym #xfe2e "ISO_Fast_Cursor_Up") (cl-define-keysym #xfe2f "ISO_Fast_Cursor_Down") (cl-define-keysym #xfe30 "ISO_Continuous_Underline") (cl-define-keysym #xfe31 "ISO_Discontinuous_Underline") (cl-define-keysym #xfe32 "ISO_Emphasize") (cl-define-keysym #xfe33 "ISO_Center_Object") (cl-define-keysym #xfe34 "ISO_Enter") (cl-define-keysym #xfe50 "dead_grave") (cl-define-keysym #xfe51 "dead_acute") (cl-define-keysym #xfe52 "dead_circumflex") (cl-define-keysym #xfe53 "dead_tilde") (cl-define-keysym #xfe54 "dead_macron") (cl-define-keysym #xfe55 "dead_breve") (cl-define-keysym #xfe56 "dead_abovedot") (cl-define-keysym #xfe57 "dead_diaeresis") (cl-define-keysym #xfe58 "dead_abovering") (cl-define-keysym #xfe59 "dead_doubleacute") (cl-define-keysym #xfe5a "dead_caron") (cl-define-keysym #xfe5b "dead_cedilla") (cl-define-keysym #xfe5c "dead_ogonek") (cl-define-keysym #xfe5d "dead_iota") (cl-define-keysym #xfe5e "dead_voiced_sound") (cl-define-keysym #xfe5f "dead_semivoiced_sound") (cl-define-keysym #xfe60 "dead_belowdot") (cl-define-keysym #xfe61 "dead_hook") (cl-define-keysym #xfe62 "dead_horn") (cl-define-keysym #xfed0 "First_Virtual_Screen") (cl-define-keysym #xfed1 "Prev_Virtual_Screen") (cl-define-keysym #xfed2 "Next_Virtual_Screen") (cl-define-keysym #xfed4 "Last_Virtual_Screen") (cl-define-keysym #xfed5 "Terminate_Server") (cl-define-keysym #xfe70 "AccessX_Enable") (cl-define-keysym #xfe71 "AccessX_Feedback_Enable") (cl-define-keysym #xfe72 "RepeatKeys_Enable") (cl-define-keysym #xfe73 "SlowKeys_Enable") (cl-define-keysym #xfe74 "BounceKeys_Enable") (cl-define-keysym #xfe75 "StickyKeys_Enable") (cl-define-keysym #xfe76 "MouseKeys_Enable") (cl-define-keysym #xfe77 "MouseKeys_Accel_Enable") (cl-define-keysym #xfe78 "Overlay1_Enable") (cl-define-keysym #xfe79 "Overlay2_Enable") (cl-define-keysym #xfe7a "AudibleBell_Enable") (cl-define-keysym #xfee0 "Pointer_Left") (cl-define-keysym #xfee1 "Pointer_Right") (cl-define-keysym #xfee2 "Pointer_Up") (cl-define-keysym #xfee3 "Pointer_Down") (cl-define-keysym #xfee4 "Pointer_UpLeft") (cl-define-keysym #xfee5 "Pointer_UpRight") (cl-define-keysym #xfee6 "Pointer_DownLeft") (cl-define-keysym #xfee7 "Pointer_DownRight") (cl-define-keysym #xfee8 "Pointer_Button_Dflt") (cl-define-keysym #xfee9 "Pointer_Button1") (cl-define-keysym #xfeea "Pointer_Button2") (cl-define-keysym #xfeeb "Pointer_Button3") (cl-define-keysym #xfeec "Pointer_Button4") (cl-define-keysym #xfeed "Pointer_Button5") (cl-define-keysym #xfeee "Pointer_DblClick_Dflt") (cl-define-keysym #xfeef "Pointer_DblClick1") (cl-define-keysym #xfef0 "Pointer_DblClick2") (cl-define-keysym #xfef1 "Pointer_DblClick3") (cl-define-keysym #xfef2 "Pointer_DblClick4") (cl-define-keysym #xfef3 "Pointer_DblClick5") (cl-define-keysym #xfef4 "Pointer_Drag_Dflt") (cl-define-keysym #xfef5 "Pointer_Drag1") (cl-define-keysym #xfef6 "Pointer_Drag2") (cl-define-keysym #xfef7 "Pointer_Drag3") (cl-define-keysym #xfef8 "Pointer_Drag4") (cl-define-keysym #xfefd "Pointer_Drag5") (cl-define-keysym #xfef9 "Pointer_EnableKeys") (cl-define-keysym #xfefa "Pointer_Accelerate") (cl-define-keysym #xfefb "Pointer_DfltBtnNext") (cl-define-keysym #xfefc "Pointer_DfltBtnPrev") (cl-define-keysym #xfd01 "3270_Duplicate") (cl-define-keysym #xfd02 "3270_FieldMark") (cl-define-keysym #xfd03 "3270_Right2") (cl-define-keysym #xfd04 "3270_Left2") (cl-define-keysym #xfd05 "3270_BackTab") (cl-define-keysym #xfd06 "3270_EraseEOF") (cl-define-keysym #xfd07 "3270_EraseInput") (cl-define-keysym #xfd08 "3270_Reset") (cl-define-keysym #xfd09 "3270_Quit") (cl-define-keysym #xfd0a "3270_PA1") (cl-define-keysym #xfd0b "3270_PA2") (cl-define-keysym #xfd0c "3270_PA3") (cl-define-keysym #xfd0d "3270_Test") (cl-define-keysym #xfd0e "3270_Attn") (cl-define-keysym #xfd0f "3270_CursorBlink") (cl-define-keysym #xfd10 "3270_AltCursor") (cl-define-keysym #xfd11 "3270_KeyClick") (cl-define-keysym #xfd12 "3270_Jump") (cl-define-keysym #xfd13 "3270_Ident") (cl-define-keysym #xfd14 "3270_Rule") (cl-define-keysym #xfd15 "3270_Copy") (cl-define-keysym #xfd16 "3270_Play") (cl-define-keysym #xfd17 "3270_Setup") (cl-define-keysym #xfd18 "3270_Record") (cl-define-keysym #xfd19 "3270_ChangeScreen") (cl-define-keysym #xfd1a "3270_DeleteWord") (cl-define-keysym #xfd1b "3270_ExSelect") (cl-define-keysym #xfd1c "3270_CursorSelect") (cl-define-keysym #xfd1d "3270_PrintScreen") (cl-define-keysym #xfd1e "3270_Enter") (cl-define-keysym #x0020 "space") ;U+0020 SPACE (cl-define-keysym #x0021 "exclam") ;U+0021 EXCLAMATION MARK (cl-define-keysym #x0022 "quotedbl") ;U+0022 QUOTATION MARK (cl-define-keysym #x0023 "numbersign") ;U+0023 NUMBER SIGN (cl-define-keysym #x0024 "dollar") ;U+0024 DOLLAR SIGN (cl-define-keysym #x0025 "percent") ;U+0025 PERCENT SIGN (cl-define-keysym #x0026 "ampersand") ;U+0026 AMPERSAND (cl-define-keysym #x0027 "apostrophe") ;U+0027 APOSTROPHE (cl-define-keysym #x0027 "quoteright") ;deprecated (cl-define-keysym #x0028 "parenleft") ;U+0028 LEFT PARENTHESIS (cl-define-keysym #x0029 "parenright") ;U+0029 RIGHT PARENTHESIS (cl-define-keysym #x002a "asterisk") ;U+002A ASTERISK (cl-define-keysym #x002b "plus") ;U+002B PLUS SIGN (cl-define-keysym #x002c "comma") ;U+002C COMMA (cl-define-keysym #x002d "minus") ;U+002D HYPHEN-MINUS (cl-define-keysym #x002e "period") ;U+002E FULL STOP (cl-define-keysym #x002f "slash") ;U+002F SOLIDUS (cl-define-keysym #x0030 "0") ;U+0030 DIGIT ZERO (cl-define-keysym #x0031 "1") ;U+0031 DIGIT ONE (cl-define-keysym #x0032 "2") ;U+0032 DIGIT TWO (cl-define-keysym #x0033 "3") ;U+0033 DIGIT THREE (cl-define-keysym #x0034 "4") ;U+0034 DIGIT FOUR (cl-define-keysym #x0035 "5") ;U+0035 DIGIT FIVE (cl-define-keysym #x0036 "6") ;U+0036 DIGIT SIX (cl-define-keysym #x0037 "7") ;U+0037 DIGIT SEVEN (cl-define-keysym #x0038 "8") ;U+0038 DIGIT EIGHT (cl-define-keysym #x0039 "9") ;U+0039 DIGIT NINE (cl-define-keysym #x003a "colon") ;U+003A COLON (cl-define-keysym #x003b "semicolon") ;U+003B SEMICOLON (cl-define-keysym #x003c "less") ;U+003C LESS-THAN SIGN (cl-define-keysym #x003d "equal") ;U+003D EQUALS SIGN (cl-define-keysym #x003e "greater") ;U+003E GREATER-THAN SIGN (cl-define-keysym #x003f "question") ;U+003F QUESTION MARK (cl-define-keysym #x0040 "at") ;U+0040 COMMERCIAL AT (cl-define-keysym #x0041 "A") ;U+0041 LATIN CAPITAL LETTER A (cl-define-keysym #x0042 "B") ;U+0042 LATIN CAPITAL LETTER B (cl-define-keysym #x0043 "C") ;U+0043 LATIN CAPITAL LETTER C (cl-define-keysym #x0044 "D") ;U+0044 LATIN CAPITAL LETTER D (cl-define-keysym #x0045 "E") ;U+0045 LATIN CAPITAL LETTER E (cl-define-keysym #x0046 "F") ;U+0046 LATIN CAPITAL LETTER F (cl-define-keysym #x0047 "G") ;U+0047 LATIN CAPITAL LETTER G (cl-define-keysym #x0048 "H") ;U+0048 LATIN CAPITAL LETTER H (cl-define-keysym #x0049 "I") ;U+0049 LATIN CAPITAL LETTER I (cl-define-keysym #x004a "J") ;U+004A LATIN CAPITAL LETTER J (cl-define-keysym #x004b "K") ;U+004B LATIN CAPITAL LETTER K (cl-define-keysym #x004c "L") ;U+004C LATIN CAPITAL LETTER L (cl-define-keysym #x004d "M") ;U+004D LATIN CAPITAL LETTER M (cl-define-keysym #x004e "N") ;U+004E LATIN CAPITAL LETTER N (cl-define-keysym #x004f "O") ;U+004F LATIN CAPITAL LETTER O (cl-define-keysym #x0050 "P") ;U+0050 LATIN CAPITAL LETTER P (cl-define-keysym #x0051 "Q") ;U+0051 LATIN CAPITAL LETTER Q (cl-define-keysym #x0052 "R") ;U+0052 LATIN CAPITAL LETTER R (cl-define-keysym #x0053 "S") ;U+0053 LATIN CAPITAL LETTER S (cl-define-keysym #x0054 "T") ;U+0054 LATIN CAPITAL LETTER T (cl-define-keysym #x0055 "U") ;U+0055 LATIN CAPITAL LETTER U (cl-define-keysym #x0056 "V") ;U+0056 LATIN CAPITAL LETTER V (cl-define-keysym #x0057 "W") ;U+0057 LATIN CAPITAL LETTER W (cl-define-keysym #x0058 "X") ;U+0058 LATIN CAPITAL LETTER X (cl-define-keysym #x0059 "Y") ;U+0059 LATIN CAPITAL LETTER Y (cl-define-keysym #x005a "Z") ;U+005A LATIN CAPITAL LETTER Z (cl-define-keysym #x005b "bracketleft") ;U+005B LEFT SQUARE BRACKET (cl-define-keysym #x005c "backslash") ;U+005C REVERSE SOLIDUS (cl-define-keysym #x005d "bracketright") ;U+005D RIGHT SQUARE BRACKET (cl-define-keysym #x005e "asciicircum") ;U+005E CIRCUMFLEX ACCENT (cl-define-keysym #x005f "underscore") ;U+005F LOW LINE (cl-define-keysym #x0060 "grave") ;U+0060 GRAVE ACCENT (cl-define-keysym #x0060 "quoteleft") ;deprecated (cl-define-keysym #x0061 "a") ;U+0061 LATIN SMALL LETTER A (cl-define-keysym #x0062 "b") ;U+0062 LATIN SMALL LETTER B (cl-define-keysym #x0063 "c") ;U+0063 LATIN SMALL LETTER C (cl-define-keysym #x0064 "d") ;U+0064 LATIN SMALL LETTER D (cl-define-keysym #x0065 "e") ;U+0065 LATIN SMALL LETTER E (cl-define-keysym #x0066 "f") ;U+0066 LATIN SMALL LETTER F (cl-define-keysym #x0067 "g") ;U+0067 LATIN SMALL LETTER G (cl-define-keysym #x0068 "h") ;U+0068 LATIN SMALL LETTER H (cl-define-keysym #x0069 "i") ;U+0069 LATIN SMALL LETTER I (cl-define-keysym #x006a "j") ;U+006A LATIN SMALL LETTER J (cl-define-keysym #x006b "k") ;U+006B LATIN SMALL LETTER K (cl-define-keysym #x006c "l") ;U+006C LATIN SMALL LETTER L (cl-define-keysym #x006d "m") ;U+006D LATIN SMALL LETTER M (cl-define-keysym #x006e "n") ;U+006E LATIN SMALL LETTER N (cl-define-keysym #x006f "o") ;U+006F LATIN SMALL LETTER O (cl-define-keysym #x0070 "p") ;U+0070 LATIN SMALL LETTER P (cl-define-keysym #x0071 "q") ;U+0071 LATIN SMALL LETTER Q (cl-define-keysym #x0072 "r") ;U+0072 LATIN SMALL LETTER R (cl-define-keysym #x0073 "s") ;U+0073 LATIN SMALL LETTER S (cl-define-keysym #x0074 "t") ;U+0074 LATIN SMALL LETTER T (cl-define-keysym #x0075 "u") ;U+0075 LATIN SMALL LETTER U (cl-define-keysym #x0076 "v") ;U+0076 LATIN SMALL LETTER V (cl-define-keysym #x0077 "w") ;U+0077 LATIN SMALL LETTER W (cl-define-keysym #x0078 "x") ;U+0078 LATIN SMALL LETTER X (cl-define-keysym #x0079 "y") ;U+0079 LATIN SMALL LETTER Y (cl-define-keysym #x007a "z") ;U+007A LATIN SMALL LETTER Z (cl-define-keysym #x007b "braceleft") ;U+007B LEFT CURLY BRACKET (cl-define-keysym #x007c "bar") ;U+007C VERTICAL LINE (cl-define-keysym #x007d "braceright") ;U+007D RIGHT CURLY BRACKET (cl-define-keysym #x007e "asciitilde") ;U+007E TILDE (cl-define-keysym #x00a0 "nobreakspace") ;U+00A0 NO-BREAK SPACE (cl-define-keysym #x00a1 "exclamdown") ;U+00A1 INVERTED EXCLAMATION MARK (cl-define-keysym #x00a2 "cent") ;U+00A2 CENT SIGN (cl-define-keysym #x00a3 "sterling") ;U+00A3 POUND SIGN (cl-define-keysym #x00a4 "currency") ;U+00A4 CURRENCY SIGN (cl-define-keysym #x00a5 "yen") ;U+00A5 YEN SIGN (cl-define-keysym #x00a6 "brokenbar") ;U+00A6 BROKEN BAR (cl-define-keysym #x00a7 "section") ;U+00A7 SECTION SIGN (cl-define-keysym #x00a8 "diaeresis") ;U+00A8 DIAERESIS (cl-define-keysym #x00a9 "copyright") ;U+00A9 COPYRIGHT SIGN (cl-define-keysym #x00aa "ordfeminine") ;U+00AA FEMININE ORDINAL INDICATOR (cl-define-keysym #x00ab "guillemotleft") ;U+00AB LEFT-POINTING DOUBLE ANGLE QUOTATION MARK (cl-define-keysym #x00ac "notsign") ;U+00AC NOT SIGN (cl-define-keysym #x00ad "hyphen") ;U+00AD SOFT HYPHEN (cl-define-keysym #x00ae "registered") ;U+00AE REGISTERED SIGN (cl-define-keysym #x00af "macron") ;U+00AF MACRON (cl-define-keysym #x00b0 "degree") ;U+00B0 DEGREE SIGN (cl-define-keysym #x00b1 "plusminus") ;U+00B1 PLUS-MINUS SIGN (cl-define-keysym #x00b2 "twosuperior") ;U+00B2 SUPERSCRIPT TWO (cl-define-keysym #x00b3 "threesuperior") ;U+00B3 SUPERSCRIPT THREE (cl-define-keysym #x00b4 "acute") ;U+00B4 ACUTE ACCENT (cl-define-keysym #x00b5 "mu") ;U+00B5 MICRO SIGN (cl-define-keysym #x00b6 "paragraph") ;U+00B6 PILCROW SIGN (cl-define-keysym #x00b7 "periodcentered") ;U+00B7 MIDDLE DOT (cl-define-keysym #x00b8 "cedilla") ;U+00B8 CEDILLA (cl-define-keysym #x00b9 "onesuperior") ;U+00B9 SUPERSCRIPT ONE (cl-define-keysym #x00ba "masculine") ;U+00BA MASCULINE ORDINAL INDICATOR (cl-define-keysym #x00bb "guillemotright") ;U+00BB RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK (cl-define-keysym #x00bc "onequarter") ;U+00BC VULGAR FRACTION ONE QUARTER (cl-define-keysym #x00bd "onehalf") ;U+00BD VULGAR FRACTION ONE HALF (cl-define-keysym #x00be "threequarters") ;U+00BE VULGAR FRACTION THREE QUARTERS (cl-define-keysym #x00bf "questiondown") ;U+00BF INVERTED QUESTION MARK (cl-define-keysym #x00c0 "Agrave") ;U+00C0 LATIN CAPITAL LETTER A WITH GRAVE (cl-define-keysym #x00c1 "Aacute") ;U+00C1 LATIN CAPITAL LETTER A WITH ACUTE (cl-define-keysym #x00c2 "Acircumflex") ;U+00C2 LATIN CAPITAL LETTER A WITH CIRCUMFLEX (cl-define-keysym #x00c3 "Atilde") ;U+00C3 LATIN CAPITAL LETTER A WITH TILDE (cl-define-keysym #x00c4 "Adiaeresis") ;U+00C4 LATIN CAPITAL LETTER A WITH DIAERESIS (cl-define-keysym #x00c5 "Aring") ;U+00C5 LATIN CAPITAL LETTER A WITH RING ABOVE (cl-define-keysym #x00c6 "AE") ;U+00C6 LATIN CAPITAL LETTER AE (cl-define-keysym #x00c7 "Ccedilla") ;U+00C7 LATIN CAPITAL LETTER C WITH CEDILLA (cl-define-keysym #x00c8 "Egrave") ;U+00C8 LATIN CAPITAL LETTER E WITH GRAVE (cl-define-keysym #x00c9 "Eacute") ;U+00C9 LATIN CAPITAL LETTER E WITH ACUTE (cl-define-keysym #x00ca "Ecircumflex") ;U+00CA LATIN CAPITAL LETTER E WITH CIRCUMFLEX (cl-define-keysym #x00cb "Ediaeresis") ;U+00CB LATIN CAPITAL LETTER E WITH DIAERESIS (cl-define-keysym #x00cc "Igrave") ;U+00CC LATIN CAPITAL LETTER I WITH GRAVE (cl-define-keysym #x00cd "Iacute") ;U+00CD LATIN CAPITAL LETTER I WITH ACUTE (cl-define-keysym #x00ce "Icircumflex") ;U+00CE LATIN CAPITAL LETTER I WITH CIRCUMFLEX (cl-define-keysym #x00cf "Idiaeresis") ;U+00CF LATIN CAPITAL LETTER I WITH DIAERESIS (cl-define-keysym #x00d0 "ETH") ;U+00D0 LATIN CAPITAL LETTER ETH (cl-define-keysym #x00d0 "Eth") ;deprecated (cl-define-keysym #x00d1 "Ntilde") ;U+00D1 LATIN CAPITAL LETTER N WITH TILDE (cl-define-keysym #x00d2 "Ograve") ;U+00D2 LATIN CAPITAL LETTER O WITH GRAVE (cl-define-keysym #x00d3 "Oacute") ;U+00D3 LATIN CAPITAL LETTER O WITH ACUTE (cl-define-keysym #x00d4 "Ocircumflex") ;U+00D4 LATIN CAPITAL LETTER O WITH CIRCUMFLEX (cl-define-keysym #x00d5 "Otilde") ;U+00D5 LATIN CAPITAL LETTER O WITH TILDE (cl-define-keysym #x00d6 "Odiaeresis") ;U+00D6 LATIN CAPITAL LETTER O WITH DIAERESIS (cl-define-keysym #x00d7 "multiply") ;U+00D7 MULTIPLICATION SIGN (cl-define-keysym #x00d8 "Oslash") ;U+00D8 LATIN CAPITAL LETTER O WITH STROKE (cl-define-keysym #x00d8 "Ooblique") ;U+00D8 LATIN CAPITAL LETTER O WITH STROKE (cl-define-keysym #x00d9 "Ugrave") ;U+00D9 LATIN CAPITAL LETTER U WITH GRAVE (cl-define-keysym #x00da "Uacute") ;U+00DA LATIN CAPITAL LETTER U WITH ACUTE (cl-define-keysym #x00db "Ucircumflex") ;U+00DB LATIN CAPITAL LETTER U WITH CIRCUMFLEX (cl-define-keysym #x00dc "Udiaeresis") ;U+00DC LATIN CAPITAL LETTER U WITH DIAERESIS (cl-define-keysym #x00dd "Yacute") ;U+00DD LATIN CAPITAL LETTER Y WITH ACUTE (cl-define-keysym #x00de "THORN") ;U+00DE LATIN CAPITAL LETTER THORN (cl-define-keysym #x00de "Thorn") ;deprecated (cl-define-keysym #x00df "ssharp") ;U+00DF LATIN SMALL LETTER SHARP S (cl-define-keysym #x00e0 "agrave") ;U+00E0 LATIN SMALL LETTER A WITH GRAVE (cl-define-keysym #x00e1 "aacute") ;U+00E1 LATIN SMALL LETTER A WITH ACUTE (cl-define-keysym #x00e2 "acircumflex") ;U+00E2 LATIN SMALL LETTER A WITH CIRCUMFLEX (cl-define-keysym #x00e3 "atilde") ;U+00E3 LATIN SMALL LETTER A WITH TILDE (cl-define-keysym #x00e4 "adiaeresis") ;U+00E4 LATIN SMALL LETTER A WITH DIAERESIS (cl-define-keysym #x00e5 "aring") ;U+00E5 LATIN SMALL LETTER A WITH RING ABOVE (cl-define-keysym #x00e6 "ae") ;U+00E6 LATIN SMALL LETTER AE (cl-define-keysym #x00e7 "ccedilla") ;U+00E7 LATIN SMALL LETTER C WITH CEDILLA (cl-define-keysym #x00e8 "egrave") ;U+00E8 LATIN SMALL LETTER E WITH GRAVE (cl-define-keysym #x00e9 "eacute") ;U+00E9 LATIN SMALL LETTER E WITH ACUTE (cl-define-keysym #x00ea "ecircumflex") ;U+00EA LATIN SMALL LETTER E WITH CIRCUMFLEX (cl-define-keysym #x00eb "ediaeresis") ;U+00EB LATIN SMALL LETTER E WITH DIAERESIS (cl-define-keysym #x00ec "igrave") ;U+00EC LATIN SMALL LETTER I WITH GRAVE (cl-define-keysym #x00ed "iacute") ;U+00ED LATIN SMALL LETTER I WITH ACUTE (cl-define-keysym #x00ee "icircumflex") ;U+00EE LATIN SMALL LETTER I WITH CIRCUMFLEX (cl-define-keysym #x00ef "idiaeresis") ;U+00EF LATIN SMALL LETTER I WITH DIAERESIS (cl-define-keysym #x00f0 "eth") ;U+00F0 LATIN SMALL LETTER ETH (cl-define-keysym #x00f1 "ntilde") ;U+00F1 LATIN SMALL LETTER N WITH TILDE (cl-define-keysym #x00f2 "ograve") ;U+00F2 LATIN SMALL LETTER O WITH GRAVE (cl-define-keysym #x00f3 "oacute") ;U+00F3 LATIN SMALL LETTER O WITH ACUTE (cl-define-keysym #x00f4 "ocircumflex") ;U+00F4 LATIN SMALL LETTER O WITH CIRCUMFLEX (cl-define-keysym #x00f5 "otilde") ;U+00F5 LATIN SMALL LETTER O WITH TILDE (cl-define-keysym #x00f6 "odiaeresis") ;U+00F6 LATIN SMALL LETTER O WITH DIAERESIS (cl-define-keysym #x00f7 "division") ;U+00F7 DIVISION SIGN (cl-define-keysym #x00f8 "oslash") ;U+00F8 LATIN SMALL LETTER O WITH STROKE (cl-define-keysym #x00f8 "ooblique") ;U+00F8 LATIN SMALL LETTER O WITH STROKE (cl-define-keysym #x00f9 "ugrave") ;U+00F9 LATIN SMALL LETTER U WITH GRAVE (cl-define-keysym #x00fa "uacute") ;U+00FA LATIN SMALL LETTER U WITH ACUTE (cl-define-keysym #x00fb "ucircumflex") ;U+00FB LATIN SMALL LETTER U WITH CIRCUMFLEX (cl-define-keysym #x00fc "udiaeresis") ;U+00FC LATIN SMALL LETTER U WITH DIAERESIS (cl-define-keysym #x00fd "yacute") ;U+00FD LATIN SMALL LETTER Y WITH ACUTE (cl-define-keysym #x00fe "thorn") ;U+00FE LATIN SMALL LETTER THORN (cl-define-keysym #x00ff "ydiaeresis") ;U+00FF LATIN SMALL LETTER Y WITH DIAERESIS (cl-define-keysym #x01a1 "Aogonek") ;U+0104 LATIN CAPITAL LETTER A WITH OGONEK (cl-define-keysym #x01a2 "breve") ;U+02D8 BREVE (cl-define-keysym #x01a3 "Lstroke") ;U+0141 LATIN CAPITAL LETTER L WITH STROKE (cl-define-keysym #x01a5 "Lcaron") ;U+013D LATIN CAPITAL LETTER L WITH CARON (cl-define-keysym #x01a6 "Sacute") ;U+015A LATIN CAPITAL LETTER S WITH ACUTE (cl-define-keysym #x01a9 "Scaron") ;U+0160 LATIN CAPITAL LETTER S WITH CARON (cl-define-keysym #x01aa "Scedilla") ;U+015E LATIN CAPITAL LETTER S WITH CEDILLA (cl-define-keysym #x01ab "Tcaron") ;U+0164 LATIN CAPITAL LETTER T WITH CARON (cl-define-keysym #x01ac "Zacute") ;U+0179 LATIN CAPITAL LETTER Z WITH ACUTE (cl-define-keysym #x01ae "Zcaron") ;U+017D LATIN CAPITAL LETTER Z WITH CARON (cl-define-keysym #x01af "Zabovedot") ;U+017B LATIN CAPITAL LETTER Z WITH DOT ABOVE (cl-define-keysym #x01b1 "aogonek") ;U+0105 LATIN SMALL LETTER A WITH OGONEK (cl-define-keysym #x01b2 "ogonek") ;U+02DB OGONEK (cl-define-keysym #x01b3 "lstroke") ;U+0142 LATIN SMALL LETTER L WITH STROKE (cl-define-keysym #x01b5 "lcaron") ;U+013E LATIN SMALL LETTER L WITH CARON (cl-define-keysym #x01b6 "sacute") ;U+015B LATIN SMALL LETTER S WITH ACUTE (cl-define-keysym #x01b7 "caron") ;U+02C7 CARON (cl-define-keysym #x01b9 "scaron") ;U+0161 LATIN SMALL LETTER S WITH CARON (cl-define-keysym #x01ba "scedilla") ;U+015F LATIN SMALL LETTER S WITH CEDILLA (cl-define-keysym #x01bb "tcaron") ;U+0165 LATIN SMALL LETTER T WITH CARON (cl-define-keysym #x01bc "zacute") ;U+017A LATIN SMALL LETTER Z WITH ACUTE (cl-define-keysym #x01bd "doubleacute") ;U+02DD DOUBLE ACUTE ACCENT (cl-define-keysym #x01be "zcaron") ;U+017E LATIN SMALL LETTER Z WITH CARON (cl-define-keysym #x01bf "zabovedot") ;U+017C LATIN SMALL LETTER Z WITH DOT ABOVE (cl-define-keysym #x01c0 "Racute") ;U+0154 LATIN CAPITAL LETTER R WITH ACUTE (cl-define-keysym #x01c3 "Abreve") ;U+0102 LATIN CAPITAL LETTER A WITH BREVE (cl-define-keysym #x01c5 "Lacute") ;U+0139 LATIN CAPITAL LETTER L WITH ACUTE (cl-define-keysym #x01c6 "Cacute") ;U+0106 LATIN CAPITAL LETTER C WITH ACUTE (cl-define-keysym #x01c8 "Ccaron") ;U+010C LATIN CAPITAL LETTER C WITH CARON (cl-define-keysym #x01ca "Eogonek") ;U+0118 LATIN CAPITAL LETTER E WITH OGONEK (cl-define-keysym #x01cc "Ecaron") ;U+011A LATIN CAPITAL LETTER E WITH CARON (cl-define-keysym #x01cf "Dcaron") ;U+010E LATIN CAPITAL LETTER D WITH CARON (cl-define-keysym #x01d0 "Dstroke") ;U+0110 LATIN CAPITAL LETTER D WITH STROKE (cl-define-keysym #x01d1 "Nacute") ;U+0143 LATIN CAPITAL LETTER N WITH ACUTE (cl-define-keysym #x01d2 "Ncaron") ;U+0147 LATIN CAPITAL LETTER N WITH CARON (cl-define-keysym #x01d5 "Odoubleacute") ;U+0150 LATIN CAPITAL LETTER O WITH DOUBLE ACUTE (cl-define-keysym #x01d8 "Rcaron") ;U+0158 LATIN CAPITAL LETTER R WITH CARON (cl-define-keysym #x01d9 "Uring") ;U+016E LATIN CAPITAL LETTER U WITH RING ABOVE (cl-define-keysym #x01db "Udoubleacute") ;U+0170 LATIN CAPITAL LETTER U WITH DOUBLE ACUTE (cl-define-keysym #x01de "Tcedilla") ;U+0162 LATIN CAPITAL LETTER T WITH CEDILLA (cl-define-keysym #x01e0 "racute") ;U+0155 LATIN SMALL LETTER R WITH ACUTE (cl-define-keysym #x01e3 "abreve") ;U+0103 LATIN SMALL LETTER A WITH BREVE (cl-define-keysym #x01e5 "lacute") ;U+013A LATIN SMALL LETTER L WITH ACUTE (cl-define-keysym #x01e6 "cacute") ;U+0107 LATIN SMALL LETTER C WITH ACUTE (cl-define-keysym #x01e8 "ccaron") ;U+010D LATIN SMALL LETTER C WITH CARON (cl-define-keysym #x01ea "eogonek") ;U+0119 LATIN SMALL LETTER E WITH OGONEK (cl-define-keysym #x01ec "ecaron") ;U+011B LATIN SMALL LETTER E WITH CARON (cl-define-keysym #x01ef "dcaron") ;U+010F LATIN SMALL LETTER D WITH CARON (cl-define-keysym #x01f0 "dstroke") ;U+0111 LATIN SMALL LETTER D WITH STROKE (cl-define-keysym #x01f1 "nacute") ;U+0144 LATIN SMALL LETTER N WITH ACUTE (cl-define-keysym #x01f2 "ncaron") ;U+0148 LATIN SMALL LETTER N WITH CARON (cl-define-keysym #x01f5 "odoubleacute") ;U+0151 LATIN SMALL LETTER O WITH DOUBLE ACUTE (cl-define-keysym #x01fb "udoubleacute") ;U+0171 LATIN SMALL LETTER U WITH DOUBLE ACUTE (cl-define-keysym #x01f8 "rcaron") ;U+0159 LATIN SMALL LETTER R WITH CARON (cl-define-keysym #x01f9 "uring") ;U+016F LATIN SMALL LETTER U WITH RING ABOVE (cl-define-keysym #x01fe "tcedilla") ;U+0163 LATIN SMALL LETTER T WITH CEDILLA (cl-define-keysym #x01ff "abovedot") ;U+02D9 DOT ABOVE (cl-define-keysym #x02a1 "Hstroke") ;U+0126 LATIN CAPITAL LETTER H WITH STROKE (cl-define-keysym #x02a6 "Hcircumflex") ;U+0124 LATIN CAPITAL LETTER H WITH CIRCUMFLEX (cl-define-keysym #x02a9 "Iabovedot") ;U+0130 LATIN CAPITAL LETTER I WITH DOT ABOVE (cl-define-keysym #x02ab "Gbreve") ;U+011E LATIN CAPITAL LETTER G WITH BREVE (cl-define-keysym #x02ac "Jcircumflex") ;U+0134 LATIN CAPITAL LETTER J WITH CIRCUMFLEX (cl-define-keysym #x02b1 "hstroke") ;U+0127 LATIN SMALL LETTER H WITH STROKE (cl-define-keysym #x02b6 "hcircumflex") ;U+0125 LATIN SMALL LETTER H WITH CIRCUMFLEX (cl-define-keysym #x02b9 "idotless") ;U+0131 LATIN SMALL LETTER DOTLESS I (cl-define-keysym #x02bb "gbreve") ;U+011F LATIN SMALL LETTER G WITH BREVE (cl-define-keysym #x02bc "jcircumflex") ;U+0135 LATIN SMALL LETTER J WITH CIRCUMFLEX (cl-define-keysym #x02c5 "Cabovedot") ;U+010A LATIN CAPITAL LETTER C WITH DOT ABOVE (cl-define-keysym #x02c6 "Ccircumflex") ;U+0108 LATIN CAPITAL LETTER C WITH CIRCUMFLEX (cl-define-keysym #x02d5 "Gabovedot") ;U+0120 LATIN CAPITAL LETTER G WITH DOT ABOVE (cl-define-keysym #x02d8 "Gcircumflex") ;U+011C LATIN CAPITAL LETTER G WITH CIRCUMFLEX (cl-define-keysym #x02dd "Ubreve") ;U+016C LATIN CAPITAL LETTER U WITH BREVE (cl-define-keysym #x02de "Scircumflex") ;U+015C LATIN CAPITAL LETTER S WITH CIRCUMFLEX (cl-define-keysym #x02e5 "cabovedot") ;U+010B LATIN SMALL LETTER C WITH DOT ABOVE (cl-define-keysym #x02e6 "ccircumflex") ;U+0109 LATIN SMALL LETTER C WITH CIRCUMFLEX (cl-define-keysym #x02f5 "gabovedot") ;U+0121 LATIN SMALL LETTER G WITH DOT ABOVE (cl-define-keysym #x02f8 "gcircumflex") ;U+011D LATIN SMALL LETTER G WITH CIRCUMFLEX (cl-define-keysym #x02fd "ubreve") ;U+016D LATIN SMALL LETTER U WITH BREVE (cl-define-keysym #x02fe "scircumflex") ;U+015D LATIN SMALL LETTER S WITH CIRCUMFLEX (cl-define-keysym #x03a2 "kra") ;U+0138 LATIN SMALL LETTER KRA (cl-define-keysym #x03a2 "kappa") ;deprecated (cl-define-keysym #x03a3 "Rcedilla") ;U+0156 LATIN CAPITAL LETTER R WITH CEDILLA (cl-define-keysym #x03a5 "Itilde") ;U+0128 LATIN CAPITAL LETTER I WITH TILDE (cl-define-keysym #x03a6 "Lcedilla") ;U+013B LATIN CAPITAL LETTER L WITH CEDILLA (cl-define-keysym #x03aa "Emacron") ;U+0112 LATIN CAPITAL LETTER E WITH MACRON (cl-define-keysym #x03ab "Gcedilla") ;U+0122 LATIN CAPITAL LETTER G WITH CEDILLA (cl-define-keysym #x03ac "Tslash") ;U+0166 LATIN CAPITAL LETTER T WITH STROKE (cl-define-keysym #x03b3 "rcedilla") ;U+0157 LATIN SMALL LETTER R WITH CEDILLA (cl-define-keysym #x03b5 "itilde") ;U+0129 LATIN SMALL LETTER I WITH TILDE (cl-define-keysym #x03b6 "lcedilla") ;U+013C LATIN SMALL LETTER L WITH CEDILLA (cl-define-keysym #x03ba "emacron") ;U+0113 LATIN SMALL LETTER E WITH MACRON (cl-define-keysym #x03bb "gcedilla") ;U+0123 LATIN SMALL LETTER G WITH CEDILLA (cl-define-keysym #x03bc "tslash") ;U+0167 LATIN SMALL LETTER T WITH STROKE (cl-define-keysym #x03bd "ENG") ;U+014A LATIN CAPITAL LETTER ENG (cl-define-keysym #x03bf "eng") ;U+014B LATIN SMALL LETTER ENG (cl-define-keysym #x03c0 "Amacron") ;U+0100 LATIN CAPITAL LETTER A WITH MACRON (cl-define-keysym #x03c7 "Iogonek") ;U+012E LATIN CAPITAL LETTER I WITH OGONEK (cl-define-keysym #x03cc "Eabovedot") ;U+0116 LATIN CAPITAL LETTER E WITH DOT ABOVE (cl-define-keysym #x03cf "Imacron") ;U+012A LATIN CAPITAL LETTER I WITH MACRON (cl-define-keysym #x03d1 "Ncedilla") ;U+0145 LATIN CAPITAL LETTER N WITH CEDILLA (cl-define-keysym #x03d2 "Omacron") ;U+014C LATIN CAPITAL LETTER O WITH MACRON (cl-define-keysym #x03d3 "Kcedilla") ;U+0136 LATIN CAPITAL LETTER K WITH CEDILLA (cl-define-keysym #x03d9 "Uogonek") ;U+0172 LATIN CAPITAL LETTER U WITH OGONEK (cl-define-keysym #x03dd "Utilde") ;U+0168 LATIN CAPITAL LETTER U WITH TILDE (cl-define-keysym #x03de "Umacron") ;U+016A LATIN CAPITAL LETTER U WITH MACRON (cl-define-keysym #x03e0 "amacron") ;U+0101 LATIN SMALL LETTER A WITH MACRON (cl-define-keysym #x03e7 "iogonek") ;U+012F LATIN SMALL LETTER I WITH OGONEK (cl-define-keysym #x03ec "eabovedot") ;U+0117 LATIN SMALL LETTER E WITH DOT ABOVE (cl-define-keysym #x03ef "imacron") ;U+012B LATIN SMALL LETTER I WITH MACRON (cl-define-keysym #x03f1 "ncedilla") ;U+0146 LATIN SMALL LETTER N WITH CEDILLA (cl-define-keysym #x03f2 "omacron") ;U+014D LATIN SMALL LETTER O WITH MACRON (cl-define-keysym #x03f3 "kcedilla") ;U+0137 LATIN SMALL LETTER K WITH CEDILLA (cl-define-keysym #x03f9 "uogonek") ;U+0173 LATIN SMALL LETTER U WITH OGONEK (cl-define-keysym #x03fd "utilde") ;U+0169 LATIN SMALL LETTER U WITH TILDE (cl-define-keysym #x03fe "umacron") ;U+016B LATIN SMALL LETTER U WITH MACRON (cl-define-keysym #x1001e02 "Babovedot") ;U+1E02 LATIN CAPITAL LETTER B WITH DOT ABOVE (cl-define-keysym #x1001e03 "babovedot") ;U+1E03 LATIN SMALL LETTER B WITH DOT ABOVE (cl-define-keysym #x1001e0a "Dabovedot") ;U+1E0A LATIN CAPITAL LETTER D WITH DOT ABOVE (cl-define-keysym #x1001e80 "Wgrave") ;U+1E80 LATIN CAPITAL LETTER W WITH GRAVE (cl-define-keysym #x1001e82 "Wacute") ;U+1E82 LATIN CAPITAL LETTER W WITH ACUTE (cl-define-keysym #x1001e0b "dabovedot") ;U+1E0B LATIN SMALL LETTER D WITH DOT ABOVE (cl-define-keysym #x1001ef2 "Ygrave") ;U+1EF2 LATIN CAPITAL LETTER Y WITH GRAVE (cl-define-keysym #x1001e1e "Fabovedot") ;U+1E1E LATIN CAPITAL LETTER F WITH DOT ABOVE (cl-define-keysym #x1001e1f "fabovedot") ;U+1E1F LATIN SMALL LETTER F WITH DOT ABOVE (cl-define-keysym #x1001e40 "Mabovedot") ;U+1E40 LATIN CAPITAL LETTER M WITH DOT ABOVE (cl-define-keysym #x1001e41 "mabovedot") ;U+1E41 LATIN SMALL LETTER M WITH DOT ABOVE (cl-define-keysym #x1001e56 "Pabovedot") ;U+1E56 LATIN CAPITAL LETTER P WITH DOT ABOVE (cl-define-keysym #x1001e81 "wgrave") ;U+1E81 LATIN SMALL LETTER W WITH GRAVE (cl-define-keysym #x1001e57 "pabovedot") ;U+1E57 LATIN SMALL LETTER P WITH DOT ABOVE (cl-define-keysym #x1001e83 "wacute") ;U+1E83 LATIN SMALL LETTER W WITH ACUTE (cl-define-keysym #x1001e60 "Sabovedot") ;U+1E60 LATIN CAPITAL LETTER S WITH DOT ABOVE (cl-define-keysym #x1001ef3 "ygrave") ;U+1EF3 LATIN SMALL LETTER Y WITH GRAVE (cl-define-keysym #x1001e84 "Wdiaeresis") ;U+1E84 LATIN CAPITAL LETTER W WITH DIAERESIS (cl-define-keysym #x1001e85 "wdiaeresis") ;U+1E85 LATIN SMALL LETTER W WITH DIAERESIS (cl-define-keysym #x1001e61 "sabovedot") ;U+1E61 LATIN SMALL LETTER S WITH DOT ABOVE (cl-define-keysym #x1000174 "Wcircumflex") ;U+0174 LATIN CAPITAL LETTER W WITH CIRCUMFLEX (cl-define-keysym #x1001e6a "Tabovedot") ;U+1E6A LATIN CAPITAL LETTER T WITH DOT ABOVE (cl-define-keysym #x1000176 "Ycircumflex") ;U+0176 LATIN CAPITAL LETTER Y WITH CIRCUMFLEX (cl-define-keysym #x1000175 "wcircumflex") ;U+0175 LATIN SMALL LETTER W WITH CIRCUMFLEX (cl-define-keysym #x1001e6b "tabovedot") ;U+1E6B LATIN SMALL LETTER T WITH DOT ABOVE (cl-define-keysym #x1000177 "ycircumflex") ;U+0177 LATIN SMALL LETTER Y WITH CIRCUMFLEX (cl-define-keysym #x13bc "OE") ;U+0152 LATIN CAPITAL LIGATURE OE (cl-define-keysym #x13bd "oe") ;U+0153 LATIN SMALL LIGATURE OE (cl-define-keysym #x13be "Ydiaeresis") ;U+0178 LATIN CAPITAL LETTER Y WITH DIAERESIS (cl-define-keysym #x047e "overline") ;U+203E OVERLINE (cl-define-keysym #x04a1 "kana_fullstop") ;U+3002 IDEOGRAPHIC FULL STOP (cl-define-keysym #x04a2 "kana_openingbracket") ;U+300C LEFT CORNER BRACKET (cl-define-keysym #x04a3 "kana_closingbracket") ;U+300D RIGHT CORNER BRACKET (cl-define-keysym #x04a4 "kana_comma") ;U+3001 IDEOGRAPHIC COMMA (cl-define-keysym #x04a5 "kana_conjunctive") ;U+30FB KATAKANA MIDDLE DOT (cl-define-keysym #x04a5 "kana_middledot") ;deprecated (cl-define-keysym #x04a6 "kana_WO") ;U+30F2 KATAKANA LETTER WO (cl-define-keysym #x04a7 "kana_a") ;U+30A1 KATAKANA LETTER SMALL A (cl-define-keysym #x04a8 "kana_i") ;U+30A3 KATAKANA LETTER SMALL I (cl-define-keysym #x04a9 "kana_u") ;U+30A5 KATAKANA LETTER SMALL U (cl-define-keysym #x04aa "kana_e") ;U+30A7 KATAKANA LETTER SMALL E (cl-define-keysym #x04ab "kana_o") ;U+30A9 KATAKANA LETTER SMALL O (cl-define-keysym #x04ac "kana_ya") ;U+30E3 KATAKANA LETTER SMALL YA (cl-define-keysym #x04ad "kana_yu") ;U+30E5 KATAKANA LETTER SMALL YU (cl-define-keysym #x04ae "kana_yo") ;U+30E7 KATAKANA LETTER SMALL YO (cl-define-keysym #x04af "kana_tsu") ;U+30C3 KATAKANA LETTER SMALL TU (cl-define-keysym #x04af "kana_tu") ;deprecated (cl-define-keysym #x04b0 "prolongedsound") ;U+30FC KATAKANA-HIRAGANA PROLONGED SOUND MARK (cl-define-keysym #x04b1 "kana_A") ;U+30A2 KATAKANA LETTER A (cl-define-keysym #x04b2 "kana_I") ;U+30A4 KATAKANA LETTER I (cl-define-keysym #x04b3 "kana_U") ;U+30A6 KATAKANA LETTER U (cl-define-keysym #x04b4 "kana_E") ;U+30A8 KATAKANA LETTER E (cl-define-keysym #x04b5 "kana_O") ;U+30AA KATAKANA LETTER O (cl-define-keysym #x04b6 "kana_KA") ;U+30AB KATAKANA LETTER KA (cl-define-keysym #x04b7 "kana_KI") ;U+30AD KATAKANA LETTER KI (cl-define-keysym #x04b8 "kana_KU") ;U+30AF KATAKANA LETTER KU (cl-define-keysym #x04b9 "kana_KE") ;U+30B1 KATAKANA LETTER KE (cl-define-keysym #x04ba "kana_KO") ;U+30B3 KATAKANA LETTER KO (cl-define-keysym #x04bb "kana_SA") ;U+30B5 KATAKANA LETTER SA (cl-define-keysym #x04bc "kana_SHI") ;U+30B7 KATAKANA LETTER SI (cl-define-keysym #x04bd "kana_SU") ;U+30B9 KATAKANA LETTER SU (cl-define-keysym #x04be "kana_SE") ;U+30BB KATAKANA LETTER SE (cl-define-keysym #x04bf "kana_SO") ;U+30BD KATAKANA LETTER SO (cl-define-keysym #x04c0 "kana_TA") ;U+30BF KATAKANA LETTER TA (cl-define-keysym #x04c1 "kana_CHI") ;U+30C1 KATAKANA LETTER TI (cl-define-keysym #x04c1 "kana_TI") ;deprecated (cl-define-keysym #x04c2 "kana_TSU") ;U+30C4 KATAKANA LETTER TU (cl-define-keysym #x04c2 "kana_TU") ;deprecated (cl-define-keysym #x04c3 "kana_TE") ;U+30C6 KATAKANA LETTER TE (cl-define-keysym #x04c4 "kana_TO") ;U+30C8 KATAKANA LETTER TO (cl-define-keysym #x04c5 "kana_NA") ;U+30CA KATAKANA LETTER NA (cl-define-keysym #x04c6 "kana_NI") ;U+30CB KATAKANA LETTER NI (cl-define-keysym #x04c7 "kana_NU") ;U+30CC KATAKANA LETTER NU (cl-define-keysym #x04c8 "kana_NE") ;U+30CD KATAKANA LETTER NE (cl-define-keysym #x04c9 "kana_NO") ;U+30CE KATAKANA LETTER NO (cl-define-keysym #x04ca "kana_HA") ;U+30CF KATAKANA LETTER HA (cl-define-keysym #x04cb "kana_HI") ;U+30D2 KATAKANA LETTER HI (cl-define-keysym #x04cc "kana_FU") ;U+30D5 KATAKANA LETTER HU (cl-define-keysym #x04cc "kana_HU") ;deprecated (cl-define-keysym #x04cd "kana_HE") ;U+30D8 KATAKANA LETTER HE (cl-define-keysym #x04ce "kana_HO") ;U+30DB KATAKANA LETTER HO (cl-define-keysym #x04cf "kana_MA") ;U+30DE KATAKANA LETTER MA (cl-define-keysym #x04d0 "kana_MI") ;U+30DF KATAKANA LETTER MI (cl-define-keysym #x04d1 "kana_MU") ;U+30E0 KATAKANA LETTER MU (cl-define-keysym #x04d2 "kana_ME") ;U+30E1 KATAKANA LETTER ME (cl-define-keysym #x04d3 "kana_MO") ;U+30E2 KATAKANA LETTER MO (cl-define-keysym #x04d4 "kana_YA") ;U+30E4 KATAKANA LETTER YA (cl-define-keysym #x04d5 "kana_YU") ;U+30E6 KATAKANA LETTER YU (cl-define-keysym #x04d6 "kana_YO") ;U+30E8 KATAKANA LETTER YO (cl-define-keysym #x04d7 "kana_RA") ;U+30E9 KATAKANA LETTER RA (cl-define-keysym #x04d8 "kana_RI") ;U+30EA KATAKANA LETTER RI (cl-define-keysym #x04d9 "kana_RU") ;U+30EB KATAKANA LETTER RU (cl-define-keysym #x04da "kana_RE") ;U+30EC KATAKANA LETTER RE (cl-define-keysym #x04db "kana_RO") ;U+30ED KATAKANA LETTER RO (cl-define-keysym #x04dc "kana_WA") ;U+30EF KATAKANA LETTER WA (cl-define-keysym #x04dd "kana_N") ;U+30F3 KATAKANA LETTER N (cl-define-keysym #x04de "voicedsound") ;U+309B KATAKANA-HIRAGANA VOICED SOUND MARK (cl-define-keysym #x04df "semivoicedsound") ;U+309C KATAKANA-HIRAGANA SEMI-VOICED SOUND MARK (cl-define-keysym #xff7e "kana_switch") ;Alias for mode_switch (cl-define-keysym #x10006f0 "Farsi_0") ;U+06F0 EXTENDED ARABIC-INDIC DIGIT ZERO (cl-define-keysym #x10006f1 "Farsi_1") ;U+06F1 EXTENDED ARABIC-INDIC DIGIT ONE (cl-define-keysym #x10006f2 "Farsi_2") ;U+06F2 EXTENDED ARABIC-INDIC DIGIT TWO (cl-define-keysym #x10006f3 "Farsi_3") ;U+06F3 EXTENDED ARABIC-INDIC DIGIT THREE (cl-define-keysym #x10006f4 "Farsi_4") ;U+06F4 EXTENDED ARABIC-INDIC DIGIT FOUR (cl-define-keysym #x10006f5 "Farsi_5") ;U+06F5 EXTENDED ARABIC-INDIC DIGIT FIVE (cl-define-keysym #x10006f6 "Farsi_6") ;U+06F6 EXTENDED ARABIC-INDIC DIGIT SIX (cl-define-keysym #x10006f7 "Farsi_7") ;U+06F7 EXTENDED ARABIC-INDIC DIGIT SEVEN (cl-define-keysym #x10006f8 "Farsi_8") ;U+06F8 EXTENDED ARABIC-INDIC DIGIT EIGHT (cl-define-keysym #x10006f9 "Farsi_9") ;U+06F9 EXTENDED ARABIC-INDIC DIGIT NINE (cl-define-keysym #x100066a "Arabic_percent") ;U+066A ARABIC PERCENT SIGN (cl-define-keysym #x1000670 "Arabic_superscript_alef") ;U+0670 ARABIC LETTER SUPERSCRIPT ALEF (cl-define-keysym #x1000679 "Arabic_tteh") ;U+0679 ARABIC LETTER TTEH (cl-define-keysym #x100067e "Arabic_peh") ;U+067E ARABIC LETTER PEH (cl-define-keysym #x1000686 "Arabic_tcheh") ;U+0686 ARABIC LETTER TCHEH (cl-define-keysym #x1000688 "Arabic_ddal") ;U+0688 ARABIC LETTER DDAL (cl-define-keysym #x1000691 "Arabic_rreh") ;U+0691 ARABIC LETTER RREH (cl-define-keysym #x05ac "Arabic_comma") ;U+060C ARABIC COMMA (cl-define-keysym #x10006d4 "Arabic_fullstop") ;U+06D4 ARABIC FULL STOP (cl-define-keysym #x1000660 "Arabic_0") ;U+0660 ARABIC-INDIC DIGIT ZERO (cl-define-keysym #x1000661 "Arabic_1") ;U+0661 ARABIC-INDIC DIGIT ONE (cl-define-keysym #x1000662 "Arabic_2") ;U+0662 ARABIC-INDIC DIGIT TWO (cl-define-keysym #x1000663 "Arabic_3") ;U+0663 ARABIC-INDIC DIGIT THREE (cl-define-keysym #x1000664 "Arabic_4") ;U+0664 ARABIC-INDIC DIGIT FOUR (cl-define-keysym #x1000665 "Arabic_5") ;U+0665 ARABIC-INDIC DIGIT FIVE (cl-define-keysym #x1000666 "Arabic_6") ;U+0666 ARABIC-INDIC DIGIT SIX (cl-define-keysym #x1000667 "Arabic_7") ;U+0667 ARABIC-INDIC DIGIT SEVEN (cl-define-keysym #x1000668 "Arabic_8") ;U+0668 ARABIC-INDIC DIGIT EIGHT (cl-define-keysym #x1000669 "Arabic_9") ;U+0669 ARABIC-INDIC DIGIT NINE (cl-define-keysym #x05bb "Arabic_semicolon") ;U+061B ARABIC SEMICOLON (cl-define-keysym #x05bf "Arabic_question_mark") ;U+061F ARABIC QUESTION MARK (cl-define-keysym #x05c1 "Arabic_hamza") ;U+0621 ARABIC LETTER HAMZA (cl-define-keysym #x05c2 "Arabic_maddaonalef") ;U+0622 ARABIC LETTER ALEF WITH MADDA ABOVE (cl-define-keysym #x05c3 "Arabic_hamzaonalef") ;U+0623 ARABIC LETTER ALEF WITH HAMZA ABOVE (cl-define-keysym #x05c4 "Arabic_hamzaonwaw") ;U+0624 ARABIC LETTER WAW WITH HAMZA ABOVE (cl-define-keysym #x05c5 "Arabic_hamzaunderalef") ;U+0625 ARABIC LETTER ALEF WITH HAMZA BELOW (cl-define-keysym #x05c6 "Arabic_hamzaonyeh") ;U+0626 ARABIC LETTER YEH WITH HAMZA ABOVE (cl-define-keysym #x05c7 "Arabic_alef") ;U+0627 ARABIC LETTER ALEF (cl-define-keysym #x05c8 "Arabic_beh") ;U+0628 ARABIC LETTER BEH (cl-define-keysym #x05c9 "Arabic_tehmarbuta") ;U+0629 ARABIC LETTER TEH MARBUTA (cl-define-keysym #x05ca "Arabic_teh") ;U+062A ARABIC LETTER TEH (cl-define-keysym #x05cb "Arabic_theh") ;U+062B ARABIC LETTER THEH (cl-define-keysym #x05cc "Arabic_jeem") ;U+062C ARABIC LETTER JEEM (cl-define-keysym #x05cd "Arabic_hah") ;U+062D ARABIC LETTER HAH (cl-define-keysym #x05ce "Arabic_khah") ;U+062E ARABIC LETTER KHAH (cl-define-keysym #x05cf "Arabic_dal") ;U+062F ARABIC LETTER DAL (cl-define-keysym #x05d0 "Arabic_thal") ;U+0630 ARABIC LETTER THAL (cl-define-keysym #x05d1 "Arabic_ra") ;U+0631 ARABIC LETTER REH (cl-define-keysym #x05d2 "Arabic_zain") ;U+0632 ARABIC LETTER ZAIN (cl-define-keysym #x05d3 "Arabic_seen") ;U+0633 ARABIC LETTER SEEN (cl-define-keysym #x05d4 "Arabic_sheen") ;U+0634 ARABIC LETTER SHEEN (cl-define-keysym #x05d5 "Arabic_sad") ;U+0635 ARABIC LETTER SAD (cl-define-keysym #x05d6 "Arabic_dad") ;U+0636 ARABIC LETTER DAD (cl-define-keysym #x05d7 "Arabic_tah") ;U+0637 ARABIC LETTER TAH (cl-define-keysym #x05d8 "Arabic_zah") ;U+0638 ARABIC LETTER ZAH (cl-define-keysym #x05d9 "Arabic_ain") ;U+0639 ARABIC LETTER AIN (cl-define-keysym #x05da "Arabic_ghain") ;U+063A ARABIC LETTER GHAIN (cl-define-keysym #x05e0 "Arabic_tatweel") ;U+0640 ARABIC TATWEEL (cl-define-keysym #x05e1 "Arabic_feh") ;U+0641 ARABIC LETTER FEH (cl-define-keysym #x05e2 "Arabic_qaf") ;U+0642 ARABIC LETTER QAF (cl-define-keysym #x05e3 "Arabic_kaf") ;U+0643 ARABIC LETTER KAF (cl-define-keysym #x05e4 "Arabic_lam") ;U+0644 ARABIC LETTER LAM (cl-define-keysym #x05e5 "Arabic_meem") ;U+0645 ARABIC LETTER MEEM (cl-define-keysym #x05e6 "Arabic_noon") ;U+0646 ARABIC LETTER NOON (cl-define-keysym #x05e7 "Arabic_ha") ;U+0647 ARABIC LETTER HEH (cl-define-keysym #x05e7 "Arabic_heh") ;deprecated (cl-define-keysym #x05e8 "Arabic_waw") ;U+0648 ARABIC LETTER WAW (cl-define-keysym #x05e9 "Arabic_alefmaksura") ;U+0649 ARABIC LETTER ALEF MAKSURA (cl-define-keysym #x05ea "Arabic_yeh") ;U+064A ARABIC LETTER YEH (cl-define-keysym #x05eb "Arabic_fathatan") ;U+064B ARABIC FATHATAN (cl-define-keysym #x05ec "Arabic_dammatan") ;U+064C ARABIC DAMMATAN (cl-define-keysym #x05ed "Arabic_kasratan") ;U+064D ARABIC KASRATAN (cl-define-keysym #x05ee "Arabic_fatha") ;U+064E ARABIC FATHA (cl-define-keysym #x05ef "Arabic_damma") ;U+064F ARABIC DAMMA (cl-define-keysym #x05f0 "Arabic_kasra") ;U+0650 ARABIC KASRA (cl-define-keysym #x05f1 "Arabic_shadda") ;U+0651 ARABIC SHADDA (cl-define-keysym #x05f2 "Arabic_sukun") ;U+0652 ARABIC SUKUN (cl-define-keysym #x1000653 "Arabic_madda_above") ;U+0653 ARABIC MADDAH ABOVE (cl-define-keysym #x1000654 "Arabic_hamza_above") ;U+0654 ARABIC HAMZA ABOVE (cl-define-keysym #x1000655 "Arabic_hamza_below") ;U+0655 ARABIC HAMZA BELOW (cl-define-keysym #x1000698 "Arabic_jeh") ;U+0698 ARABIC LETTER JEH (cl-define-keysym #x10006a4 "Arabic_veh") ;U+06A4 ARABIC LETTER VEH (cl-define-keysym #x10006a9 "Arabic_keheh") ;U+06A9 ARABIC LETTER KEHEH (cl-define-keysym #x10006af "Arabic_gaf") ;U+06AF ARABIC LETTER GAF (cl-define-keysym #x10006ba "Arabic_noon_ghunna") ;U+06BA ARABIC LETTER NOON GHUNNA (cl-define-keysym #x10006be "Arabic_heh_doachashmee") ;U+06BE ARABIC LETTER HEH DOACHASHMEE (cl-define-keysym #x10006cc "Farsi_yeh") ;U+06CC ARABIC LETTER FARSI YEH (cl-define-keysym #x10006cc "Arabic_farsi_yeh") ;U+06CC ARABIC LETTER FARSI YEH (cl-define-keysym #x10006d2 "Arabic_yeh_baree") ;U+06D2 ARABIC LETTER YEH BARREE (cl-define-keysym #x10006c1 "Arabic_heh_goal") ;U+06C1 ARABIC LETTER HEH GOAL (cl-define-keysym #xff7e "Arabic_switch") ;Alias for mode_switch (cl-define-keysym #x1000492 "Cyrillic_GHE_bar") ;U+0492 CYRILLIC CAPITAL LETTER GHE WITH STROKE (cl-define-keysym #x1000493 "Cyrillic_ghe_bar") ;U+0493 CYRILLIC SMALL LETTER GHE WITH STROKE (cl-define-keysym #x1000496 "Cyrillic_ZHE_descender") ;U+0496 CYRILLIC CAPITAL LETTER ZHE WITH DESCENDER (cl-define-keysym #x1000497 "Cyrillic_zhe_descender") ;U+0497 CYRILLIC SMALL LETTER ZHE WITH DESCENDER (cl-define-keysym #x100049a "Cyrillic_KA_descender") ;U+049A CYRILLIC CAPITAL LETTER KA WITH DESCENDER (cl-define-keysym #x100049b "Cyrillic_ka_descender") ;U+049B CYRILLIC SMALL LETTER KA WITH DESCENDER (cl-define-keysym #x100049c "Cyrillic_KA_vertstroke") ;U+049C CYRILLIC CAPITAL LETTER KA WITH VERTICAL STROKE (cl-define-keysym #x100049d "Cyrillic_ka_vertstroke") ;U+049D CYRILLIC SMALL LETTER KA WITH VERTICAL STROKE (cl-define-keysym #x10004a2 "Cyrillic_EN_descender") ;U+04A2 CYRILLIC CAPITAL LETTER EN WITH DESCENDER (cl-define-keysym #x10004a3 "Cyrillic_en_descender") ;U+04A3 CYRILLIC SMALL LETTER EN WITH DESCENDER (cl-define-keysym #x10004ae "Cyrillic_U_straight") ;U+04AE CYRILLIC CAPITAL LETTER STRAIGHT U (cl-define-keysym #x10004af "Cyrillic_u_straight") ;U+04AF CYRILLIC SMALL LETTER STRAIGHT U (cl-define-keysym #x10004b0 "Cyrillic_U_straight_bar") ;U+04B0 CYRILLIC CAPITAL LETTER STRAIGHT U WITH STROKE (cl-define-keysym #x10004b1 "Cyrillic_u_straight_bar") ;U+04B1 CYRILLIC SMALL LETTER STRAIGHT U WITH STROKE (cl-define-keysym #x10004b2 "Cyrillic_HA_descender") ;U+04B2 CYRILLIC CAPITAL LETTER HA WITH DESCENDER (cl-define-keysym #x10004b3 "Cyrillic_ha_descender") ;U+04B3 CYRILLIC SMALL LETTER HA WITH DESCENDER (cl-define-keysym #x10004b6 "Cyrillic_CHE_descender") ;U+04B6 CYRILLIC CAPITAL LETTER CHE WITH DESCENDER (cl-define-keysym #x10004b7 "Cyrillic_che_descender") ;U+04B7 CYRILLIC SMALL LETTER CHE WITH DESCENDER (cl-define-keysym #x10004b8 "Cyrillic_CHE_vertstroke") ;U+04B8 CYRILLIC CAPITAL LETTER CHE WITH VERTICAL STROKE (cl-define-keysym #x10004b9 "Cyrillic_che_vertstroke") ;U+04B9 CYRILLIC SMALL LETTER CHE WITH VERTICAL STROKE (cl-define-keysym #x10004ba "Cyrillic_SHHA") ;U+04BA CYRILLIC CAPITAL LETTER SHHA (cl-define-keysym #x10004bb "Cyrillic_shha") ;U+04BB CYRILLIC SMALL LETTER SHHA (cl-define-keysym #x10004d8 "Cyrillic_SCHWA") ;U+04D8 CYRILLIC CAPITAL LETTER SCHWA (cl-define-keysym #x10004d9 "Cyrillic_schwa") ;U+04D9 CYRILLIC SMALL LETTER SCHWA (cl-define-keysym #x10004e2 "Cyrillic_I_macron") ;U+04E2 CYRILLIC CAPITAL LETTER I WITH MACRON (cl-define-keysym #x10004e3 "Cyrillic_i_macron") ;U+04E3 CYRILLIC SMALL LETTER I WITH MACRON (cl-define-keysym #x10004e8 "Cyrillic_O_bar") ;U+04E8 CYRILLIC CAPITAL LETTER BARRED O (cl-define-keysym #x10004e9 "Cyrillic_o_bar") ;U+04E9 CYRILLIC SMALL LETTER BARRED O (cl-define-keysym #x10004ee "Cyrillic_U_macron") ;U+04EE CYRILLIC CAPITAL LETTER U WITH MACRON (cl-define-keysym #x10004ef "Cyrillic_u_macron") ;U+04EF CYRILLIC SMALL LETTER U WITH MACRON (cl-define-keysym #x06a1 "Serbian_dje") ;U+0452 CYRILLIC SMALL LETTER DJE (cl-define-keysym #x06a2 "Macedonia_gje") ;U+0453 CYRILLIC SMALL LETTER GJE (cl-define-keysym #x06a3 "Cyrillic_io") ;U+0451 CYRILLIC SMALL LETTER IO (cl-define-keysym #x06a4 "Ukrainian_ie") ;U+0454 CYRILLIC SMALL LETTER UKRAINIAN IE (cl-define-keysym #x06a4 "Ukranian_je") ;deprecated (cl-define-keysym #x06a5 "Macedonia_dse") ;U+0455 CYRILLIC SMALL LETTER DZE (cl-define-keysym #x06a6 "Ukrainian_i") ;U+0456 CYRILLIC SMALL LETTER BYELORUSSIAN-UKRAINIAN I (cl-define-keysym #x06a6 "Ukranian_i") ;deprecated (cl-define-keysym #x06a7 "Ukrainian_yi") ;U+0457 CYRILLIC SMALL LETTER YI (cl-define-keysym #x06a7 "Ukranian_yi") ;deprecated (cl-define-keysym #x06a8 "Cyrillic_je") ;U+0458 CYRILLIC SMALL LETTER JE (cl-define-keysym #x06a8 "Serbian_je") ;deprecated (cl-define-keysym #x06a9 "Cyrillic_lje") ;U+0459 CYRILLIC SMALL LETTER LJE (cl-define-keysym #x06a9 "Serbian_lje") ;deprecated (cl-define-keysym #x06aa "Cyrillic_nje") ;U+045A CYRILLIC SMALL LETTER NJE (cl-define-keysym #x06aa "Serbian_nje") ;deprecated (cl-define-keysym #x06ab "Serbian_tshe") ;U+045B CYRILLIC SMALL LETTER TSHE (cl-define-keysym #x06ac "Macedonia_kje") ;U+045C CYRILLIC SMALL LETTER KJE (cl-define-keysym #x06ad "Ukrainian_ghe_with_upturn") ;U+0491 CYRILLIC SMALL LETTER GHE WITH UPTURN (cl-define-keysym #x06ae "Byelorussian_shortu") ;U+045E CYRILLIC SMALL LETTER SHORT U (cl-define-keysym #x06af "Cyrillic_dzhe") ;U+045F CYRILLIC SMALL LETTER DZHE (cl-define-keysym #x06af "Serbian_dze") ;deprecated (cl-define-keysym #x06b0 "numerosign") ;U+2116 NUMERO SIGN (cl-define-keysym #x06b1 "Serbian_DJE") ;U+0402 CYRILLIC CAPITAL LETTER DJE (cl-define-keysym #x06b2 "Macedonia_GJE") ;U+0403 CYRILLIC CAPITAL LETTER GJE (cl-define-keysym #x06b3 "Cyrillic_IO") ;U+0401 CYRILLIC CAPITAL LETTER IO (cl-define-keysym #x06b4 "Ukrainian_IE") ;U+0404 CYRILLIC CAPITAL LETTER UKRAINIAN IE (cl-define-keysym #x06b4 "Ukranian_JE") ;deprecated (cl-define-keysym #x06b5 "Macedonia_DSE") ;U+0405 CYRILLIC CAPITAL LETTER DZE (cl-define-keysym #x06b6 "Ukrainian_I") ;U+0406 CYRILLIC CAPITAL LETTER BYELORUSSIAN-UKRAINIAN I (cl-define-keysym #x06b6 "Ukranian_I") ;deprecated (cl-define-keysym #x06b7 "Ukrainian_YI") ;U+0407 CYRILLIC CAPITAL LETTER YI (cl-define-keysym #x06b7 "Ukranian_YI") ;deprecated (cl-define-keysym #x06b8 "Cyrillic_JE") ;U+0408 CYRILLIC CAPITAL LETTER JE (cl-define-keysym #x06b8 "Serbian_JE") ;deprecated (cl-define-keysym #x06b9 "Cyrillic_LJE") ;U+0409 CYRILLIC CAPITAL LETTER LJE (cl-define-keysym #x06b9 "Serbian_LJE") ;deprecated (cl-define-keysym #x06ba "Cyrillic_NJE") ;U+040A CYRILLIC CAPITAL LETTER NJE (cl-define-keysym #x06ba "Serbian_NJE") ;deprecated (cl-define-keysym #x06bb "Serbian_TSHE") ;U+040B CYRILLIC CAPITAL LETTER TSHE (cl-define-keysym #x06bc "Macedonia_KJE") ;U+040C CYRILLIC CAPITAL LETTER KJE (cl-define-keysym #x06bd "Ukrainian_GHE_WITH_UPTURN") ;U+0490 CYRILLIC CAPITAL LETTER GHE WITH UPTURN (cl-define-keysym #x06be "Byelorussian_SHORTU") ;U+040E CYRILLIC CAPITAL LETTER SHORT U (cl-define-keysym #x06bf "Cyrillic_DZHE") ;U+040F CYRILLIC CAPITAL LETTER DZHE (cl-define-keysym #x06bf "Serbian_DZE") ;deprecated (cl-define-keysym #x06c0 "Cyrillic_yu") ;U+044E CYRILLIC SMALL LETTER YU (cl-define-keysym #x06c1 "Cyrillic_a") ;U+0430 CYRILLIC SMALL LETTER A (cl-define-keysym #x06c2 "Cyrillic_be") ;U+0431 CYRILLIC SMALL LETTER BE (cl-define-keysym #x06c3 "Cyrillic_tse") ;U+0446 CYRILLIC SMALL LETTER TSE (cl-define-keysym #x06c4 "Cyrillic_de") ;U+0434 CYRILLIC SMALL LETTER DE (cl-define-keysym #x06c5 "Cyrillic_ie") ;U+0435 CYRILLIC SMALL LETTER IE (cl-define-keysym #x06c6 "Cyrillic_ef") ;U+0444 CYRILLIC SMALL LETTER EF (cl-define-keysym #x06c7 "Cyrillic_ghe") ;U+0433 CYRILLIC SMALL LETTER GHE (cl-define-keysym #x06c8 "Cyrillic_ha") ;U+0445 CYRILLIC SMALL LETTER HA (cl-define-keysym #x06c9 "Cyrillic_i") ;U+0438 CYRILLIC SMALL LETTER I (cl-define-keysym #x06ca "Cyrillic_shorti") ;U+0439 CYRILLIC SMALL LETTER SHORT I (cl-define-keysym #x06cb "Cyrillic_ka") ;U+043A CYRILLIC SMALL LETTER KA (cl-define-keysym #x06cc "Cyrillic_el") ;U+043B CYRILLIC SMALL LETTER EL (cl-define-keysym #x06cd "Cyrillic_em") ;U+043C CYRILLIC SMALL LETTER EM (cl-define-keysym #x06ce "Cyrillic_en") ;U+043D CYRILLIC SMALL LETTER EN (cl-define-keysym #x06cf "Cyrillic_o") ;U+043E CYRILLIC SMALL LETTER O (cl-define-keysym #x06d0 "Cyrillic_pe") ;U+043F CYRILLIC SMALL LETTER PE (cl-define-keysym #x06d1 "Cyrillic_ya") ;U+044F CYRILLIC SMALL LETTER YA (cl-define-keysym #x06d2 "Cyrillic_er") ;U+0440 CYRILLIC SMALL LETTER ER (cl-define-keysym #x06d3 "Cyrillic_es") ;U+0441 CYRILLIC SMALL LETTER ES (cl-define-keysym #x06d4 "Cyrillic_te") ;U+0442 CYRILLIC SMALL LETTER TE (cl-define-keysym #x06d5 "Cyrillic_u") ;U+0443 CYRILLIC SMALL LETTER U (cl-define-keysym #x06d6 "Cyrillic_zhe") ;U+0436 CYRILLIC SMALL LETTER ZHE (cl-define-keysym #x06d7 "Cyrillic_ve") ;U+0432 CYRILLIC SMALL LETTER VE (cl-define-keysym #x06d8 "Cyrillic_softsign") ;U+044C CYRILLIC SMALL LETTER SOFT SIGN (cl-define-keysym #x06d9 "Cyrillic_yeru") ;U+044B CYRILLIC SMALL LETTER YERU (cl-define-keysym #x06da "Cyrillic_ze") ;U+0437 CYRILLIC SMALL LETTER ZE (cl-define-keysym #x06db "Cyrillic_sha") ;U+0448 CYRILLIC SMALL LETTER SHA (cl-define-keysym #x06dc "Cyrillic_e") ;U+044D CYRILLIC SMALL LETTER E (cl-define-keysym #x06dd "Cyrillic_shcha") ;U+0449 CYRILLIC SMALL LETTER SHCHA (cl-define-keysym #x06de "Cyrillic_che") ;U+0447 CYRILLIC SMALL LETTER CHE (cl-define-keysym #x06df "Cyrillic_hardsign") ;U+044A CYRILLIC SMALL LETTER HARD SIGN (cl-define-keysym #x06e0 "Cyrillic_YU") ;U+042E CYRILLIC CAPITAL LETTER YU (cl-define-keysym #x06e1 "Cyrillic_A") ;U+0410 CYRILLIC CAPITAL LETTER A (cl-define-keysym #x06e2 "Cyrillic_BE") ;U+0411 CYRILLIC CAPITAL LETTER BE (cl-define-keysym #x06e3 "Cyrillic_TSE") ;U+0426 CYRILLIC CAPITAL LETTER TSE (cl-define-keysym #x06e4 "Cyrillic_DE") ;U+0414 CYRILLIC CAPITAL LETTER DE (cl-define-keysym #x06e5 "Cyrillic_IE") ;U+0415 CYRILLIC CAPITAL LETTER IE (cl-define-keysym #x06e6 "Cyrillic_EF") ;U+0424 CYRILLIC CAPITAL LETTER EF (cl-define-keysym #x06e7 "Cyrillic_GHE") ;U+0413 CYRILLIC CAPITAL LETTER GHE (cl-define-keysym #x06e8 "Cyrillic_HA") ;U+0425 CYRILLIC CAPITAL LETTER HA (cl-define-keysym #x06e9 "Cyrillic_I") ;U+0418 CYRILLIC CAPITAL LETTER I (cl-define-keysym #x06ea "Cyrillic_SHORTI") ;U+0419 CYRILLIC CAPITAL LETTER SHORT I (cl-define-keysym #x06eb "Cyrillic_KA") ;U+041A CYRILLIC CAPITAL LETTER KA (cl-define-keysym #x06ec "Cyrillic_EL") ;U+041B CYRILLIC CAPITAL LETTER EL (cl-define-keysym #x06ed "Cyrillic_EM") ;U+041C CYRILLIC CAPITAL LETTER EM (cl-define-keysym #x06ee "Cyrillic_EN") ;U+041D CYRILLIC CAPITAL LETTER EN (cl-define-keysym #x06ef "Cyrillic_O") ;U+041E CYRILLIC CAPITAL LETTER O (cl-define-keysym #x06f0 "Cyrillic_PE") ;U+041F CYRILLIC CAPITAL LETTER PE (cl-define-keysym #x06f1 "Cyrillic_YA") ;U+042F CYRILLIC CAPITAL LETTER YA (cl-define-keysym #x06f2 "Cyrillic_ER") ;U+0420 CYRILLIC CAPITAL LETTER ER (cl-define-keysym #x06f3 "Cyrillic_ES") ;U+0421 CYRILLIC CAPITAL LETTER ES (cl-define-keysym #x06f4 "Cyrillic_TE") ;U+0422 CYRILLIC CAPITAL LETTER TE (cl-define-keysym #x06f5 "Cyrillic_U") ;U+0423 CYRILLIC CAPITAL LETTER U (cl-define-keysym #x06f6 "Cyrillic_ZHE") ;U+0416 CYRILLIC CAPITAL LETTER ZHE (cl-define-keysym #x06f7 "Cyrillic_VE") ;U+0412 CYRILLIC CAPITAL LETTER VE (cl-define-keysym #x06f8 "Cyrillic_SOFTSIGN") ;U+042C CYRILLIC CAPITAL LETTER SOFT SIGN (cl-define-keysym #x06f9 "Cyrillic_YERU") ;U+042B CYRILLIC CAPITAL LETTER YERU (cl-define-keysym #x06fa "Cyrillic_ZE") ;U+0417 CYRILLIC CAPITAL LETTER ZE (cl-define-keysym #x06fb "Cyrillic_SHA") ;U+0428 CYRILLIC CAPITAL LETTER SHA (cl-define-keysym #x06fc "Cyrillic_E") ;U+042D CYRILLIC CAPITAL LETTER E (cl-define-keysym #x06fd "Cyrillic_SHCHA") ;U+0429 CYRILLIC CAPITAL LETTER SHCHA (cl-define-keysym #x06fe "Cyrillic_CHE") ;U+0427 CYRILLIC CAPITAL LETTER CHE (cl-define-keysym #x06ff "Cyrillic_HARDSIGN") ;U+042A CYRILLIC CAPITAL LETTER HARD SIGN (cl-define-keysym #x07a1 "Greek_ALPHAaccent") ;U+0386 GREEK CAPITAL LETTER ALPHA WITH TONOS (cl-define-keysym #x07a2 "Greek_EPSILONaccent") ;U+0388 GREEK CAPITAL LETTER EPSILON WITH TONOS (cl-define-keysym #x07a3 "Greek_ETAaccent") ;U+0389 GREEK CAPITAL LETTER ETA WITH TONOS (cl-define-keysym #x07a4 "Greek_IOTAaccent") ;U+038A GREEK CAPITAL LETTER IOTA WITH TONOS (cl-define-keysym #x07a5 "Greek_IOTAdieresis") ;U+03AA GREEK CAPITAL LETTER IOTA WITH DIALYTIKA (cl-define-keysym #x07a5 "Greek_IOTAdiaeresis") ;old typo (cl-define-keysym #x07a7 "Greek_OMICRONaccent") ;U+038C GREEK CAPITAL LETTER OMICRON WITH TONOS (cl-define-keysym #x07a8 "Greek_UPSILONaccent") ;U+038E GREEK CAPITAL LETTER UPSILON WITH TONOS (cl-define-keysym #x07a9 "Greek_UPSILONdieresis") ;U+03AB GREEK CAPITAL LETTER UPSILON WITH DIALYTIKA (cl-define-keysym #x07ab "Greek_OMEGAaccent") ;U+038F GREEK CAPITAL LETTER OMEGA WITH TONOS (cl-define-keysym #x07ae "Greek_accentdieresis") ;U+0385 GREEK DIALYTIKA TONOS (cl-define-keysym #x07af "Greek_horizbar") ;U+2015 HORIZONTAL BAR (cl-define-keysym #x07b1 "Greek_alphaaccent") ;U+03AC GREEK SMALL LETTER ALPHA WITH TONOS (cl-define-keysym #x07b2 "Greek_epsilonaccent") ;U+03AD GREEK SMALL LETTER EPSILON WITH TONOS (cl-define-keysym #x07b3 "Greek_etaaccent") ;U+03AE GREEK SMALL LETTER ETA WITH TONOS (cl-define-keysym #x07b4 "Greek_iotaaccent") ;U+03AF GREEK SMALL LETTER IOTA WITH TONOS (cl-define-keysym #x07b5 "Greek_iotadieresis") ;U+03CA GREEK SMALL LETTER IOTA WITH DIALYTIKA (cl-define-keysym #x07b6 "Greek_iotaaccentdieresis") ;U+0390 GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS (cl-define-keysym #x07b7 "Greek_omicronaccent") ;U+03CC GREEK SMALL LETTER OMICRON WITH TONOS (cl-define-keysym #x07b8 "Greek_upsilonaccent") ;U+03CD GREEK SMALL LETTER UPSILON WITH TONOS (cl-define-keysym #x07b9 "Greek_upsilondieresis") ;U+03CB GREEK SMALL LETTER UPSILON WITH DIALYTIKA (cl-define-keysym #x07ba "Greek_upsilonaccentdieresis") ;U+03B0 GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS (cl-define-keysym #x07bb "Greek_omegaaccent") ;U+03CE GREEK SMALL LETTER OMEGA WITH TONOS (cl-define-keysym #x07c1 "Greek_ALPHA") ;U+0391 GREEK CAPITAL LETTER ALPHA (cl-define-keysym #x07c2 "Greek_BETA") ;U+0392 GREEK CAPITAL LETTER BETA (cl-define-keysym #x07c3 "Greek_GAMMA") ;U+0393 GREEK CAPITAL LETTER GAMMA (cl-define-keysym #x07c4 "Greek_DELTA") ;U+0394 GREEK CAPITAL LETTER DELTA (cl-define-keysym #x07c5 "Greek_EPSILON") ;U+0395 GREEK CAPITAL LETTER EPSILON (cl-define-keysym #x07c6 "Greek_ZETA") ;U+0396 GREEK CAPITAL LETTER ZETA (cl-define-keysym #x07c7 "Greek_ETA") ;U+0397 GREEK CAPITAL LETTER ETA (cl-define-keysym #x07c8 "Greek_THETA") ;U+0398 GREEK CAPITAL LETTER THETA (cl-define-keysym #x07c9 "Greek_IOTA") ;U+0399 GREEK CAPITAL LETTER IOTA (cl-define-keysym #x07ca "Greek_KAPPA") ;U+039A GREEK CAPITAL LETTER KAPPA (cl-define-keysym #x07cb "Greek_LAMDA") ;U+039B GREEK CAPITAL LETTER LAMDA (cl-define-keysym #x07cb "Greek_LAMBDA") ;U+039B GREEK CAPITAL LETTER LAMDA (cl-define-keysym #x07cc "Greek_MU") ;U+039C GREEK CAPITAL LETTER MU (cl-define-keysym #x07cd "Greek_NU") ;U+039D GREEK CAPITAL LETTER NU (cl-define-keysym #x07ce "Greek_XI") ;U+039E GREEK CAPITAL LETTER XI (cl-define-keysym #x07cf "Greek_OMICRON") ;U+039F GREEK CAPITAL LETTER OMICRON (cl-define-keysym #x07d0 "Greek_PI") ;U+03A0 GREEK CAPITAL LETTER PI (cl-define-keysym #x07d1 "Greek_RHO") ;U+03A1 GREEK CAPITAL LETTER RHO (cl-define-keysym #x07d2 "Greek_SIGMA") ;U+03A3 GREEK CAPITAL LETTER SIGMA (cl-define-keysym #x07d4 "Greek_TAU") ;U+03A4 GREEK CAPITAL LETTER TAU (cl-define-keysym #x07d5 "Greek_UPSILON") ;U+03A5 GREEK CAPITAL LETTER UPSILON (cl-define-keysym #x07d6 "Greek_PHI") ;U+03A6 GREEK CAPITAL LETTER PHI (cl-define-keysym #x07d7 "Greek_CHI") ;U+03A7 GREEK CAPITAL LETTER CHI (cl-define-keysym #x07d8 "Greek_PSI") ;U+03A8 GREEK CAPITAL LETTER PSI (cl-define-keysym #x07d9 "Greek_OMEGA") ;U+03A9 GREEK CAPITAL LETTER OMEGA (cl-define-keysym #x07e1 "Greek_alpha") ;U+03B1 GREEK SMALL LETTER ALPHA (cl-define-keysym #x07e2 "Greek_beta") ;U+03B2 GREEK SMALL LETTER BETA (cl-define-keysym #x07e3 "Greek_gamma") ;U+03B3 GREEK SMALL LETTER GAMMA (cl-define-keysym #x07e4 "Greek_delta") ;U+03B4 GREEK SMALL LETTER DELTA (cl-define-keysym #x07e5 "Greek_epsilon") ;U+03B5 GREEK SMALL LETTER EPSILON (cl-define-keysym #x07e6 "Greek_zeta") ;U+03B6 GREEK SMALL LETTER ZETA (cl-define-keysym #x07e7 "Greek_eta") ;U+03B7 GREEK SMALL LETTER ETA (cl-define-keysym #x07e8 "Greek_theta") ;U+03B8 GREEK SMALL LETTER THETA (cl-define-keysym #x07e9 "Greek_iota") ;U+03B9 GREEK SMALL LETTER IOTA (cl-define-keysym #x07ea "Greek_kappa") ;U+03BA GREEK SMALL LETTER KAPPA (cl-define-keysym #x07eb "Greek_lamda") ;U+03BB GREEK SMALL LETTER LAMDA (cl-define-keysym #x07eb "Greek_lambda") ;U+03BB GREEK SMALL LETTER LAMDA (cl-define-keysym #x07ec "Greek_mu") ;U+03BC GREEK SMALL LETTER MU (cl-define-keysym #x07ed "Greek_nu") ;U+03BD GREEK SMALL LETTER NU (cl-define-keysym #x07ee "Greek_xi") ;U+03BE GREEK SMALL LETTER XI (cl-define-keysym #x07ef "Greek_omicron") ;U+03BF GREEK SMALL LETTER OMICRON (cl-define-keysym #x07f0 "Greek_pi") ;U+03C0 GREEK SMALL LETTER PI (cl-define-keysym #x07f1 "Greek_rho") ;U+03C1 GREEK SMALL LETTER RHO (cl-define-keysym #x07f2 "Greek_sigma") ;U+03C3 GREEK SMALL LETTER SIGMA (cl-define-keysym #x07f3 "Greek_finalsmallsigma") ;U+03C2 GREEK SMALL LETTER FINAL SIGMA (cl-define-keysym #x07f4 "Greek_tau") ;U+03C4 GREEK SMALL LETTER TAU (cl-define-keysym #x07f5 "Greek_upsilon") ;U+03C5 GREEK SMALL LETTER UPSILON (cl-define-keysym #x07f6 "Greek_phi") ;U+03C6 GREEK SMALL LETTER PHI (cl-define-keysym #x07f7 "Greek_chi") ;U+03C7 GREEK SMALL LETTER CHI (cl-define-keysym #x07f8 "Greek_psi") ;U+03C8 GREEK SMALL LETTER PSI (cl-define-keysym #x07f9 "Greek_omega") ;U+03C9 GREEK SMALL LETTER OMEGA (cl-define-keysym #xff7e "Greek_switch") ;Alias for mode_switch (cl-define-keysym #x08a1 "leftradical") ;U+23B7 RADICAL SYMBOL BOTTOM (cl-define-keysym #x08a2 "topleftradical") ;(U+250C BOX DRAWINGS LIGHT DOWN AND RIGHT) (cl-define-keysym #x08a3 "horizconnector") ;(U+2500 BOX DRAWINGS LIGHT HORIZONTAL) (cl-define-keysym #x08a4 "topintegral") ;U+2320 TOP HALF INTEGRAL (cl-define-keysym #x08a5 "botintegral") ;U+2321 BOTTOM HALF INTEGRAL (cl-define-keysym #x08a6 "vertconnector") ;(U+2502 BOX DRAWINGS LIGHT VERTICAL) (cl-define-keysym #x08a7 "topleftsqbracket") ;U+23A1 LEFT SQUARE BRACKET UPPER CORNER (cl-define-keysym #x08a8 "botleftsqbracket") ;U+23A3 LEFT SQUARE BRACKET LOWER CORNER (cl-define-keysym #x08a9 "toprightsqbracket") ;U+23A4 RIGHT SQUARE BRACKET UPPER CORNER (cl-define-keysym #x08aa "botrightsqbracket") ;U+23A6 RIGHT SQUARE BRACKET LOWER CORNER (cl-define-keysym #x08ab "topleftparens") ;U+239B LEFT PARENTHESIS UPPER HOOK (cl-define-keysym #x08ac "botleftparens") ;U+239D LEFT PARENTHESIS LOWER HOOK (cl-define-keysym #x08ad "toprightparens") ;U+239E RIGHT PARENTHESIS UPPER HOOK (cl-define-keysym #x08ae "botrightparens") ;U+23A0 RIGHT PARENTHESIS LOWER HOOK (cl-define-keysym #x08af "leftmiddlecurlybrace") ;U+23A8 LEFT CURLY BRACKET MIDDLE PIECE (cl-define-keysym #x08b0 "rightmiddlecurlybrace") ;U+23AC RIGHT CURLY BRACKET MIDDLE PIECE (cl-define-keysym #x08b1 "topleftsummation") (cl-define-keysym #x08b2 "botleftsummation") (cl-define-keysym #x08b3 "topvertsummationconnector") (cl-define-keysym #x08b4 "botvertsummationconnector") (cl-define-keysym #x08b5 "toprightsummation") (cl-define-keysym #x08b6 "botrightsummation") (cl-define-keysym #x08b7 "rightmiddlesummation") (cl-define-keysym #x08bc "lessthanequal") ;U+2264 LESS-THAN OR EQUAL TO (cl-define-keysym #x08bd "notequal") ;U+2260 NOT EQUAL TO (cl-define-keysym #x08be "greaterthanequal") ;U+2265 GREATER-THAN OR EQUAL TO (cl-define-keysym #x08bf "integral") ;U+222B INTEGRAL (cl-define-keysym #x08c0 "therefore") ;U+2234 THEREFORE (cl-define-keysym #x08c1 "variation") ;U+221D PROPORTIONAL TO (cl-define-keysym #x08c2 "infinity") ;U+221E INFINITY (cl-define-keysym #x08c5 "nabla") ;U+2207 NABLA (cl-define-keysym #x08c8 "approximate") ;U+223C TILDE OPERATOR (cl-define-keysym #x08c9 "similarequal") ;U+2243 ASYMPTOTICALLY EQUAL TO (cl-define-keysym #x08cd "ifonlyif") ;U+21D4 LEFT RIGHT DOUBLE ARROW (cl-define-keysym #x08ce "implies") ;U+21D2 RIGHTWARDS DOUBLE ARROW (cl-define-keysym #x08cf "identical") ;U+2261 IDENTICAL TO (cl-define-keysym #x08d6 "radical") ;U+221A SQUARE ROOT (cl-define-keysym #x08da "includedin") ;U+2282 SUBSET OF (cl-define-keysym #x08db "includes") ;U+2283 SUPERSET OF (cl-define-keysym #x08dc "intersection") ;U+2229 INTERSECTION (cl-define-keysym #x08dd "union") ;U+222A UNION (cl-define-keysym #x08de "logicaland") ;U+2227 LOGICAL AND (cl-define-keysym #x08df "logicalor") ;U+2228 LOGICAL OR (cl-define-keysym #x08ef "partialderivative") ;U+2202 PARTIAL DIFFERENTIAL (cl-define-keysym #x08f6 "function") ;U+0192 LATIN SMALL LETTER F WITH HOOK (cl-define-keysym #x08fb "leftarrow") ;U+2190 LEFTWARDS ARROW (cl-define-keysym #x08fc "uparrow") ;U+2191 UPWARDS ARROW (cl-define-keysym #x08fd "rightarrow") ;U+2192 RIGHTWARDS ARROW (cl-define-keysym #x08fe "downarrow") ;U+2193 DOWNWARDS ARROW (cl-define-keysym #x09df "blank") (cl-define-keysym #x09e0 "soliddiamond") ;U+25C6 BLACK DIAMOND (cl-define-keysym #x09e1 "checkerboard") ;U+2592 MEDIUM SHADE (cl-define-keysym #x09e2 "ht") ;U+2409 SYMBOL FOR HORIZONTAL TABULATION (cl-define-keysym #x09e3 "ff") ;U+240C SYMBOL FOR FORM FEED (cl-define-keysym #x09e4 "cr") ;U+240D SYMBOL FOR CARRIAGE RETURN (cl-define-keysym #x09e5 "lf") ;U+240A SYMBOL FOR LINE FEED (cl-define-keysym #x09e8 "nl") ;U+2424 SYMBOL FOR NEWLINE (cl-define-keysym #x09e9 "vt") ;U+240B SYMBOL FOR VERTICAL TABULATION (cl-define-keysym #x09ea "lowrightcorner") ;U+2518 BOX DRAWINGS LIGHT UP AND LEFT (cl-define-keysym #x09eb "uprightcorner") ;U+2510 BOX DRAWINGS LIGHT DOWN AND LEFT (cl-define-keysym #x09ec "upleftcorner") ;U+250C BOX DRAWINGS LIGHT DOWN AND RIGHT (cl-define-keysym #x09ed "lowleftcorner") ;U+2514 BOX DRAWINGS LIGHT UP AND RIGHT (cl-define-keysym #x09ee "crossinglines") ;U+253C BOX DRAWINGS LIGHT VERTICAL AND HORIZONTAL (cl-define-keysym #x09ef "horizlinescan1") ;U+23BA HORIZONTAL SCAN LINE-1 (cl-define-keysym #x09f0 "horizlinescan3") ;U+23BB HORIZONTAL SCAN LINE-3 (cl-define-keysym #x09f1 "horizlinescan5") ;U+2500 BOX DRAWINGS LIGHT HORIZONTAL (cl-define-keysym #x09f2 "horizlinescan7") ;U+23BC HORIZONTAL SCAN LINE-7 (cl-define-keysym #x09f3 "horizlinescan9") ;U+23BD HORIZONTAL SCAN LINE-9 (cl-define-keysym #x09f4 "leftt") ;U+251C BOX DRAWINGS LIGHT VERTICAL AND RIGHT (cl-define-keysym #x09f5 "rightt") ;U+2524 BOX DRAWINGS LIGHT VERTICAL AND LEFT (cl-define-keysym #x09f6 "bott") ;U+2534 BOX DRAWINGS LIGHT UP AND HORIZONTAL (cl-define-keysym #x09f7 "topt") ;U+252C BOX DRAWINGS LIGHT DOWN AND HORIZONTAL (cl-define-keysym #x09f8 "vertbar") ;U+2502 BOX DRAWINGS LIGHT VERTICAL (cl-define-keysym #x0aa1 "emspace") ;U+2003 EM SPACE (cl-define-keysym #x0aa2 "enspace") ;U+2002 EN SPACE (cl-define-keysym #x0aa3 "em3space") ;U+2004 THREE-PER-EM SPACE (cl-define-keysym #x0aa4 "em4space") ;U+2005 FOUR-PER-EM SPACE (cl-define-keysym #x0aa5 "digitspace") ;U+2007 FIGURE SPACE (cl-define-keysym #x0aa6 "punctspace") ;U+2008 PUNCTUATION SPACE (cl-define-keysym #x0aa7 "thinspace") ;U+2009 THIN SPACE (cl-define-keysym #x0aa8 "hairspace") ;U+200A HAIR SPACE (cl-define-keysym #x0aa9 "emdash") ;U+2014 EM DASH (cl-define-keysym #x0aaa "endash") ;U+2013 EN DASH (cl-define-keysym #x0aac "signifblank") ;(U+2423 OPEN BOX) (cl-define-keysym #x0aae "ellipsis") ;U+2026 HORIZONTAL ELLIPSIS (cl-define-keysym #x0aaf "doubbaselinedot") ;U+2025 TWO DOT LEADER (cl-define-keysym #x0ab0 "onethird") ;U+2153 VULGAR FRACTION ONE THIRD (cl-define-keysym #x0ab1 "twothirds") ;U+2154 VULGAR FRACTION TWO THIRDS (cl-define-keysym #x0ab2 "onefifth") ;U+2155 VULGAR FRACTION ONE FIFTH (cl-define-keysym #x0ab3 "twofifths") ;U+2156 VULGAR FRACTION TWO FIFTHS (cl-define-keysym #x0ab4 "threefifths") ;U+2157 VULGAR FRACTION THREE FIFTHS (cl-define-keysym #x0ab5 "fourfifths") ;U+2158 VULGAR FRACTION FOUR FIFTHS (cl-define-keysym #x0ab6 "onesixth") ;U+2159 VULGAR FRACTION ONE SIXTH (cl-define-keysym #x0ab7 "fivesixths") ;U+215A VULGAR FRACTION FIVE SIXTHS (cl-define-keysym #x0ab8 "careof") ;U+2105 CARE OF (cl-define-keysym #x0abb "figdash") ;U+2012 FIGURE DASH (cl-define-keysym #x0abc "leftanglebracket") ;(U+27E8 MATHEMATICAL LEFT ANGLE BRACKET) (cl-define-keysym #x0abd "decimalpoint") ;(U+002E FULL STOP) (cl-define-keysym #x0abe "rightanglebracket") ;(U+27E9 MATHEMATICAL RIGHT ANGLE BRACKET) (cl-define-keysym #x0abf "marker") (cl-define-keysym #x0ac3 "oneeighth") ;U+215B VULGAR FRACTION ONE EIGHTH (cl-define-keysym #x0ac4 "threeeighths") ;U+215C VULGAR FRACTION THREE EIGHTHS (cl-define-keysym #x0ac5 "fiveeighths") ;U+215D VULGAR FRACTION FIVE EIGHTHS (cl-define-keysym #x0ac6 "seveneighths") ;U+215E VULGAR FRACTION SEVEN EIGHTHS (cl-define-keysym #x0ac9 "trademark") ;U+2122 TRADE MARK SIGN (cl-define-keysym #x0aca "signaturemark") ;(U+2613 SALTIRE) (cl-define-keysym #x0acb "trademarkincircle") (cl-define-keysym #x0acc "leftopentriangle") ;(U+25C1 WHITE LEFT-POINTING TRIANGLE) (cl-define-keysym #x0acd "rightopentriangle") ;(U+25B7 WHITE RIGHT-POINTING TRIANGLE) (cl-define-keysym #x0ace "emopencircle") ;(U+25CB WHITE CIRCLE) (cl-define-keysym #x0acf "emopenrectangle") ;(U+25AF WHITE VERTICAL RECTANGLE) (cl-define-keysym #x0ad0 "leftsinglequotemark") ;U+2018 LEFT SINGLE QUOTATION MARK (cl-define-keysym #x0ad1 "rightsinglequotemark") ;U+2019 RIGHT SINGLE QUOTATION MARK (cl-define-keysym #x0ad2 "leftdoublequotemark") ;U+201C LEFT DOUBLE QUOTATION MARK (cl-define-keysym #x0ad3 "rightdoublequotemark") ;U+201D RIGHT DOUBLE QUOTATION MARK (cl-define-keysym #x0ad4 "prescription") ;U+211E PRESCRIPTION TAKE (cl-define-keysym #x0ad6 "minutes") ;U+2032 PRIME (cl-define-keysym #x0ad7 "seconds") ;U+2033 DOUBLE PRIME (cl-define-keysym #x0ad9 "latincross") ;U+271D LATIN CROSS (cl-define-keysym #x0ada "hexagram") (cl-define-keysym #x0adb "filledrectbullet") ;(U+25AC BLACK RECTANGLE) (cl-define-keysym #x0adc "filledlefttribullet") ;(U+25C0 BLACK LEFT-POINTING TRIANGLE) (cl-define-keysym #x0add "filledrighttribullet") ;(U+25B6 BLACK RIGHT-POINTING TRIANGLE) (cl-define-keysym #x0ade "emfilledcircle") ;(U+25CF BLACK CIRCLE) (cl-define-keysym #x0adf "emfilledrect") ;(U+25AE BLACK VERTICAL RECTANGLE) (cl-define-keysym #x0ae0 "enopencircbullet") ;(U+25E6 WHITE BULLET) (cl-define-keysym #x0ae1 "enopensquarebullet") ;(U+25AB WHITE SMALL SQUARE) (cl-define-keysym #x0ae2 "openrectbullet") ;(U+25AD WHITE RECTANGLE) (cl-define-keysym #x0ae3 "opentribulletup") ;(U+25B3 WHITE UP-POINTING TRIANGLE) (cl-define-keysym #x0ae4 "opentribulletdown") ;(U+25BD WHITE DOWN-POINTING TRIANGLE) (cl-define-keysym #x0ae5 "openstar") ;(U+2606 WHITE STAR) (cl-define-keysym #x0ae6 "enfilledcircbullet") ;(U+2022 BULLET) (cl-define-keysym #x0ae7 "enfilledsqbullet") ;(U+25AA BLACK SMALL SQUARE) (cl-define-keysym #x0ae8 "filledtribulletup") ;(U+25B2 BLACK UP-POINTING TRIANGLE) (cl-define-keysym #x0ae9 "filledtribulletdown") ;(U+25BC BLACK DOWN-POINTING TRIANGLE) (cl-define-keysym #x0aea "leftpointer") ;(U+261C WHITE LEFT POINTING INDEX) (cl-define-keysym #x0aeb "rightpointer") ;(U+261E WHITE RIGHT POINTING INDEX) (cl-define-keysym #x0aec "club") ;U+2663 BLACK CLUB SUIT (cl-define-keysym #x0aed "diamond") ;U+2666 BLACK DIAMOND SUIT (cl-define-keysym #x0aee "heart") ;U+2665 BLACK HEART SUIT (cl-define-keysym #x0af0 "maltesecross") ;U+2720 MALTESE CROSS (cl-define-keysym #x0af1 "dagger") ;U+2020 DAGGER (cl-define-keysym #x0af2 "doubledagger") ;U+2021 DOUBLE DAGGER (cl-define-keysym #x0af3 "checkmark") ;U+2713 CHECK MARK (cl-define-keysym #x0af4 "ballotcross") ;U+2717 BALLOT X (cl-define-keysym #x0af5 "musicalsharp") ;U+266F MUSIC SHARP SIGN (cl-define-keysym #x0af6 "musicalflat") ;U+266D MUSIC FLAT SIGN (cl-define-keysym #x0af7 "malesymbol") ;U+2642 MALE SIGN (cl-define-keysym #x0af8 "femalesymbol") ;U+2640 FEMALE SIGN (cl-define-keysym #x0af9 "telephone") ;U+260E BLACK TELEPHONE (cl-define-keysym #x0afa "telephonerecorder") ;U+2315 TELEPHONE RECORDER (cl-define-keysym #x0afb "phonographcopyright") ;U+2117 SOUND RECORDING COPYRIGHT (cl-define-keysym #x0afc "caret") ;U+2038 CARET (cl-define-keysym #x0afd "singlelowquotemark") ;U+201A SINGLE LOW-9 QUOTATION MARK (cl-define-keysym #x0afe "doublelowquotemark") ;U+201E DOUBLE LOW-9 QUOTATION MARK (cl-define-keysym #x0aff "cursor") (cl-define-keysym #x0ba3 "leftcaret") ;(U+003C LESS-THAN SIGN) (cl-define-keysym #x0ba6 "rightcaret") ;(U+003E GREATER-THAN SIGN) (cl-define-keysym #x0ba8 "downcaret") ;(U+2228 LOGICAL OR) (cl-define-keysym #x0ba9 "upcaret") ;(U+2227 LOGICAL AND) (cl-define-keysym #x0bc0 "overbar") ;(U+00AF MACRON) (cl-define-keysym #x0bc2 "downtack") ;U+22A5 UP TACK (cl-define-keysym #x0bc3 "upshoe") ;(U+2229 INTERSECTION) (cl-define-keysym #x0bc4 "downstile") ;U+230A LEFT FLOOR (cl-define-keysym #x0bc6 "underbar") ;(U+005F LOW LINE) (cl-define-keysym #x0bca "jot") ;U+2218 RING OPERATOR (cl-define-keysym #x0bcc "quad") ;U+2395 APL FUNCTIONAL SYMBOL QUAD (cl-define-keysym #x0bce "uptack") ;U+22A4 DOWN TACK (cl-define-keysym #x0bcf "circle") ;U+25CB WHITE CIRCLE (cl-define-keysym #x0bd3 "upstile") ;U+2308 LEFT CEILING (cl-define-keysym #x0bd6 "downshoe") ;(U+222A UNION) (cl-define-keysym #x0bd8 "rightshoe") ;(U+2283 SUPERSET OF) (cl-define-keysym #x0bda "leftshoe") ;(U+2282 SUBSET OF) (cl-define-keysym #x0bdc "lefttack") ;U+22A2 RIGHT TACK (cl-define-keysym #x0bfc "righttack") ;U+22A3 LEFT TACK (cl-define-keysym #x0cdf "hebrew_doublelowline") ;U+2017 DOUBLE LOW LINE (cl-define-keysym #x0ce0 "hebrew_aleph") ;U+05D0 HEBREW LETTER ALEF (cl-define-keysym #x0ce1 "hebrew_bet") ;U+05D1 HEBREW LETTER BET (cl-define-keysym #x0ce1 "hebrew_beth") ;deprecated (cl-define-keysym #x0ce2 "hebrew_gimel") ;U+05D2 HEBREW LETTER GIMEL (cl-define-keysym #x0ce2 "hebrew_gimmel") ;deprecated (cl-define-keysym #x0ce3 "hebrew_dalet") ;U+05D3 HEBREW LETTER DALET (cl-define-keysym #x0ce3 "hebrew_daleth") ;deprecated (cl-define-keysym #x0ce4 "hebrew_he") ;U+05D4 HEBREW LETTER HE (cl-define-keysym #x0ce5 "hebrew_waw") ;U+05D5 HEBREW LETTER VAV (cl-define-keysym #x0ce6 "hebrew_zain") ;U+05D6 HEBREW LETTER ZAYIN (cl-define-keysym #x0ce6 "hebrew_zayin") ;deprecated (cl-define-keysym #x0ce7 "hebrew_chet") ;U+05D7 HEBREW LETTER HET (cl-define-keysym #x0ce7 "hebrew_het") ;deprecated (cl-define-keysym #x0ce8 "hebrew_tet") ;U+05D8 HEBREW LETTER TET (cl-define-keysym #x0ce8 "hebrew_teth") ;deprecated (cl-define-keysym #x0ce9 "hebrew_yod") ;U+05D9 HEBREW LETTER YOD (cl-define-keysym #x0cea "hebrew_finalkaph") ;U+05DA HEBREW LETTER FINAL KAF (cl-define-keysym #x0ceb "hebrew_kaph") ;U+05DB HEBREW LETTER KAF (cl-define-keysym #x0cec "hebrew_lamed") ;U+05DC HEBREW LETTER LAMED (cl-define-keysym #x0ced "hebrew_finalmem") ;U+05DD HEBREW LETTER FINAL MEM (cl-define-keysym #x0cee "hebrew_mem") ;U+05DE HEBREW LETTER MEM (cl-define-keysym #x0cef "hebrew_finalnun") ;U+05DF HEBREW LETTER FINAL NUN (cl-define-keysym #x0cf0 "hebrew_nun") ;U+05E0 HEBREW LETTER NUN (cl-define-keysym #x0cf1 "hebrew_samech") ;U+05E1 HEBREW LETTER SAMEKH (cl-define-keysym #x0cf1 "hebrew_samekh") ;deprecated (cl-define-keysym #x0cf2 "hebrew_ayin") ;U+05E2 HEBREW LETTER AYIN (cl-define-keysym #x0cf3 "hebrew_finalpe") ;U+05E3 HEBREW LETTER FINAL PE (cl-define-keysym #x0cf4 "hebrew_pe") ;U+05E4 HEBREW LETTER PE (cl-define-keysym #x0cf5 "hebrew_finalzade") ;U+05E5 HEBREW LETTER FINAL TSADI (cl-define-keysym #x0cf5 "hebrew_finalzadi") ;deprecated (cl-define-keysym #x0cf6 "hebrew_zade") ;U+05E6 HEBREW LETTER TSADI (cl-define-keysym #x0cf6 "hebrew_zadi") ;deprecated (cl-define-keysym #x0cf7 "hebrew_qoph") ;U+05E7 HEBREW LETTER QOF (cl-define-keysym #x0cf7 "hebrew_kuf") ;deprecated (cl-define-keysym #x0cf8 "hebrew_resh") ;U+05E8 HEBREW LETTER RESH (cl-define-keysym #x0cf9 "hebrew_shin") ;U+05E9 HEBREW LETTER SHIN (cl-define-keysym #x0cfa "hebrew_taw") ;U+05EA HEBREW LETTER TAV (cl-define-keysym #x0cfa "hebrew_taf") ;deprecated (cl-define-keysym #xff7e "Hebrew_switch") ;Alias for mode_switch (cl-define-keysym #x0da1 "Thai_kokai") ;U+0E01 THAI CHARACTER KO KAI (cl-define-keysym #x0da2 "Thai_khokhai") ;U+0E02 THAI CHARACTER KHO KHAI (cl-define-keysym #x0da3 "Thai_khokhuat") ;U+0E03 THAI CHARACTER KHO KHUAT (cl-define-keysym #x0da4 "Thai_khokhwai") ;U+0E04 THAI CHARACTER KHO KHWAI (cl-define-keysym #x0da5 "Thai_khokhon") ;U+0E05 THAI CHARACTER KHO KHON (cl-define-keysym #x0da6 "Thai_khorakhang") ;U+0E06 THAI CHARACTER KHO RAKHANG (cl-define-keysym #x0da7 "Thai_ngongu") ;U+0E07 THAI CHARACTER NGO NGU (cl-define-keysym #x0da8 "Thai_chochan") ;U+0E08 THAI CHARACTER CHO CHAN (cl-define-keysym #x0da9 "Thai_choching") ;U+0E09 THAI CHARACTER CHO CHING (cl-define-keysym #x0daa "Thai_chochang") ;U+0E0A THAI CHARACTER CHO CHANG (cl-define-keysym #x0dab "Thai_soso") ;U+0E0B THAI CHARACTER SO SO (cl-define-keysym #x0dac "Thai_chochoe") ;U+0E0C THAI CHARACTER CHO CHOE (cl-define-keysym #x0dad "Thai_yoying") ;U+0E0D THAI CHARACTER YO YING (cl-define-keysym #x0dae "Thai_dochada") ;U+0E0E THAI CHARACTER DO CHADA (cl-define-keysym #x0daf "Thai_topatak") ;U+0E0F THAI CHARACTER TO PATAK (cl-define-keysym #x0db0 "Thai_thothan") ;U+0E10 THAI CHARACTER THO THAN (cl-define-keysym #x0db1 "Thai_thonangmontho") ;U+0E11 THAI CHARACTER THO NANGMONTHO (cl-define-keysym #x0db2 "Thai_thophuthao") ;U+0E12 THAI CHARACTER THO PHUTHAO (cl-define-keysym #x0db3 "Thai_nonen") ;U+0E13 THAI CHARACTER NO NEN (cl-define-keysym #x0db4 "Thai_dodek") ;U+0E14 THAI CHARACTER DO DEK (cl-define-keysym #x0db5 "Thai_totao") ;U+0E15 THAI CHARACTER TO TAO (cl-define-keysym #x0db6 "Thai_thothung") ;U+0E16 THAI CHARACTER THO THUNG (cl-define-keysym #x0db7 "Thai_thothahan") ;U+0E17 THAI CHARACTER THO THAHAN (cl-define-keysym #x0db8 "Thai_thothong") ;U+0E18 THAI CHARACTER THO THONG (cl-define-keysym #x0db9 "Thai_nonu") ;U+0E19 THAI CHARACTER NO NU (cl-define-keysym #x0dba "Thai_bobaimai") ;U+0E1A THAI CHARACTER BO BAIMAI (cl-define-keysym #x0dbb "Thai_popla") ;U+0E1B THAI CHARACTER PO PLA (cl-define-keysym #x0dbc "Thai_phophung") ;U+0E1C THAI CHARACTER PHO PHUNG (cl-define-keysym #x0dbd "Thai_fofa") ;U+0E1D THAI CHARACTER FO FA (cl-define-keysym #x0dbe "Thai_phophan") ;U+0E1E THAI CHARACTER PHO PHAN (cl-define-keysym #x0dbf "Thai_fofan") ;U+0E1F THAI CHARACTER FO FAN (cl-define-keysym #x0dc0 "Thai_phosamphao") ;U+0E20 THAI CHARACTER PHO SAMPHAO (cl-define-keysym #x0dc1 "Thai_moma") ;U+0E21 THAI CHARACTER MO MA (cl-define-keysym #x0dc2 "Thai_yoyak") ;U+0E22 THAI CHARACTER YO YAK (cl-define-keysym #x0dc3 "Thai_rorua") ;U+0E23 THAI CHARACTER RO RUA (cl-define-keysym #x0dc4 "Thai_ru") ;U+0E24 THAI CHARACTER RU (cl-define-keysym #x0dc5 "Thai_loling") ;U+0E25 THAI CHARACTER LO LING (cl-define-keysym #x0dc6 "Thai_lu") ;U+0E26 THAI CHARACTER LU (cl-define-keysym #x0dc7 "Thai_wowaen") ;U+0E27 THAI CHARACTER WO WAEN (cl-define-keysym #x0dc8 "Thai_sosala") ;U+0E28 THAI CHARACTER SO SALA (cl-define-keysym #x0dc9 "Thai_sorusi") ;U+0E29 THAI CHARACTER SO RUSI (cl-define-keysym #x0dca "Thai_sosua") ;U+0E2A THAI CHARACTER SO SUA (cl-define-keysym #x0dcb "Thai_hohip") ;U+0E2B THAI CHARACTER HO HIP (cl-define-keysym #x0dcc "Thai_lochula") ;U+0E2C THAI CHARACTER LO CHULA (cl-define-keysym #x0dcd "Thai_oang") ;U+0E2D THAI CHARACTER O ANG (cl-define-keysym #x0dce "Thai_honokhuk") ;U+0E2E THAI CHARACTER HO NOKHUK (cl-define-keysym #x0dcf "Thai_paiyannoi") ;U+0E2F THAI CHARACTER PAIYANNOI (cl-define-keysym #x0dd0 "Thai_saraa") ;U+0E30 THAI CHARACTER SARA A (cl-define-keysym #x0dd1 "Thai_maihanakat") ;U+0E31 THAI CHARACTER MAI HAN-AKAT (cl-define-keysym #x0dd2 "Thai_saraaa") ;U+0E32 THAI CHARACTER SARA AA (cl-define-keysym #x0dd3 "Thai_saraam") ;U+0E33 THAI CHARACTER SARA AM (cl-define-keysym #x0dd4 "Thai_sarai") ;U+0E34 THAI CHARACTER SARA I (cl-define-keysym #x0dd5 "Thai_saraii") ;U+0E35 THAI CHARACTER SARA II (cl-define-keysym #x0dd6 "Thai_saraue") ;U+0E36 THAI CHARACTER SARA UE (cl-define-keysym #x0dd7 "Thai_sarauee") ;U+0E37 THAI CHARACTER SARA UEE (cl-define-keysym #x0dd8 "Thai_sarau") ;U+0E38 THAI CHARACTER SARA U (cl-define-keysym #x0dd9 "Thai_sarauu") ;U+0E39 THAI CHARACTER SARA UU (cl-define-keysym #x0dda "Thai_phinthu") ;U+0E3A THAI CHARACTER PHINTHU (cl-define-keysym #x0dde "Thai_maihanakat_maitho") (cl-define-keysym #x0ddf "Thai_baht") ;U+0E3F THAI CURRENCY SYMBOL BAHT (cl-define-keysym #x0de0 "Thai_sarae") ;U+0E40 THAI CHARACTER SARA E (cl-define-keysym #x0de1 "Thai_saraae") ;U+0E41 THAI CHARACTER SARA AE (cl-define-keysym #x0de2 "Thai_sarao") ;U+0E42 THAI CHARACTER SARA O (cl-define-keysym #x0de3 "Thai_saraaimaimuan") ;U+0E43 THAI CHARACTER SARA AI MAIMUAN (cl-define-keysym #x0de4 "Thai_saraaimaimalai") ;U+0E44 THAI CHARACTER SARA AI MAIMALAI (cl-define-keysym #x0de5 "Thai_lakkhangyao") ;U+0E45 THAI CHARACTER LAKKHANGYAO (cl-define-keysym #x0de6 "Thai_maiyamok") ;U+0E46 THAI CHARACTER MAIYAMOK (cl-define-keysym #x0de7 "Thai_maitaikhu") ;U+0E47 THAI CHARACTER MAITAIKHU (cl-define-keysym #x0de8 "Thai_maiek") ;U+0E48 THAI CHARACTER MAI EK (cl-define-keysym #x0de9 "Thai_maitho") ;U+0E49 THAI CHARACTER MAI THO (cl-define-keysym #x0dea "Thai_maitri") ;U+0E4A THAI CHARACTER MAI TRI (cl-define-keysym #x0deb "Thai_maichattawa") ;U+0E4B THAI CHARACTER MAI CHATTAWA (cl-define-keysym #x0dec "Thai_thanthakhat") ;U+0E4C THAI CHARACTER THANTHAKHAT (cl-define-keysym #x0ded "Thai_nikhahit") ;U+0E4D THAI CHARACTER NIKHAHIT (cl-define-keysym #x0df0 "Thai_leksun") ;U+0E50 THAI DIGIT ZERO (cl-define-keysym #x0df1 "Thai_leknung") ;U+0E51 THAI DIGIT ONE (cl-define-keysym #x0df2 "Thai_leksong") ;U+0E52 THAI DIGIT TWO (cl-define-keysym #x0df3 "Thai_leksam") ;U+0E53 THAI DIGIT THREE (cl-define-keysym #x0df4 "Thai_leksi") ;U+0E54 THAI DIGIT FOUR (cl-define-keysym #x0df5 "Thai_lekha") ;U+0E55 THAI DIGIT FIVE (cl-define-keysym #x0df6 "Thai_lekhok") ;U+0E56 THAI DIGIT SIX (cl-define-keysym #x0df7 "Thai_lekchet") ;U+0E57 THAI DIGIT SEVEN (cl-define-keysym #x0df8 "Thai_lekpaet") ;U+0E58 THAI DIGIT EIGHT (cl-define-keysym #x0df9 "Thai_lekkao") ;U+0E59 THAI DIGIT NINE (cl-define-keysym #xff31 "Hangul") ;Hangul start/stop(toggle) (cl-define-keysym #xff32 "Hangul_Start") ;Hangul start (cl-define-keysym #xff33 "Hangul_End") ;Hangul end, English start (cl-define-keysym #xff34 "Hangul_Hanja") ;Start Hangul->Hanja Conversion (cl-define-keysym #xff35 "Hangul_Jamo") ;Hangul Jamo mode (cl-define-keysym #xff36 "Hangul_Romaja") ;Hangul Romaja mode (cl-define-keysym #xff37 "Hangul_Codeinput") ;Hangul code input mode (cl-define-keysym #xff38 "Hangul_Jeonja") ;Jeonja mode (cl-define-keysym #xff39 "Hangul_Banja") ;Banja mode (cl-define-keysym #xff3a "Hangul_PreHanja") ;Pre Hanja conversion (cl-define-keysym #xff3b "Hangul_PostHanja") ;Post Hanja conversion (cl-define-keysym #xff3c "Hangul_SingleCandidate") ;Single candidate (cl-define-keysym #xff3d "Hangul_MultipleCandidate") ;Multiple candidate (cl-define-keysym #xff3e "Hangul_PreviousCandidate") ;Previous candidate (cl-define-keysym #xff3f "Hangul_Special") ;Special symbols (cl-define-keysym #xff7e "Hangul_switch") ;Alias for mode_switch (cl-define-keysym #x0ea1 "Hangul_Kiyeog") (cl-define-keysym #x0ea2 "Hangul_SsangKiyeog") (cl-define-keysym #x0ea3 "Hangul_KiyeogSios") (cl-define-keysym #x0ea4 "Hangul_Nieun") (cl-define-keysym #x0ea5 "Hangul_NieunJieuj") (cl-define-keysym #x0ea6 "Hangul_NieunHieuh") (cl-define-keysym #x0ea7 "Hangul_Dikeud") (cl-define-keysym #x0ea8 "Hangul_SsangDikeud") (cl-define-keysym #x0ea9 "Hangul_Rieul") (cl-define-keysym #x0eaa "Hangul_RieulKiyeog") (cl-define-keysym #x0eab "Hangul_RieulMieum") (cl-define-keysym #x0eac "Hangul_RieulPieub") (cl-define-keysym #x0ead "Hangul_RieulSios") (cl-define-keysym #x0eae "Hangul_RieulTieut") (cl-define-keysym #x0eaf "Hangul_RieulPhieuf") (cl-define-keysym #x0eb0 "Hangul_RieulHieuh") (cl-define-keysym #x0eb1 "Hangul_Mieum") (cl-define-keysym #x0eb2 "Hangul_Pieub") (cl-define-keysym #x0eb3 "Hangul_SsangPieub") (cl-define-keysym #x0eb4 "Hangul_PieubSios") (cl-define-keysym #x0eb5 "Hangul_Sios") (cl-define-keysym #x0eb6 "Hangul_SsangSios") (cl-define-keysym #x0eb7 "Hangul_Ieung") (cl-define-keysym #x0eb8 "Hangul_Jieuj") (cl-define-keysym #x0eb9 "Hangul_SsangJieuj") (cl-define-keysym #x0eba "Hangul_Cieuc") (cl-define-keysym #x0ebb "Hangul_Khieuq") (cl-define-keysym #x0ebc "Hangul_Tieut") (cl-define-keysym #x0ebd "Hangul_Phieuf") (cl-define-keysym #x0ebe "Hangul_Hieuh") (cl-define-keysym #x0ebf "Hangul_A") (cl-define-keysym #x0ec0 "Hangul_AE") (cl-define-keysym #x0ec1 "Hangul_YA") (cl-define-keysym #x0ec2 "Hangul_YAE") (cl-define-keysym #x0ec3 "Hangul_EO") (cl-define-keysym #x0ec4 "Hangul_E") (cl-define-keysym #x0ec5 "Hangul_YEO") (cl-define-keysym #x0ec6 "Hangul_YE") (cl-define-keysym #x0ec7 "Hangul_O") (cl-define-keysym #x0ec8 "Hangul_WA") (cl-define-keysym #x0ec9 "Hangul_WAE") (cl-define-keysym #x0eca "Hangul_OE") (cl-define-keysym #x0ecb "Hangul_YO") (cl-define-keysym #x0ecc "Hangul_U") (cl-define-keysym #x0ecd "Hangul_WEO") (cl-define-keysym #x0ece "Hangul_WE") (cl-define-keysym #x0ecf "Hangul_WI") (cl-define-keysym #x0ed0 "Hangul_YU") (cl-define-keysym #x0ed1 "Hangul_EU") (cl-define-keysym #x0ed2 "Hangul_YI") (cl-define-keysym #x0ed3 "Hangul_I") (cl-define-keysym #x0ed4 "Hangul_J_Kiyeog") (cl-define-keysym #x0ed5 "Hangul_J_SsangKiyeog") (cl-define-keysym #x0ed6 "Hangul_J_KiyeogSios") (cl-define-keysym #x0ed7 "Hangul_J_Nieun") (cl-define-keysym #x0ed8 "Hangul_J_NieunJieuj") (cl-define-keysym #x0ed9 "Hangul_J_NieunHieuh") (cl-define-keysym #x0eda "Hangul_J_Dikeud") (cl-define-keysym #x0edb "Hangul_J_Rieul") (cl-define-keysym #x0edc "Hangul_J_RieulKiyeog") (cl-define-keysym #x0edd "Hangul_J_RieulMieum") (cl-define-keysym #x0ede "Hangul_J_RieulPieub") (cl-define-keysym #x0edf "Hangul_J_RieulSios") (cl-define-keysym #x0ee0 "Hangul_J_RieulTieut") (cl-define-keysym #x0ee1 "Hangul_J_RieulPhieuf") (cl-define-keysym #x0ee2 "Hangul_J_RieulHieuh") (cl-define-keysym #x0ee3 "Hangul_J_Mieum") (cl-define-keysym #x0ee4 "Hangul_J_Pieub") (cl-define-keysym #x0ee5 "Hangul_J_PieubSios") (cl-define-keysym #x0ee6 "Hangul_J_Sios") (cl-define-keysym #x0ee7 "Hangul_J_SsangSios") (cl-define-keysym #x0ee8 "Hangul_J_Ieung") (cl-define-keysym #x0ee9 "Hangul_J_Jieuj") (cl-define-keysym #x0eea "Hangul_J_Cieuc") (cl-define-keysym #x0eeb "Hangul_J_Khieuq") (cl-define-keysym #x0eec "Hangul_J_Tieut") (cl-define-keysym #x0eed "Hangul_J_Phieuf") (cl-define-keysym #x0eee "Hangul_J_Hieuh") (cl-define-keysym #x0eef "Hangul_RieulYeorinHieuh") (cl-define-keysym #x0ef0 "Hangul_SunkyeongeumMieum") (cl-define-keysym #x0ef1 "Hangul_SunkyeongeumPieub") (cl-define-keysym #x0ef2 "Hangul_PanSios") (cl-define-keysym #x0ef3 "Hangul_KkogjiDalrinIeung") (cl-define-keysym #x0ef4 "Hangul_SunkyeongeumPhieuf") (cl-define-keysym #x0ef5 "Hangul_YeorinHieuh") (cl-define-keysym #x0ef6 "Hangul_AraeA") (cl-define-keysym #x0ef7 "Hangul_AraeAE") (cl-define-keysym #x0ef8 "Hangul_J_PanSios") (cl-define-keysym #x0ef9 "Hangul_J_KkogjiDalrinIeung") (cl-define-keysym #x0efa "Hangul_J_YeorinHieuh") (cl-define-keysym #x0eff "Korean_Won") ;(U+20A9 WON SIGN) (cl-define-keysym #x1000587 "Armenian_ligature_ew") ;U+0587 ARMENIAN SMALL LIGATURE ECH YIWN (cl-define-keysym #x1000589 "Armenian_full_stop") ;U+0589 ARMENIAN FULL STOP (cl-define-keysym #x1000589 "Armenian_verjaket") ;U+0589 ARMENIAN FULL STOP (cl-define-keysym #x100055d "Armenian_separation_mark") ;U+055D ARMENIAN COMMA (cl-define-keysym #x100055d "Armenian_but") ;U+055D ARMENIAN COMMA (cl-define-keysym #x100058a "Armenian_hyphen") ;U+058A ARMENIAN HYPHEN (cl-define-keysym #x100058a "Armenian_yentamna") ;U+058A ARMENIAN HYPHEN (cl-define-keysym #x100055c "Armenian_exclam") ;U+055C ARMENIAN EXCLAMATION MARK (cl-define-keysym #x100055c "Armenian_amanak") ;U+055C ARMENIAN EXCLAMATION MARK (cl-define-keysym #x100055b "Armenian_accent") ;U+055B ARMENIAN EMPHASIS MARK (cl-define-keysym #x100055b "Armenian_shesht") ;U+055B ARMENIAN EMPHASIS MARK (cl-define-keysym #x100055e "Armenian_question") ;U+055E ARMENIAN QUESTION MARK (cl-define-keysym #x100055e "Armenian_paruyk") ;U+055E ARMENIAN QUESTION MARK (cl-define-keysym #x1000531 "Armenian_AYB") ;U+0531 ARMENIAN CAPITAL LETTER AYB (cl-define-keysym #x1000561 "Armenian_ayb") ;U+0561 ARMENIAN SMALL LETTER AYB (cl-define-keysym #x1000532 "Armenian_BEN") ;U+0532 ARMENIAN CAPITAL LETTER BEN (cl-define-keysym #x1000562 "Armenian_ben") ;U+0562 ARMENIAN SMALL LETTER BEN (cl-define-keysym #x1000533 "Armenian_GIM") ;U+0533 ARMENIAN CAPITAL LETTER GIM (cl-define-keysym #x1000563 "Armenian_gim") ;U+0563 ARMENIAN SMALL LETTER GIM (cl-define-keysym #x1000534 "Armenian_DA") ;U+0534 ARMENIAN CAPITAL LETTER DA (cl-define-keysym #x1000564 "Armenian_da") ;U+0564 ARMENIAN SMALL LETTER DA (cl-define-keysym #x1000535 "Armenian_YECH") ;U+0535 ARMENIAN CAPITAL LETTER ECH (cl-define-keysym #x1000565 "Armenian_yech") ;U+0565 ARMENIAN SMALL LETTER ECH (cl-define-keysym #x1000536 "Armenian_ZA") ;U+0536 ARMENIAN CAPITAL LETTER ZA (cl-define-keysym #x1000566 "Armenian_za") ;U+0566 ARMENIAN SMALL LETTER ZA (cl-define-keysym #x1000537 "Armenian_E") ;U+0537 ARMENIAN CAPITAL LETTER EH (cl-define-keysym #x1000567 "Armenian_e") ;U+0567 ARMENIAN SMALL LETTER EH (cl-define-keysym #x1000538 "Armenian_AT") ;U+0538 ARMENIAN CAPITAL LETTER ET (cl-define-keysym #x1000568 "Armenian_at") ;U+0568 ARMENIAN SMALL LETTER ET (cl-define-keysym #x1000539 "Armenian_TO") ;U+0539 ARMENIAN CAPITAL LETTER TO (cl-define-keysym #x1000569 "Armenian_to") ;U+0569 ARMENIAN SMALL LETTER TO (cl-define-keysym #x100053a "Armenian_ZHE") ;U+053A ARMENIAN CAPITAL LETTER ZHE (cl-define-keysym #x100056a "Armenian_zhe") ;U+056A ARMENIAN SMALL LETTER ZHE (cl-define-keysym #x100053b "Armenian_INI") ;U+053B ARMENIAN CAPITAL LETTER INI (cl-define-keysym #x100056b "Armenian_ini") ;U+056B ARMENIAN SMALL LETTER INI (cl-define-keysym #x100053c "Armenian_LYUN") ;U+053C ARMENIAN CAPITAL LETTER LIWN (cl-define-keysym #x100056c "Armenian_lyun") ;U+056C ARMENIAN SMALL LETTER LIWN (cl-define-keysym #x100053d "Armenian_KHE") ;U+053D ARMENIAN CAPITAL LETTER XEH (cl-define-keysym #x100056d "Armenian_khe") ;U+056D ARMENIAN SMALL LETTER XEH (cl-define-keysym #x100053e "Armenian_TSA") ;U+053E ARMENIAN CAPITAL LETTER CA (cl-define-keysym #x100056e "Armenian_tsa") ;U+056E ARMENIAN SMALL LETTER CA (cl-define-keysym #x100053f "Armenian_KEN") ;U+053F ARMENIAN CAPITAL LETTER KEN (cl-define-keysym #x100056f "Armenian_ken") ;U+056F ARMENIAN SMALL LETTER KEN (cl-define-keysym #x1000540 "Armenian_HO") ;U+0540 ARMENIAN CAPITAL LETTER HO (cl-define-keysym #x1000570 "Armenian_ho") ;U+0570 ARMENIAN SMALL LETTER HO (cl-define-keysym #x1000541 "Armenian_DZA") ;U+0541 ARMENIAN CAPITAL LETTER JA (cl-define-keysym #x1000571 "Armenian_dza") ;U+0571 ARMENIAN SMALL LETTER JA (cl-define-keysym #x1000542 "Armenian_GHAT") ;U+0542 ARMENIAN CAPITAL LETTER GHAD (cl-define-keysym #x1000572 "Armenian_ghat") ;U+0572 ARMENIAN SMALL LETTER GHAD (cl-define-keysym #x1000543 "Armenian_TCHE") ;U+0543 ARMENIAN CAPITAL LETTER CHEH (cl-define-keysym #x1000573 "Armenian_tche") ;U+0573 ARMENIAN SMALL LETTER CHEH (cl-define-keysym #x1000544 "Armenian_MEN") ;U+0544 ARMENIAN CAPITAL LETTER MEN (cl-define-keysym #x1000574 "Armenian_men") ;U+0574 ARMENIAN SMALL LETTER MEN (cl-define-keysym #x1000545 "Armenian_HI") ;U+0545 ARMENIAN CAPITAL LETTER YI (cl-define-keysym #x1000575 "Armenian_hi") ;U+0575 ARMENIAN SMALL LETTER YI (cl-define-keysym #x1000546 "Armenian_NU") ;U+0546 ARMENIAN CAPITAL LETTER NOW (cl-define-keysym #x1000576 "Armenian_nu") ;U+0576 ARMENIAN SMALL LETTER NOW (cl-define-keysym #x1000547 "Armenian_SHA") ;U+0547 ARMENIAN CAPITAL LETTER SHA (cl-define-keysym #x1000577 "Armenian_sha") ;U+0577 ARMENIAN SMALL LETTER SHA (cl-define-keysym #x1000548 "Armenian_VO") ;U+0548 ARMENIAN CAPITAL LETTER VO (cl-define-keysym #x1000578 "Armenian_vo") ;U+0578 ARMENIAN SMALL LETTER VO (cl-define-keysym #x1000549 "Armenian_CHA") ;U+0549 ARMENIAN CAPITAL LETTER CHA (cl-define-keysym #x1000579 "Armenian_cha") ;U+0579 ARMENIAN SMALL LETTER CHA (cl-define-keysym #x100054a "Armenian_PE") ;U+054A ARMENIAN CAPITAL LETTER PEH (cl-define-keysym #x100057a "Armenian_pe") ;U+057A ARMENIAN SMALL LETTER PEH (cl-define-keysym #x100054b "Armenian_JE") ;U+054B ARMENIAN CAPITAL LETTER JHEH (cl-define-keysym #x100057b "Armenian_je") ;U+057B ARMENIAN SMALL LETTER JHEH (cl-define-keysym #x100054c "Armenian_RA") ;U+054C ARMENIAN CAPITAL LETTER RA (cl-define-keysym #x100057c "Armenian_ra") ;U+057C ARMENIAN SMALL LETTER RA (cl-define-keysym #x100054d "Armenian_SE") ;U+054D ARMENIAN CAPITAL LETTER SEH (cl-define-keysym #x100057d "Armenian_se") ;U+057D ARMENIAN SMALL LETTER SEH (cl-define-keysym #x100054e "Armenian_VEV") ;U+054E ARMENIAN CAPITAL LETTER VEW (cl-define-keysym #x100057e "Armenian_vev") ;U+057E ARMENIAN SMALL LETTER VEW (cl-define-keysym #x100054f "Armenian_TYUN") ;U+054F ARMENIAN CAPITAL LETTER TIWN (cl-define-keysym #x100057f "Armenian_tyun") ;U+057F ARMENIAN SMALL LETTER TIWN (cl-define-keysym #x1000550 "Armenian_RE") ;U+0550 ARMENIAN CAPITAL LETTER REH (cl-define-keysym #x1000580 "Armenian_re") ;U+0580 ARMENIAN SMALL LETTER REH (cl-define-keysym #x1000551 "Armenian_TSO") ;U+0551 ARMENIAN CAPITAL LETTER CO (cl-define-keysym #x1000581 "Armenian_tso") ;U+0581 ARMENIAN SMALL LETTER CO (cl-define-keysym #x1000552 "Armenian_VYUN") ;U+0552 ARMENIAN CAPITAL LETTER YIWN (cl-define-keysym #x1000582 "Armenian_vyun") ;U+0582 ARMENIAN SMALL LETTER YIWN (cl-define-keysym #x1000553 "Armenian_PYUR") ;U+0553 ARMENIAN CAPITAL LETTER PIWR (cl-define-keysym #x1000583 "Armenian_pyur") ;U+0583 ARMENIAN SMALL LETTER PIWR (cl-define-keysym #x1000554 "Armenian_KE") ;U+0554 ARMENIAN CAPITAL LETTER KEH (cl-define-keysym #x1000584 "Armenian_ke") ;U+0584 ARMENIAN SMALL LETTER KEH (cl-define-keysym #x1000555 "Armenian_O") ;U+0555 ARMENIAN CAPITAL LETTER OH (cl-define-keysym #x1000585 "Armenian_o") ;U+0585 ARMENIAN SMALL LETTER OH (cl-define-keysym #x1000556 "Armenian_FE") ;U+0556 ARMENIAN CAPITAL LETTER FEH (cl-define-keysym #x1000586 "Armenian_fe") ;U+0586 ARMENIAN SMALL LETTER FEH (cl-define-keysym #x100055a "Armenian_apostrophe") ;U+055A ARMENIAN APOSTROPHE (cl-define-keysym #x10010d0 "Georgian_an") ;U+10D0 GEORGIAN LETTER AN (cl-define-keysym #x10010d1 "Georgian_ban") ;U+10D1 GEORGIAN LETTER BAN (cl-define-keysym #x10010d2 "Georgian_gan") ;U+10D2 GEORGIAN LETTER GAN (cl-define-keysym #x10010d3 "Georgian_don") ;U+10D3 GEORGIAN LETTER DON (cl-define-keysym #x10010d4 "Georgian_en") ;U+10D4 GEORGIAN LETTER EN (cl-define-keysym #x10010d5 "Georgian_vin") ;U+10D5 GEORGIAN LETTER VIN (cl-define-keysym #x10010d6 "Georgian_zen") ;U+10D6 GEORGIAN LETTER ZEN (cl-define-keysym #x10010d7 "Georgian_tan") ;U+10D7 GEORGIAN LETTER TAN (cl-define-keysym #x10010d8 "Georgian_in") ;U+10D8 GEORGIAN LETTER IN (cl-define-keysym #x10010d9 "Georgian_kan") ;U+10D9 GEORGIAN LETTER KAN (cl-define-keysym #x10010da "Georgian_las") ;U+10DA GEORGIAN LETTER LAS (cl-define-keysym #x10010db "Georgian_man") ;U+10DB GEORGIAN LETTER MAN (cl-define-keysym #x10010dc "Georgian_nar") ;U+10DC GEORGIAN LETTER NAR (cl-define-keysym #x10010dd "Georgian_on") ;U+10DD GEORGIAN LETTER ON (cl-define-keysym #x10010de "Georgian_par") ;U+10DE GEORGIAN LETTER PAR (cl-define-keysym #x10010df "Georgian_zhar") ;U+10DF GEORGIAN LETTER ZHAR (cl-define-keysym #x10010e0 "Georgian_rae") ;U+10E0 GEORGIAN LETTER RAE (cl-define-keysym #x10010e1 "Georgian_san") ;U+10E1 GEORGIAN LETTER SAN (cl-define-keysym #x10010e2 "Georgian_tar") ;U+10E2 GEORGIAN LETTER TAR (cl-define-keysym #x10010e3 "Georgian_un") ;U+10E3 GEORGIAN LETTER UN (cl-define-keysym #x10010e4 "Georgian_phar") ;U+10E4 GEORGIAN LETTER PHAR (cl-define-keysym #x10010e5 "Georgian_khar") ;U+10E5 GEORGIAN LETTER KHAR (cl-define-keysym #x10010e6 "Georgian_ghan") ;U+10E6 GEORGIAN LETTER GHAN (cl-define-keysym #x10010e7 "Georgian_qar") ;U+10E7 GEORGIAN LETTER QAR (cl-define-keysym #x10010e8 "Georgian_shin") ;U+10E8 GEORGIAN LETTER SHIN (cl-define-keysym #x10010e9 "Georgian_chin") ;U+10E9 GEORGIAN LETTER CHIN (cl-define-keysym #x10010ea "Georgian_can") ;U+10EA GEORGIAN LETTER CAN (cl-define-keysym #x10010eb "Georgian_jil") ;U+10EB GEORGIAN LETTER JIL (cl-define-keysym #x10010ec "Georgian_cil") ;U+10EC GEORGIAN LETTER CIL (cl-define-keysym #x10010ed "Georgian_char") ;U+10ED GEORGIAN LETTER CHAR (cl-define-keysym #x10010ee "Georgian_xan") ;U+10EE GEORGIAN LETTER XAN (cl-define-keysym #x10010ef "Georgian_jhan") ;U+10EF GEORGIAN LETTER JHAN (cl-define-keysym #x10010f0 "Georgian_hae") ;U+10F0 GEORGIAN LETTER HAE (cl-define-keysym #x10010f1 "Georgian_he") ;U+10F1 GEORGIAN LETTER HE (cl-define-keysym #x10010f2 "Georgian_hie") ;U+10F2 GEORGIAN LETTER HIE (cl-define-keysym #x10010f3 "Georgian_we") ;U+10F3 GEORGIAN LETTER WE (cl-define-keysym #x10010f4 "Georgian_har") ;U+10F4 GEORGIAN LETTER HAR (cl-define-keysym #x10010f5 "Georgian_hoe") ;U+10F5 GEORGIAN LETTER HOE (cl-define-keysym #x10010f6 "Georgian_fi") ;U+10F6 GEORGIAN LETTER FI (cl-define-keysym #x1001e8a "Xabovedot") ;U+1E8A LATIN CAPITAL LETTER X WITH DOT ABOVE (cl-define-keysym #x100012c "Ibreve") ;U+012C LATIN CAPITAL LETTER I WITH BREVE (cl-define-keysym #x10001b5 "Zstroke") ;U+01B5 LATIN CAPITAL LETTER Z WITH STROKE (cl-define-keysym #x10001e6 "Gcaron") ;U+01E6 LATIN CAPITAL LETTER G WITH CARON (cl-define-keysym #x10001d1 "Ocaron") ;U+01D2 LATIN CAPITAL LETTER O WITH CARON (cl-define-keysym #x100019f "Obarred") ;U+019F LATIN CAPITAL LETTER O WITH MIDDLE TILDE (cl-define-keysym #x1001e8b "xabovedot") ;U+1E8B LATIN SMALL LETTER X WITH DOT ABOVE (cl-define-keysym #x100012d "ibreve") ;U+012D LATIN SMALL LETTER I WITH BREVE (cl-define-keysym #x10001b6 "zstroke") ;U+01B6 LATIN SMALL LETTER Z WITH STROKE (cl-define-keysym #x10001e7 "gcaron") ;U+01E7 LATIN SMALL LETTER G WITH CARON (cl-define-keysym #x10001d2 "ocaron") ;U+01D2 LATIN SMALL LETTER O WITH CARON (cl-define-keysym #x1000275 "obarred") ;U+0275 LATIN SMALL LETTER BARRED O (cl-define-keysym #x100018f "SCHWA") ;U+018F LATIN CAPITAL LETTER SCHWA (cl-define-keysym #x1000259 "schwa") ;U+0259 LATIN SMALL LETTER SCHWA (cl-define-keysym #x1001e36 "Lbelowdot") ;U+1E36 LATIN CAPITAL LETTER L WITH DOT BELOW (cl-define-keysym #x1001e37 "lbelowdot") ;U+1E37 LATIN SMALL LETTER L WITH DOT BELOW (cl-define-keysym #x1001ea0 "Abelowdot") ;U+1EA0 LATIN CAPITAL LETTER A WITH DOT BELOW (cl-define-keysym #x1001ea1 "abelowdot") ;U+1EA1 LATIN SMALL LETTER A WITH DOT BELOW (cl-define-keysym #x1001ea2 "Ahook") ;U+1EA2 LATIN CAPITAL LETTER A WITH HOOK ABOVE (cl-define-keysym #x1001ea3 "ahook") ;U+1EA3 LATIN SMALL LETTER A WITH HOOK ABOVE (cl-define-keysym #x1001ea4 "Acircumflexacute") ;U+1EA4 LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND ACUTE (cl-define-keysym #x1001ea5 "acircumflexacute") ;U+1EA5 LATIN SMALL LETTER A WITH CIRCUMFLEX AND ACUTE (cl-define-keysym #x1001ea6 "Acircumflexgrave") ;U+1EA6 LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND GRAVE (cl-define-keysym #x1001ea7 "acircumflexgrave") ;U+1EA7 LATIN SMALL LETTER A WITH CIRCUMFLEX AND GRAVE (cl-define-keysym #x1001ea8 "Acircumflexhook") ;U+1EA8 LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND HOOK ABOVE (cl-define-keysym #x1001ea9 "acircumflexhook") ;U+1EA9 LATIN SMALL LETTER A WITH CIRCUMFLEX AND HOOK ABOVE (cl-define-keysym #x1001eaa "Acircumflextilde") ;U+1EAA LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND TILDE (cl-define-keysym #x1001eab "acircumflextilde") ;U+1EAB LATIN SMALL LETTER A WITH CIRCUMFLEX AND TILDE (cl-define-keysym #x1001eac "Acircumflexbelowdot") ;U+1EAC LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND DOT BELOW (cl-define-keysym #x1001ead "acircumflexbelowdot") ;U+1EAD LATIN SMALL LETTER A WITH CIRCUMFLEX AND DOT BELOW (cl-define-keysym #x1001eae "Abreveacute") ;U+1EAE LATIN CAPITAL LETTER A WITH BREVE AND ACUTE (cl-define-keysym #x1001eaf "abreveacute") ;U+1EAF LATIN SMALL LETTER A WITH BREVE AND ACUTE (cl-define-keysym #x1001eb0 "Abrevegrave") ;U+1EB0 LATIN CAPITAL LETTER A WITH BREVE AND GRAVE (cl-define-keysym #x1001eb1 "abrevegrave") ;U+1EB1 LATIN SMALL LETTER A WITH BREVE AND GRAVE (cl-define-keysym #x1001eb2 "Abrevehook") ;U+1EB2 LATIN CAPITAL LETTER A WITH BREVE AND HOOK ABOVE (cl-define-keysym #x1001eb3 "abrevehook") ;U+1EB3 LATIN SMALL LETTER A WITH BREVE AND HOOK ABOVE (cl-define-keysym #x1001eb4 "Abrevetilde") ;U+1EB4 LATIN CAPITAL LETTER A WITH BREVE AND TILDE (cl-define-keysym #x1001eb5 "abrevetilde") ;U+1EB5 LATIN SMALL LETTER A WITH BREVE AND TILDE (cl-define-keysym #x1001eb6 "Abrevebelowdot") ;U+1EB6 LATIN CAPITAL LETTER A WITH BREVE AND DOT BELOW (cl-define-keysym #x1001eb7 "abrevebelowdot") ;U+1EB7 LATIN SMALL LETTER A WITH BREVE AND DOT BELOW (cl-define-keysym #x1001eb8 "Ebelowdot") ;U+1EB8 LATIN CAPITAL LETTER E WITH DOT BELOW (cl-define-keysym #x1001eb9 "ebelowdot") ;U+1EB9 LATIN SMALL LETTER E WITH DOT BELOW (cl-define-keysym #x1001eba "Ehook") ;U+1EBA LATIN CAPITAL LETTER E WITH HOOK ABOVE (cl-define-keysym #x1001ebb "ehook") ;U+1EBB LATIN SMALL LETTER E WITH HOOK ABOVE (cl-define-keysym #x1001ebc "Etilde") ;U+1EBC LATIN CAPITAL LETTER E WITH TILDE (cl-define-keysym #x1001ebd "etilde") ;U+1EBD LATIN SMALL LETTER E WITH TILDE (cl-define-keysym #x1001ebe "Ecircumflexacute") ;U+1EBE LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND ACUTE (cl-define-keysym #x1001ebf "ecircumflexacute") ;U+1EBF LATIN SMALL LETTER E WITH CIRCUMFLEX AND ACUTE (cl-define-keysym #x1001ec0 "Ecircumflexgrave") ;U+1EC0 LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND GRAVE (cl-define-keysym #x1001ec1 "ecircumflexgrave") ;U+1EC1 LATIN SMALL LETTER E WITH CIRCUMFLEX AND GRAVE (cl-define-keysym #x1001ec2 "Ecircumflexhook") ;U+1EC2 LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND HOOK ABOVE (cl-define-keysym #x1001ec3 "ecircumflexhook") ;U+1EC3 LATIN SMALL LETTER E WITH CIRCUMFLEX AND HOOK ABOVE (cl-define-keysym #x1001ec4 "Ecircumflextilde") ;U+1EC4 LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND TILDE (cl-define-keysym #x1001ec5 "ecircumflextilde") ;U+1EC5 LATIN SMALL LETTER E WITH CIRCUMFLEX AND TILDE (cl-define-keysym #x1001ec6 "Ecircumflexbelowdot") ;U+1EC6 LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND DOT BELOW (cl-define-keysym #x1001ec7 "ecircumflexbelowdot") ;U+1EC7 LATIN SMALL LETTER E WITH CIRCUMFLEX AND DOT BELOW (cl-define-keysym #x1001ec8 "Ihook") ;U+1EC8 LATIN CAPITAL LETTER I WITH HOOK ABOVE (cl-define-keysym #x1001ec9 "ihook") ;U+1EC9 LATIN SMALL LETTER I WITH HOOK ABOVE (cl-define-keysym #x1001eca "Ibelowdot") ;U+1ECA LATIN CAPITAL LETTER I WITH DOT BELOW (cl-define-keysym #x1001ecb "ibelowdot") ;U+1ECB LATIN SMALL LETTER I WITH DOT BELOW (cl-define-keysym #x1001ecc "Obelowdot") ;U+1ECC LATIN CAPITAL LETTER O WITH DOT BELOW (cl-define-keysym #x1001ecd "obelowdot") ;U+1ECD LATIN SMALL LETTER O WITH DOT BELOW (cl-define-keysym #x1001ece "Ohook") ;U+1ECE LATIN CAPITAL LETTER O WITH HOOK ABOVE (cl-define-keysym #x1001ecf "ohook") ;U+1ECF LATIN SMALL LETTER O WITH HOOK ABOVE (cl-define-keysym #x1001ed0 "Ocircumflexacute") ;U+1ED0 LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND ACUTE (cl-define-keysym #x1001ed1 "ocircumflexacute") ;U+1ED1 LATIN SMALL LETTER O WITH CIRCUMFLEX AND ACUTE (cl-define-keysym #x1001ed2 "Ocircumflexgrave") ;U+1ED2 LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND GRAVE (cl-define-keysym #x1001ed3 "ocircumflexgrave") ;U+1ED3 LATIN SMALL LETTER O WITH CIRCUMFLEX AND GRAVE (cl-define-keysym #x1001ed4 "Ocircumflexhook") ;U+1ED4 LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND HOOK ABOVE (cl-define-keysym #x1001ed5 "ocircumflexhook") ;U+1ED5 LATIN SMALL LETTER O WITH CIRCUMFLEX AND HOOK ABOVE (cl-define-keysym #x1001ed6 "Ocircumflextilde") ;U+1ED6 LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND TILDE (cl-define-keysym #x1001ed7 "ocircumflextilde") ;U+1ED7 LATIN SMALL LETTER O WITH CIRCUMFLEX AND TILDE (cl-define-keysym #x1001ed8 "Ocircumflexbelowdot") ;U+1ED8 LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND DOT BELOW (cl-define-keysym #x1001ed9 "ocircumflexbelowdot") ;U+1ED9 LATIN SMALL LETTER O WITH CIRCUMFLEX AND DOT BELOW (cl-define-keysym #x1001eda "Ohornacute") ;U+1EDA LATIN CAPITAL LETTER O WITH HORN AND ACUTE (cl-define-keysym #x1001edb "ohornacute") ;U+1EDB LATIN SMALL LETTER O WITH HORN AND ACUTE (cl-define-keysym #x1001edc "Ohorngrave") ;U+1EDC LATIN CAPITAL LETTER O WITH HORN AND GRAVE (cl-define-keysym #x1001edd "ohorngrave") ;U+1EDD LATIN SMALL LETTER O WITH HORN AND GRAVE (cl-define-keysym #x1001ede "Ohornhook") ;U+1EDE LATIN CAPITAL LETTER O WITH HORN AND HOOK ABOVE (cl-define-keysym #x1001edf "ohornhook") ;U+1EDF LATIN SMALL LETTER O WITH HORN AND HOOK ABOVE (cl-define-keysym #x1001ee0 "Ohorntilde") ;U+1EE0 LATIN CAPITAL LETTER O WITH HORN AND TILDE (cl-define-keysym #x1001ee1 "ohorntilde") ;U+1EE1 LATIN SMALL LETTER O WITH HORN AND TILDE (cl-define-keysym #x1001ee2 "Ohornbelowdot") ;U+1EE2 LATIN CAPITAL LETTER O WITH HORN AND DOT BELOW (cl-define-keysym #x1001ee3 "ohornbelowdot") ;U+1EE3 LATIN SMALL LETTER O WITH HORN AND DOT BELOW (cl-define-keysym #x1001ee4 "Ubelowdot") ;U+1EE4 LATIN CAPITAL LETTER U WITH DOT BELOW (cl-define-keysym #x1001ee5 "ubelowdot") ;U+1EE5 LATIN SMALL LETTER U WITH DOT BELOW (cl-define-keysym #x1001ee6 "Uhook") ;U+1EE6 LATIN CAPITAL LETTER U WITH HOOK ABOVE (cl-define-keysym #x1001ee7 "uhook") ;U+1EE7 LATIN SMALL LETTER U WITH HOOK ABOVE (cl-define-keysym #x1001ee8 "Uhornacute") ;U+1EE8 LATIN CAPITAL LETTER U WITH HORN AND ACUTE (cl-define-keysym #x1001ee9 "uhornacute") ;U+1EE9 LATIN SMALL LETTER U WITH HORN AND ACUTE (cl-define-keysym #x1001eea "Uhorngrave") ;U+1EEA LATIN CAPITAL LETTER U WITH HORN AND GRAVE (cl-define-keysym #x1001eeb "uhorngrave") ;U+1EEB LATIN SMALL LETTER U WITH HORN AND GRAVE (cl-define-keysym #x1001eec "Uhornhook") ;U+1EEC LATIN CAPITAL LETTER U WITH HORN AND HOOK ABOVE (cl-define-keysym #x1001eed "uhornhook") ;U+1EED LATIN SMALL LETTER U WITH HORN AND HOOK ABOVE (cl-define-keysym #x1001eee "Uhorntilde") ;U+1EEE LATIN CAPITAL LETTER U WITH HORN AND TILDE (cl-define-keysym #x1001eef "uhorntilde") ;U+1EEF LATIN SMALL LETTER U WITH HORN AND TILDE (cl-define-keysym #x1001ef0 "Uhornbelowdot") ;U+1EF0 LATIN CAPITAL LETTER U WITH HORN AND DOT BELOW (cl-define-keysym #x1001ef1 "uhornbelowdot") ;U+1EF1 LATIN SMALL LETTER U WITH HORN AND DOT BELOW (cl-define-keysym #x1001ef4 "Ybelowdot") ;U+1EF4 LATIN CAPITAL LETTER Y WITH DOT BELOW (cl-define-keysym #x1001ef5 "ybelowdot") ;U+1EF5 LATIN SMALL LETTER Y WITH DOT BELOW (cl-define-keysym #x1001ef6 "Yhook") ;U+1EF6 LATIN CAPITAL LETTER Y WITH HOOK ABOVE (cl-define-keysym #x1001ef7 "yhook") ;U+1EF7 LATIN SMALL LETTER Y WITH HOOK ABOVE (cl-define-keysym #x1001ef8 "Ytilde") ;U+1EF8 LATIN CAPITAL LETTER Y WITH TILDE (cl-define-keysym #x1001ef9 "ytilde") ;U+1EF9 LATIN SMALL LETTER Y WITH TILDE (cl-define-keysym #x10001a0 "Ohorn") ;U+01A0 LATIN CAPITAL LETTER O WITH HORN (cl-define-keysym #x10001a1 "ohorn") ;U+01A1 LATIN SMALL LETTER O WITH HORN (cl-define-keysym #x10001af "Uhorn") ;U+01AF LATIN CAPITAL LETTER U WITH HORN (cl-define-keysym #x10001b0 "uhorn") ;U+01B0 LATIN SMALL LETTER U WITH HORN (cl-define-keysym #x10020a0 "EcuSign") ;U+20A0 EURO-CURRENCY SIGN (cl-define-keysym #x10020a1 "ColonSign") ;U+20A1 COLON SIGN (cl-define-keysym #x10020a2 "CruzeiroSign") ;U+20A2 CRUZEIRO SIGN (cl-define-keysym #x10020a3 "FFrancSign") ;U+20A3 FRENCH FRANC SIGN (cl-define-keysym #x10020a4 "LiraSign") ;U+20A4 LIRA SIGN (cl-define-keysym #x10020a5 "MillSign") ;U+20A5 MILL SIGN (cl-define-keysym #x10020a6 "NairaSign") ;U+20A6 NAIRA SIGN (cl-define-keysym #x10020a7 "PesetaSign") ;U+20A7 PESETA SIGN (cl-define-keysym #x10020a8 "RupeeSign") ;U+20A8 RUPEE SIGN (cl-define-keysym #x10020a9 "WonSign") ;U+20A9 WON SIGN (cl-define-keysym #x10020aa "NewSheqelSign") ;U+20AA NEW SHEQEL SIGN (cl-define-keysym #x10020ab "DongSign") ;U+20AB DONG SIGN (cl-define-keysym #x20ac "EuroSign") ;U+20AC EURO SIGN (cl-define-keysym #x1002070 "zerosuperior") ;U+2070 SUPERSCRIPT ZERO (cl-define-keysym #x1002074 "foursuperior") ;U+2074 SUPERSCRIPT FOUR (cl-define-keysym #x1002075 "fivesuperior") ;U+2075 SUPERSCRIPT FIVE (cl-define-keysym #x1002076 "sixsuperior") ;U+2076 SUPERSCRIPT SIX (cl-define-keysym #x1002077 "sevensuperior") ;U+2077 SUPERSCRIPT SEVEN (cl-define-keysym #x1002078 "eightsuperior") ;U+2078 SUPERSCRIPT EIGHT (cl-define-keysym #x1002079 "ninesuperior") ;U+2079 SUPERSCRIPT NINE (cl-define-keysym #x1002080 "zerosubscript") ;U+2080 SUBSCRIPT ZERO (cl-define-keysym #x1002081 "onesubscript") ;U+2081 SUBSCRIPT ONE (cl-define-keysym #x1002082 "twosubscript") ;U+2082 SUBSCRIPT TWO (cl-define-keysym #x1002083 "threesubscript") ;U+2083 SUBSCRIPT THREE (cl-define-keysym #x1002084 "foursubscript") ;U+2084 SUBSCRIPT FOUR (cl-define-keysym #x1002085 "fivesubscript") ;U+2085 SUBSCRIPT FIVE (cl-define-keysym #x1002086 "sixsubscript") ;U+2086 SUBSCRIPT SIX (cl-define-keysym #x1002087 "sevensubscript") ;U+2087 SUBSCRIPT SEVEN (cl-define-keysym #x1002088 "eightsubscript") ;U+2088 SUBSCRIPT EIGHT (cl-define-keysym #x1002089 "ninesubscript") ;U+2089 SUBSCRIPT NINE (cl-define-keysym #x1002202 "partdifferential") ;U+2202 PARTIAL DIFFERENTIAL (cl-define-keysym #x1002205 "emptyset") ;U+2205 NULL SET (cl-define-keysym #x1002208 "elementof") ;U+2208 ELEMENT OF (cl-define-keysym #x1002209 "notelementof") ;U+2209 NOT AN ELEMENT OF (cl-define-keysym #x100220B "containsas") ;U+220B CONTAINS AS MEMBER (cl-define-keysym #x100221A "squareroot") ;U+221A SQUARE ROOT (cl-define-keysym #x100221B "cuberoot") ;U+221B CUBE ROOT (cl-define-keysym #x100221C "fourthroot") ;U+221C FOURTH ROOT (cl-define-keysym #x100222C "dintegral") ;U+222C DOUBLE INTEGRAL (cl-define-keysym #x100222D "tintegral") ;U+222D TRIPLE INTEGRAL (cl-define-keysym #x1002235 "because") ;U+2235 BECAUSE (cl-define-keysym #x1002248 "approxeq") ;U+2245 ALMOST EQUAL TO (cl-define-keysym #x1002247 "notapproxeq") ;U+2247 NOT ALMOST EQUAL TO (cl-define-keysym #x1002262 "notidentical") ;U+2262 NOT IDENTICAL TO (cl-define-keysym #x1002263 "stricteq") ;U+2263 STRICTLY EQUIVALENT TO ;; A bunch of extended keysyms (cl-define-keysym #x100000A8 "hpmute_acute") (cl-define-keysym #x100000A9 "hpmute_grave") (cl-define-keysym #x100000AA "hpmute_asciicircum") (cl-define-keysym #x100000AB "hpmute_diaeresis") (cl-define-keysym #x100000AC "hpmute_asciitilde") (cl-define-keysym #x100000AF "hplira") (cl-define-keysym #x100000BE "hpguilder") (cl-define-keysym #x100000EE "hpYdiaeresis") (cl-define-keysym #x100000EE "hpIO") (cl-define-keysym #x100000F6 "hplongminus") (cl-define-keysym #x100000FC "hpblock") (cl-define-keysym #x1000FF00 "apLineDel") (cl-define-keysym #x1000FF01 "apCharDel") (cl-define-keysym #x1000FF02 "apCopy") (cl-define-keysym #x1000FF03 "apCut") (cl-define-keysym #x1000FF04 "apPaste") (cl-define-keysym #x1000FF05 "apMove") (cl-define-keysym #x1000FF06 "apGrow") (cl-define-keysym #x1000FF07 "apCmd") (cl-define-keysym #x1000FF08 "apShell") (cl-define-keysym #x1000FF09 "apLeftBar") (cl-define-keysym #x1000FF0A "apRightBar") (cl-define-keysym #x1000FF0B "apLeftBox") (cl-define-keysym #x1000FF0C "apRightBox") (cl-define-keysym #x1000FF0D "apUpBox") (cl-define-keysym #x1000FF0E "apDownBox") (cl-define-keysym #x1000FF0F "apPop") (cl-define-keysym #x1000FF10 "apRead") (cl-define-keysym #x1000FF11 "apEdit") (cl-define-keysym #x1000FF12 "apSave") (cl-define-keysym #x1000FF13 "apExit") (cl-define-keysym #x1000FF14 "apRepeat") (cl-define-keysym #x1000FF48 "hpModelock1") (cl-define-keysym #x1000FF49 "hpModelock2") (cl-define-keysym #x1000FF6C "hpReset") (cl-define-keysym #x1000FF6D "hpSystem") (cl-define-keysym #x1000FF6E "hpUser") (cl-define-keysym #x1000FF6F "hpClearLine") (cl-define-keysym #x1000FF70 "hpInsertLine") (cl-define-keysym #x1000FF71 "hpDeleteLine") (cl-define-keysym #x1000FF72 "hpInsertChar") (cl-define-keysym #x1000FF73 "hpDeleteChar") (cl-define-keysym #x1000FF74 "hpBackTab") (cl-define-keysym #x1000FF75 "hpKP_BackTab") (cl-define-keysym #x1000FFA8 "apKP_parenleft") (cl-define-keysym #x1000FFA9 "apKP_parenright") (cl-define-keysym #x10004001 "I2ND_FUNC_L") (cl-define-keysym #x10004002 "I2ND_FUNC_R") (cl-define-keysym #x10004003 "IREMOVE") (cl-define-keysym #x10004004 "IREPEAT") (cl-define-keysym #x10004101 "IA1") (cl-define-keysym #x10004102 "IA2") (cl-define-keysym #x10004103 "IA3") (cl-define-keysym #x10004104 "IA4") (cl-define-keysym #x10004105 "IA5") (cl-define-keysym #x10004106 "IA6") (cl-define-keysym #x10004107 "IA7") (cl-define-keysym #x10004108 "IA8") (cl-define-keysym #x10004109 "IA9") (cl-define-keysym #x1000410A "IA10") (cl-define-keysym #x1000410B "IA11") (cl-define-keysym #x1000410C "IA12") (cl-define-keysym #x1000410D "IA13") (cl-define-keysym #x1000410E "IA14") (cl-define-keysym #x1000410F "IA15") (cl-define-keysym #x10004201 "IB1") (cl-define-keysym #x10004202 "IB2") (cl-define-keysym #x10004203 "IB3") (cl-define-keysym #x10004204 "IB4") (cl-define-keysym #x10004205 "IB5") (cl-define-keysym #x10004206 "IB6") (cl-define-keysym #x10004207 "IB7") (cl-define-keysym #x10004208 "IB8") (cl-define-keysym #x10004209 "IB9") (cl-define-keysym #x1000420A "IB10") (cl-define-keysym #x1000420B "IB11") (cl-define-keysym #x1000420C "IB12") (cl-define-keysym #x1000420D "IB13") (cl-define-keysym #x1000420E "IB14") (cl-define-keysym #x1000420F "IB15") (cl-define-keysym #x10004210 "IB16") (cl-define-keysym #x1000FF00 "DRemove") (cl-define-keysym #x1000FEB0 "Dring_accent") (cl-define-keysym #x1000FE5E "Dcircumflex_accent") (cl-define-keysym #x1000FE2C "Dcedilla_accent") (cl-define-keysym #x1000FE27 "Dacute_accent") (cl-define-keysym #x1000FE60 "Dgrave_accent") (cl-define-keysym #x1000FE7E "Dtilde") (cl-define-keysym #x1000FE22 "Ddiaeresis") (cl-define-keysym #x1004FF02 "osfCopy") (cl-define-keysym #x1004FF03 "osfCut") (cl-define-keysym #x1004FF04 "osfPaste") (cl-define-keysym #x1004FF07 "osfBackTab") (cl-define-keysym #x1004FF08 "osfBackSpace") (cl-define-keysym #x1004FF0B "osfClear") (cl-define-keysym #x1004FF1B "osfEscape") (cl-define-keysym #x1004FF31 "osfAddMode") (cl-define-keysym #x1004FF32 "osfPrimaryPaste") (cl-define-keysym #x1004FF33 "osfQuickPaste") (cl-define-keysym #x1004FF40 "osfPageLeft") (cl-define-keysym #x1004FF41 "osfPageUp") (cl-define-keysym #x1004FF42 "osfPageDown") (cl-define-keysym #x1004FF43 "osfPageRight") (cl-define-keysym #x1004FF44 "osfActivate") (cl-define-keysym #x1004FF45 "osfMenuBar") (cl-define-keysym #x1004FF51 "osfLeft") (cl-define-keysym #x1004FF52 "osfUp") (cl-define-keysym #x1004FF53 "osfRight") (cl-define-keysym #x1004FF54 "osfDown") (cl-define-keysym #x1004FF55 "osfPrior") (cl-define-keysym #x1004FF56 "osfNext") (cl-define-keysym #x1004FF57 "osfEndLine") (cl-define-keysym #x1004FF58 "osfBeginLine") (cl-define-keysym #x1004FF59 "osfEndData") (cl-define-keysym #x1004FF5A "osfBeginData") (cl-define-keysym #x1004FF5B "osfPrevMenu") (cl-define-keysym #x1004FF5C "osfNextMenu") (cl-define-keysym #x1004FF5D "osfPrevField") (cl-define-keysym #x1004FF5E "osfNextField") (cl-define-keysym #x1004FF60 "osfSelect") (cl-define-keysym #x1004FF63 "osfInsert") (cl-define-keysym #x1004FF65 "osfUndo") (cl-define-keysym #x1004FF67 "osfMenu") (cl-define-keysym #x1004FF69 "osfCancel") (cl-define-keysym #x1004FF6A "osfHelp") (cl-define-keysym #x1004FF71 "osfSelectAll") (cl-define-keysym #x1004FF72 "osfDeselectAll") (cl-define-keysym #x1004FF73 "osfReselect") (cl-define-keysym #x1004FF74 "osfExtend") (cl-define-keysym #x1004FF78 "osfRestore") (cl-define-keysym #x1004FF7E "osfSwitchDirection") (cl-define-keysym #x1004FFF5 "osfPriorMinor") (cl-define-keysym #x1004FFF6 "osfNextMinor") (cl-define-keysym #x1004FFF7 "osfRightLine") (cl-define-keysym #x1004FFF8 "osfLeftLine") (cl-define-keysym #x1004FFFF "osfDelete") (cl-define-keysym #x1005FF00 "SunFA_Grave") (cl-define-keysym #x1005FF01 "SunFA_Circum") (cl-define-keysym #x1005FF02 "SunFA_Tilde") (cl-define-keysym #x1005FF03 "SunFA_Acute") (cl-define-keysym #x1005FF04 "SunFA_Diaeresis") (cl-define-keysym #x1005FF05 "SunFA_Cedilla") (cl-define-keysym #x1005FF10 "SunF36") (cl-define-keysym #x1005FF11 "SunF37") (cl-define-keysym #x1005FF60 "SunSys_Req") (cl-define-keysym #x1005FF70 "SunProps") (cl-define-keysym #x1005FF71 "SunFront") (cl-define-keysym #x1005FF72 "SunCopy") (cl-define-keysym #x1005FF73 "SunOpen") (cl-define-keysym #x1005FF74 "SunPaste") (cl-define-keysym #x1005FF75 "SunCut") (cl-define-keysym #x1005FF76 "SunPowerSwitch") (cl-define-keysym #x1005FF77 "SunAudioLowerVolume") (cl-define-keysym #x1005FF78 "SunAudioMute") (cl-define-keysym #x1005FF79 "SunAudioRaiseVolume") (cl-define-keysym #x1005FF7A "SunVideoDegauss") (cl-define-keysym #x1005FF7B "SunVideoLowerBrightness") (cl-define-keysym #x1005FF7C "SunVideoRaiseBrightness") (cl-define-keysym #x1005FF7D "SunPowerSwitchShift") (cl-define-keysym #xFF20 "SunCompose") (cl-define-keysym #xFF55 "SunPageUp") (cl-define-keysym #xFF56 "SunPageDown") (cl-define-keysym #xFF61 "SunPrint_Screen") (cl-define-keysym #xFF65 "SunUndo") (cl-define-keysym #xFF66 "SunAgain") (cl-define-keysym #xFF68 "SunFind") (cl-define-keysym #xFF69 "SunStop") (cl-define-keysym #xFF7E "SunAltGraph") (cl-define-keysym #x1006FF00 "WYSetup") (cl-define-keysym #x1006FF00 "ncdSetup") (cl-define-keysym #x10070001 "XeroxPointerButton1") (cl-define-keysym #x10070002 "XeroxPointerButton2") (cl-define-keysym #x10070003 "XeroxPointerButton3") (cl-define-keysym #x10070004 "XeroxPointerButton4") (cl-define-keysym #x10070005 "XeroxPointerButton5") (cl-define-keysym #x1008FF01 "XF86ModeLock") (cl-define-keysym #x1008FF10 "XF86Standby") (cl-define-keysym #x1008FF11 "XF86AudioLowerVolume") (cl-define-keysym #x1008FF12 "XF86AudioMute") (cl-define-keysym #x1008FF13 "XF86AudioRaiseVolume") (cl-define-keysym #x1008FF14 "XF86AudioPlay") (cl-define-keysym #x1008FF15 "XF86AudioStop") (cl-define-keysym #x1008FF16 "XF86AudioPrev") (cl-define-keysym #x1008FF17 "XF86AudioNext") (cl-define-keysym #x1008FF18 "XF86HomePage") (cl-define-keysym #x1008FF19 "XF86Mail") (cl-define-keysym #x1008FF1A "XF86Start") (cl-define-keysym #x1008FF1B "XF86Search") (cl-define-keysym #x1008FF1C "XF86AudioRecord") (cl-define-keysym #x1008FF1D "XF86Calculator") (cl-define-keysym #x1008FF1E "XF86Memo") (cl-define-keysym #x1008FF1F "XF86ToDoList") (cl-define-keysym #x1008FF20 "XF86Calendar") (cl-define-keysym #x1008FF21 "XF86PowerDown") (cl-define-keysym #x1008FF22 "XF86ContrastAdjust") (cl-define-keysym #x1008FF23 "XF86RockerUp") (cl-define-keysym #x1008FF24 "XF86RockerDown") (cl-define-keysym #x1008FF25 "XF86RockerEnter") (cl-define-keysym #x1008FF26 "XF86Back") (cl-define-keysym #x1008FF27 "XF86Forward") (cl-define-keysym #x1008FF28 "XF86Stop") (cl-define-keysym #x1008FF29 "XF86Refresh") (cl-define-keysym #x1008FF2A "XF86PowerOff") (cl-define-keysym #x1008FF2B "XF86WakeUp") (cl-define-keysym #x1008FF2C "XF86Eject") (cl-define-keysym #x1008FF2D "XF86ScreenSaver") (cl-define-keysym #x1008FF2E "XF86WWW") (cl-define-keysym #x1008FF2F "XF86Sleep") (cl-define-keysym #x1008FF30 "XF86Favorites") (cl-define-keysym #x1008FF31 "XF86AudioPause") (cl-define-keysym #x1008FF32 "XF86AudioMedia") (cl-define-keysym #x1008FF33 "XF86MyComputer") (cl-define-keysym #x1008FF34 "XF86VendorHome") (cl-define-keysym #x1008FF35 "XF86LightBulb") (cl-define-keysym #x1008FF36 "XF86Shop") (cl-define-keysym #x1008FF37 "XF86History") (cl-define-keysym #x1008FF38 "XF86OpenURL") (cl-define-keysym #x1008FF39 "XF86AddFavorite") (cl-define-keysym #x1008FF3A "XF86HotLinks") (cl-define-keysym #x1008FF3B "XF86BrightnessAdjust") (cl-define-keysym #x1008FF3C "XF86Finance") (cl-define-keysym #x1008FF3D "XF86Community") (cl-define-keysym #x1008FF3E "XF86AudioRewind") (cl-define-keysym #x1008FF3F "XF86BackForward") (cl-define-keysym #x1008FF40 "XF86Launch0") (cl-define-keysym #x1008FF41 "XF86Launch1") (cl-define-keysym #x1008FF42 "XF86Launch2") (cl-define-keysym #x1008FF43 "XF86Launch3") (cl-define-keysym #x1008FF44 "XF86Launch4") (cl-define-keysym #x1008FF45 "XF86Launch5") (cl-define-keysym #x1008FF46 "XF86Launch6") (cl-define-keysym #x1008FF47 "XF86Launch7") (cl-define-keysym #x1008FF48 "XF86Launch8") (cl-define-keysym #x1008FF49 "XF86Launch9") (cl-define-keysym #x1008FF4A "XF86LaunchA") (cl-define-keysym #x1008FF4B "XF86LaunchB") (cl-define-keysym #x1008FF4C "XF86LaunchC") (cl-define-keysym #x1008FF4D "XF86LaunchD") (cl-define-keysym #x1008FF4E "XF86LaunchE") (cl-define-keysym #x1008FF4F "XF86LaunchF") (cl-define-keysym #x1008FF50 "XF86ApplicationLeft") (cl-define-keysym #x1008FF51 "XF86ApplicationRight") (cl-define-keysym #x1008FF52 "XF86Book") (cl-define-keysym #x1008FF53 "XF86CD") (cl-define-keysym #x1008FF54 "XF86Calculater") (cl-define-keysym #x1008FF55 "XF86Clear") (cl-define-keysym #x1008FF56 "XF86Close") (cl-define-keysym #x1008FF57 "XF86Copy") (cl-define-keysym #x1008FF58 "XF86Cut") (cl-define-keysym #x1008FF59 "XF86Display") (cl-define-keysym #x1008FF5A "XF86DOS") (cl-define-keysym #x1008FF5B "XF86Documents") (cl-define-keysym #x1008FF5C "XF86Excel") (cl-define-keysym #x1008FF5D "XF86Explorer") (cl-define-keysym #x1008FF5E "XF86Game") (cl-define-keysym #x1008FF5F "XF86Go") (cl-define-keysym #x1008FF60 "XF86iTouch") (cl-define-keysym #x1008FF61 "XF86LogOff") (cl-define-keysym #x1008FF62 "XF86Market") (cl-define-keysym #x1008FF63 "XF86Meeting") (cl-define-keysym #x1008FF65 "XF86MenuKB") (cl-define-keysym #x1008FF66 "XF86MenuPB") (cl-define-keysym #x1008FF67 "XF86MySites") (cl-define-keysym #x1008FF68 "XF86New") (cl-define-keysym #x1008FF69 "XF86News") (cl-define-keysym #x1008FF6A "XF86OfficeHome") (cl-define-keysym #x1008FF6B "XF86Open") (cl-define-keysym #x1008FF6C "XF86Option") (cl-define-keysym #x1008FF6D "XF86Paste") (cl-define-keysym #x1008FF6E "XF86Phone") (cl-define-keysym #x1008FF70 "XF86Q") (cl-define-keysym #x1008FF72 "XF86Reply") (cl-define-keysym #x1008FF73 "XF86Reload") (cl-define-keysym #x1008FF74 "XF86RotateWindows") (cl-define-keysym #x1008FF75 "XF86RotationPB") (cl-define-keysym #x1008FF76 "XF86RotationKB") (cl-define-keysym #x1008FF77 "XF86Save") (cl-define-keysym #x1008FF78 "XF86ScrollUp") (cl-define-keysym #x1008FF79 "XF86ScrollDown") (cl-define-keysym #x1008FF7A "XF86ScrollClick") (cl-define-keysym #x1008FF7B "XF86Send") (cl-define-keysym #x1008FF7C "XF86Spell") (cl-define-keysym #x1008FF7D "XF86SplitScreen") (cl-define-keysym #x1008FF7E "XF86Support") (cl-define-keysym #x1008FF7F "XF86TaskPane") (cl-define-keysym #x1008FF80 "XF86Terminal") (cl-define-keysym #x1008FF81 "XF86Tools") (cl-define-keysym #x1008FF82 "XF86Travel") (cl-define-keysym #x1008FF84 "XF86UserPB") (cl-define-keysym #x1008FF85 "XF86User1KB") (cl-define-keysym #x1008FF86 "XF86User2KB") (cl-define-keysym #x1008FF87 "XF86Video") (cl-define-keysym #x1008FF88 "XF86WheelButton") (cl-define-keysym #x1008FF89 "XF86Word") (cl-define-keysym #x1008FF8A "XF86Xfer") (cl-define-keysym #x1008FF8B "XF86ZoomIn") (cl-define-keysym #x1008FF8C "XF86ZoomOut") (cl-define-keysym #x1008FF8D "XF86Away") (cl-define-keysym #x1008FF8E "XF86Messenger") (cl-define-keysym #x1008FF8F "XF86WebCam") (cl-define-keysym #x1008FF90 "XF86MailForward") (cl-define-keysym #x1008FF91 "XF86Pictures") (cl-define-keysym #x1008FF92 "XF86Music") (cl-define-keysym #x1008FE01 "XF86_Switch_VT_1") (cl-define-keysym #x1008FE02 "XF86_Switch_VT_2") (cl-define-keysym #x1008FE03 "XF86_Switch_VT_3") (cl-define-keysym #x1008FE04 "XF86_Switch_VT_4") (cl-define-keysym #x1008FE05 "XF86_Switch_VT_5") (cl-define-keysym #x1008FE06 "XF86_Switch_VT_6") (cl-define-keysym #x1008FE07 "XF86_Switch_VT_7") (cl-define-keysym #x1008FE08 "XF86_Switch_VT_8") (cl-define-keysym #x1008FE09 "XF86_Switch_VT_9") (cl-define-keysym #x1008FE0A "XF86_Switch_VT_10") (cl-define-keysym #x1008FE0B "XF86_Switch_VT_11") (cl-define-keysym #x1008FE0C "XF86_Switch_VT_12") (cl-define-keysym #x1008FE20 "XF86_Ungrab") (cl-define-keysym #x1008FE21 "XF86_ClearGrab") (cl-define-keysym #x1008FE22 "XF86_Next_VMode") (cl-define-keysym #x1008FE23 "XF86_Prev_VMode") (cl-define-keysym #x100000A8 "usldead_acute") (cl-define-keysym #x100000A9 "usldead_grave") (cl-define-keysym #x100000AB "usldead_diaeresis") (cl-define-keysym #x100000AA "usldead_asciicircum") (cl-define-keysym #x100000AC "usldead_asciitilde") (cl-define-keysym #x1000FE2C "usldead_cedilla") (cl-define-keysym #x1000FEB0 "usldead_ring") ;; For convenience (cl-define-keysym #xff55 "Page_Up") (cl-define-keysym #xff56 "Page_Down") clfswm-20111015.git51b0a02/src/menu-def.lisp000066400000000000000000000246411164636077000201170ustar00rootroot00000000000000;;; -------------------------------------------------------------------------- ;;; CLFSWM - FullScreen Window Manager ;;; ;;; -------------------------------------------------------------------------- ;;; Documentation: Menu definitions ;;; ;;; Note: Mod-1 is the Alt or Meta key, Mod-2 is the Numlock key. ;;; -------------------------------------------------------------------------- ;;; ;;; (C) 2011 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;; ;;; -------------------------------------------------------------------------- (in-package :clfswm) (init-menu) ;;; Here is a small example of menu manipulation: ;;(add-menu-key 'main "a" 'help-on-second-mode) ;;(add-menu-key 'main "c" 'help-on-clfswm) ;; ;;(add-sub-menu 'main "p" 'plop "A sub menu") ;; ;;(add-menu-key 'plop "a" 'help-on-clfswm) ;;(add-menu-key 'plop "b" 'help-on-second-mode) ;;(add-menu-key 'plop "d" 'help-on-second-mode) ;;(del-menu-key 'main "p") ;;(del-menu-value 'plop 'help-on-main-mode) ;;(del-sub-menu 'main 'plop) ;;(define-second-key ("a") 'open-menu) (add-sub-menu 'main "F1" 'help-menu "Help menu") (add-sub-menu 'main "d" 'standard-menu "Standard menu") (add-sub-menu 'main "c" 'child-menu "Child menu") (add-sub-menu 'main "f" 'frame-menu "Frame menu") (add-sub-menu 'main "w" 'window-menu "Window menu") (add-sub-menu 'main "s" 'selection-menu "Selection menu") (add-sub-menu 'main "n" 'action-by-name-menu "Action by name menu") (add-sub-menu 'main "u" 'action-by-number-menu "Action by number menu") (add-sub-menu 'main "y" 'utility-menu "Utility menu") (add-sub-menu 'main "o" 'configuration-menu "Configuration menu") (add-sub-menu 'main "m" 'clfswm-menu "CLFSWM menu") (update-menus (find-menu 'standard-menu)) (add-menu-key 'help-menu "a" 'show-first-aid-kit) (add-menu-key 'help-menu "h" 'show-global-key-binding) (add-menu-key 'help-menu "b" 'show-main-mode-key-binding) (add-menu-key 'help-menu "s" 'show-second-mode-key-binding) (add-menu-key 'help-menu "r" 'show-circulate-mode-key-binding) (add-menu-key 'help-menu "e" 'show-expose-window-mode-key-binding) (add-menu-key 'help-menu "c" 'show-corner-help) (add-menu-key 'help-menu "g" 'show-config-variable) (add-menu-key 'help-menu "d" 'show-date) (add-menu-key 'help-menu "p" 'show-cpu-proc) (add-menu-key 'help-menu "m" 'show-mem-proc) (add-menu-key 'help-menu "v" 'show-version) (add-menu-key 'child-menu "r" 'rename-current-child) (add-menu-key 'child-menu "e" 'ensure-unique-name) (add-menu-key 'child-menu "n" 'ensure-unique-number) (add-menu-key 'child-menu "Delete" 'delete-current-child) (add-menu-key 'child-menu "X" 'remove-current-child) (add-menu-key 'child-menu "h" 'hide-current-child) (add-menu-key 'child-menu "u" 'unhide-a-child) (add-menu-key 'child-menu "f" 'unhide-a-child-from-all-frames) (add-menu-key 'child-menu "a" 'unhide-all-children) (add-menu-key 'child-menu "Page_Up" 'frame-lower-child) (add-menu-key 'child-menu "Page_Down" 'frame-raise-child) (add-sub-menu 'frame-menu "a" 'frame-adding-menu "Adding frame menu") (add-sub-menu 'frame-menu "l" 'frame-layout-menu "Frame layout menu") (add-sub-menu 'frame-menu "n" 'frame-nw-hook-menu "Frame new window hook menu") (add-sub-menu 'frame-menu "m" 'frame-movement-menu "Frame movement menu") (add-sub-menu 'frame-menu "f" 'frame-focus-policy "Frame focus policy menu") (add-sub-menu 'frame-menu "w" 'frame-managed-window-menu "Managed window type menu") (add-sub-menu 'frame-menu "u" 'frame-unmanaged-window-menu "Unmanaged window behaviour") (add-sub-menu 'frame-menu "s" 'frame-miscellaneous-menu "Frame miscallenous menu") (add-menu-key 'frame-menu "x" 'frame-toggle-maximize) (add-menu-key 'frame-adding-menu "a" 'add-default-frame) (add-menu-key 'frame-adding-menu "p" 'add-placed-frame) (add-sub-menu 'frame-movement-menu "p" 'frame-pack-menu "Frame pack menu") (add-sub-menu 'frame-movement-menu "f" 'frame-fill-menu "Frame fill menu") (add-sub-menu 'frame-movement-menu "r" 'frame-resize-menu "Frame resize menu") (add-menu-key 'frame-movement-menu "c" 'center-current-frame) (add-menu-key 'frame-movement-menu "Right" 'with-movement-select-next-brother) (add-menu-key 'frame-movement-menu "Left" 'with-movement-select-previous-brother) (add-menu-key 'frame-movement-menu "Up" 'with-movement-select-next-level) (add-menu-key 'frame-movement-menu "Down" 'with-movement-select-previous-level) (add-menu-key 'frame-movement-menu "Tab" 'with-movement-select-next-child) (add-menu-key 'frame-pack-menu "Up" 'current-frame-pack-up) (add-menu-key 'frame-pack-menu "Down" 'current-frame-pack-down) (add-menu-key 'frame-pack-menu "Left" 'current-frame-pack-left) (add-menu-key 'frame-pack-menu "Right" 'current-frame-pack-right) (add-menu-key 'frame-fill-menu "Up" 'current-frame-fill-up) (add-menu-key 'frame-fill-menu "Down" 'current-frame-fill-down) (add-menu-key 'frame-fill-menu "Left" 'current-frame-fill-left) (add-menu-key 'frame-fill-menu "Right" 'current-frame-fill-right) (add-menu-key 'frame-fill-menu "a" 'current-frame-fill-all-dir) (add-menu-key 'frame-fill-menu "v" 'current-frame-fill-vertical) (add-menu-key 'frame-fill-menu "h" 'current-frame-fill-horizontal) (add-menu-key 'frame-resize-menu "Up" 'current-frame-resize-up) (add-menu-key 'frame-resize-menu "Down" 'current-frame-resize-down) (add-menu-key 'frame-resize-menu "Left" 'current-frame-resize-left) (add-menu-key 'frame-resize-menu "Right" 'current-frame-resize-right) (add-menu-key 'frame-resize-menu "a" 'current-frame-resize-all-dir) (add-menu-key 'frame-resize-menu "m" 'current-frame-resize-all-dir-minimal) (add-menu-comment 'frame-focus-policy "-=- For the current frame -=-") (add-menu-key 'frame-focus-policy "a" 'current-frame-set-click-focus-policy) (add-menu-key 'frame-focus-policy "b" 'current-frame-set-sloppy-focus-policy) (add-menu-key 'frame-focus-policy "c" 'current-frame-set-sloppy-strict-focus-policy) (add-menu-key 'frame-focus-policy "d" 'current-frame-set-sloppy-select-policy) (add-menu-comment 'frame-focus-policy "-=- For all frames -=-") (add-menu-key 'frame-focus-policy "e" 'all-frames-set-click-focus-policy) (add-menu-key 'frame-focus-policy "f" 'all-frames-set-sloppy-focus-policy) (add-menu-key 'frame-focus-policy "g" 'all-frames-set-sloppy-strict-focus-policy) (add-menu-key 'frame-focus-policy "h" 'all-frames-set-sloppy-select-policy) (add-menu-key 'frame-managed-window-menu "m" 'current-frame-manage-window-type) (add-menu-key 'frame-managed-window-menu "a" 'current-frame-manage-all-window-type) (add-menu-key 'frame-managed-window-menu "n" 'current-frame-manage-only-normal-window-type) (add-menu-key 'frame-managed-window-menu "u" 'current-frame-manage-no-window-type) (add-menu-key 'frame-unmanaged-window-menu "s" 'set-show-unmanaged-window) (add-menu-key 'frame-unmanaged-window-menu "h" 'set-hide-unmanaged-window) (add-menu-key 'frame-unmanaged-window-menu "d" 'set-default-hide-unmanaged-window) (add-menu-key 'frame-unmanaged-window-menu "w" 'set-globally-show-unmanaged-window) (add-menu-key 'frame-unmanaged-window-menu "i" 'set-globally-hide-unmanaged-window) (add-menu-key 'frame-miscellaneous-menu "s" 'show-all-frames-info) (add-menu-key 'frame-miscellaneous-menu "a" 'hide-all-frames-info) (add-menu-key 'frame-miscellaneous-menu "h" 'hide-current-frame-window) (add-menu-key 'frame-miscellaneous-menu "w" 'show-current-frame-window) (add-menu-key 'frame-miscellaneous-menu "u" 'renumber-current-frame) (add-menu-key 'frame-miscellaneous-menu "x" 'explode-current-frame) (add-menu-key 'frame-miscellaneous-menu "i" 'implode-current-frame) (add-menu-key 'window-menu "i" 'display-current-window-info) (add-menu-key 'window-menu "f" 'force-window-in-frame) (add-menu-key 'window-menu "c" 'force-window-center-in-frame) (add-menu-key 'window-menu "m" 'manage-current-window) (add-menu-key 'window-menu "u" 'unmanage-current-window) (add-menu-key 'window-menu "a" 'adapt-current-frame-to-window-hints) (add-menu-key 'window-menu "w" 'adapt-current-frame-to-window-width-hint) (add-menu-key 'window-menu "h" 'adapt-current-frame-to-window-height-hint) (add-menu-key 'selection-menu "x" 'cut-current-child) (add-menu-key 'selection-menu "c" 'copy-current-child) (add-menu-key 'selection-menu "v" 'paste-selection) (add-menu-key 'selection-menu "p" 'paste-selection-no-clear) (add-menu-key 'selection-menu "Delete" 'remove-current-child) (add-menu-key 'selection-menu "z" 'clear-selection) (add-menu-key 'action-by-name-menu "f" 'focus-frame-by-name) (add-menu-key 'action-by-name-menu "o" 'open-frame-by-name) (add-menu-key 'action-by-name-menu "d" 'delete-frame-by-name) (add-menu-key 'action-by-name-menu "m" 'move-current-child-by-name) (add-menu-key 'action-by-name-menu "c" 'copy-current-child-by-name) (add-menu-key 'action-by-number-menu "f" 'focus-frame-by-number) (add-menu-key 'action-by-number-menu "o" 'open-frame-by-number) (add-menu-key 'action-by-number-menu "d" 'delete-frame-by-number) (add-menu-key 'action-by-number-menu "m" 'move-current-child-by-number) (add-menu-key 'action-by-number-menu "c" 'copy-current-child-by-number) (add-menu-key 'utility-menu "i" 'identify-key) (add-menu-key 'utility-menu "colon" 'eval-from-query-string) (add-menu-key 'utility-menu "exclam" 'run-program-from-query-string) (add-sub-menu 'utility-menu "o" 'other-window-manager-menu "Other window manager menu") (add-menu-key 'other-window-manager-menu "x" 'run-xterm) (add-menu-key 'other-window-manager-menu "t" 'run-twm) (add-menu-key 'other-window-manager-menu "i" 'run-icewm) (add-menu-key 'other-window-manager-menu "g" 'run-gnome-session) (add-menu-key 'other-window-manager-menu "k" 'run-startkde) (add-menu-key 'other-window-manager-menu "c" 'run-xfce4-session) (add-menu-key 'other-window-manager-menu "l" 'run-lxde) (add-menu-key 'other-window-manager-menu "p" 'run-prompt-wm) (add-menu-key 'clfswm-menu "r" 'reset-clfswm) (add-menu-key 'clfswm-menu "l" 'reload-clfswm) (add-menu-key 'clfswm-menu "x" 'exit-clfswm) clfswm-20111015.git51b0a02/src/my-html.lisp000066400000000000000000000066661164636077000200150ustar00rootroot00000000000000;;; -------------------------------------------------------------------------- ;;; CLFSWM - FullScreen Window Manager ;;; ;;; -------------------------------------------------------------------------- ;;; Documentation: Html generator helper ;;; -------------------------------------------------------------------------- ;;; ;;; (C) 2011 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;; ;;; -------------------------------------------------------------------------- (in-package :common-lisp-user) (defpackage :my-html (:use :common-lisp :tools) (:export :insert-html-doctype :escape-html :produce-html :with-html :produce-html-string)) (in-package :my-html) (defun insert-html-doctype () "") (defun escape-html (string &optional (replace '((">" ">") ("<" "<")))) (if replace (aif (search (caar replace) string) (escape-html (concatenate 'string (subseq string 0 it) (cadar replace) (subseq string (+ it (length (caar replace))))) replace) (escape-html string (cdr replace))) string)) (defun produce-html (tree &optional (level 0) (stream *standard-output*)) (cond ((listp tree) (print-space level stream) (format stream "~(<~A>~)~%" (first tree)) (dolist (subtree (rest tree)) (produce-html subtree (+ 2 level) stream)) (print-space level stream) (format stream "~(~)~%" (if (stringp (first tree)) (subseq (first tree) 0 (position #\Space (first tree))) (first tree)))) (t (print-space level stream) (format stream (if (stringp tree) "~A~%" "~(~A~)~%") tree)))) (defmacro with-html ((&optional (stream t)) &rest rest) `(produce-html ',@rest 0 ,stream)) (defun produce-html-string (tree &optional (level 0)) (with-output-to-string (str) (produce-html tree level str))) (defun test1 () (produce-html `(html (head (title "Plop")) (body (h1 "A title") (h2 "plop") Plop ,(+ 2 2) ,(format nil "Plip=~A" (+ 3 5)) ("a href=\"index.html\"" index) (ul (li "toto") (li "klm")))))) (defun test2 () (with-html () (html (head (title "Plop")) "" (body (h1 "Un titre") (h2 "plop") (ul (li "toto") (li "klm")))))) (defun test3 () (produce-html-string `(html (head (title "Plop")) (body (h1 "A title") (h2 plop) Plop ,(+ 2 2) ,(format nil "Plip=~A" (+ 3 5)) |Foo Bar Baz| ("a href=\"index.html\"" Index) (ul (li "toto") (li "klm")))) 10)) clfswm-20111015.git51b0a02/src/netwm-util.lisp000066400000000000000000000064041164636077000205210ustar00rootroot00000000000000;;; -------------------------------------------------------------------------- ;;; CLFSWM - FullScreen Window Manager ;;; ;;; -------------------------------------------------------------------------- ;;; Documentation: NetWM functions ;;; http://freedesktop.org/wiki/Specifications_2fwm_2dspec ;;; -------------------------------------------------------------------------- ;;; ;;; (C) 2011 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;; ;;; -------------------------------------------------------------------------- (in-package :clfswm) ;;; Client List functions (defun netwm-set-client-list (id-list) (xlib:change-property *root* :_NET_CLIENT_LIST id-list :window 32)) (defun netwm-get-client-list () (xlib:get-property *root* :_NET_CLIENT_LIST)) (defun netwm-add-in-client-list (window) (let ((last-list (netwm-get-client-list))) (pushnew (xlib:window-id window) last-list) (netwm-set-client-list last-list))) (defun netwm-remove-in-client-list (window) (netwm-set-client-list (remove (xlib:window-id window) (netwm-get-client-list)))) ;;; Desktop functions ;; +PHIL (defun netwm-update-desktop-property () ;; (xlib:change-property *root* :_NET_NUMBER_OF_DESKTOPS ;; (list (length *workspace-list*)) :cardinal 32) ;; (xlib:change-property *root* :_NET_DESKTOP_GEOMETRY ;; (list (xlib:screen-width *screen*) ;; (xlib:screen-height *screen*)) ;; :cardinal 32) ;; (xlib:change-property *root* :_NET_DESKTOP_VIEWPORT ;; (list 0 0) :cardinal 32) ;; (xlib:change-property *root* :_NET_CURRENT_DESKTOP ;; (list 1) :cardinal 32) ;;; TODO ;;(xlib:change-property *root* :_NET_DESKTOP_NAMES ;; (list "toto" "klm" "poi") :string 8 :transform #'xlib:char->card8)) ) ;;; Taken from stumpwm (thanks) (defun netwm-set-properties () "Set NETWM properties on the root window of the specified screen. FOCUS-WINDOW is an extra window used for _NET_SUPPORTING_WM_CHECK." ;; _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 *no-focus-window*) :window 32 :transform #'xlib:drawable-id) (xlib:change-property *no-focus-window* :_NET_SUPPORTING_WM_CHECK (list *no-focus-window*) :window 32 :transform #'xlib:drawable-id) (xlib:change-property *no-focus-window* :_NET_WM_NAME "clfswm" :string 8 :transform #'xlib:char->card8) (netwm-update-desktop-property)) clfswm-20111015.git51b0a02/src/package.lisp000066400000000000000000000216771164636077000200200ustar00rootroot00000000000000;;; -------------------------------------------------------------------------- ;;; CLFSWM - FullScreen Window Manager ;;; ;;; -------------------------------------------------------------------------- ;;; Documentation: Package definition ;;; -------------------------------------------------------------------------- ;;; ;;; (C) 2011 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;; ;;; -------------------------------------------------------------------------- (in-package :cl-user) (defpackage clfswm (:use :common-lisp :my-html :tools :version) ;; (:shadow :defun) (:export :main :reload-clfswm :reset-clfswm :exit-clfswm)) (in-package :clfswm) ;;; CONFIG - Compress motion notify ? ;; This variable may be useful to speed up some slow version of CLX. ;; It is particulary useful with CLISP/MIT-CLX (and others). (defconfig *have-to-compress-notify* t nil "Compress event notify? This variable may be useful to speed up some slow version of CLX. It is particulary useful with CLISP/MIT-CLX.") (defconfig *show-root-frame-p* nil nil "Show the root frame information or not") (defconfig *border-size* 1 nil "Windows and frames border size") (defparameter *modifier-alias* '((:alt :mod-1) (:alt-l :mod-1) (:numlock :mod-2) (:super_l :mod-4) (:alt-r :mod-5) (:alt-gr :mod-5) (:capslock :lock)) "Syntax: (modifier-alias effective-modifier)") (defparameter *display* nil) (defparameter *screen* nil) (defparameter *root* nil) (defparameter *no-focus-window* nil) (defconfig *loop-timeout* 0.1 nil "Maximum time (in seconds) to wait before calling *loop-hook*") (defparameter *pixmap-buffer* nil) (defparameter *contrib-dir* "") (defparameter *default-font* nil) ;;(defparameter *default-font-string* "9x15") (defconfig *default-font-string* "fixed" nil "The default font used in clfswm") (defconfig *color-move-window* "DeepPink" 'Main-mode "Color when moving or resizing a windows") (defparameter *child-selection* nil) ;;; CONFIG - Default frame datas (defconfig *default-frame-data* (list '(:tile-size 0.8) '(:tile-space-size 0.1) '(:fast-layout (tile-left-layout tile-layout)) '(:main-layout-windows nil)) nil "Default slots set in frame date") ;;; CONFIG - Default managed window type for a frame ;;; type can be :all, :normal, :transient, :maxsize, :desktop, :dock, :toolbar, :menu, :utility, :splash, :dialog (defconfig *default-managed-type* '(:normal) nil "Default managed window types") ;;(defparameter *default-managed-type* '(:normal :maxsize :transient)) ;;(defparameter *default-managed-type* '(:normal :transient :maxsize :desktop :dock :toolbar :menu :utility :splash :dialog)) ;;(defparameter *default-managed-type* '()) ;;(defparameter *default-managed-type* '(:all)) ;;; CONFIG - Default focus policy (defconfig *default-focus-policy* :click nil "Default mouse focus policy. One of :click, :sloppy, :sloppy-strict or :sloppy-select.") (defstruct child-rect child parent selected-p x y w h) (defclass frame () ((name :initarg :name :accessor frame-name :initform nil) (number :initarg :number :accessor frame-number :initform 0) ;;; Float size between 0 and 1 - Manipulate only this variable and not real size (x :initarg :x :accessor frame-x :initform 0.1) (y :initarg :y :accessor frame-y :initform 0.1) (w :initarg :w :accessor frame-w :initform 0.8) (h :initarg :h :accessor frame-h :initform 0.8) ;;; Real size (integer) in screen size - Don't set directly this variables ;;; they may be recalculated by the layout manager. (rx :initarg :rx :accessor frame-rx :initform 0) (ry :initarg :ry :accessor frame-ry :initform 0) (rw :initarg :rw :accessor frame-rw :initform 800) (rh :initarg :rh :accessor frame-rh :initform 600) (layout :initarg :layout :accessor frame-layout :initform nil :documentation "Layout to display windows on a frame") (nw-hook :initarg :nw-hook :accessor frame-nw-hook :initform nil :documentation "Hook done by the frame when a new window is mapped") (managed-type :initarg :managed-type :accessor frame-managed-type :initform *default-managed-type* :documentation "Managed window type") (forced-managed-window :initarg :forced-managed-window :accessor frame-forced-managed-window :initform nil :documentation "A list of forced managed windows (wm-name or window)") (forced-unmanaged-window :initarg :forced-unmanaged-window :accessor frame-forced-unmanaged-window :initform nil :documentation "A list of forced unmanaged windows (wm-name or window)") (show-window-p :initarg :show-window-p :accessor frame-show-window-p :initform t) (hidden-children :initarg :hidden-children :accessor frame-hidden-children :initform nil :documentation "A list of hidden children") (selected-pos :initarg :selected-pos :accessor frame-selected-pos :initform 0 :documentation "The position in the child list of the selected child") (focus-policy :initarg :focus-ploicy :accessor frame-focus-policy :initform *default-focus-policy*) (window :initarg :window :accessor frame-window :initform nil) (gc :initarg :gc :accessor frame-gc :initform nil) (child :initarg :child :accessor frame-child :initform nil) (data :initarg :data :accessor frame-data :initform *default-frame-data* :documentation "An assoc list to store additional data"))) (defparameter *root-frame* nil "Root of the root - ie the root frame") (defparameter *current-root* nil "The current fullscreen maximized child") (defparameter *current-child* nil "The current child with the focus") (defparameter *main-keys* nil) (defparameter *main-mouse* nil) (defparameter *second-keys* nil) (defparameter *second-mouse* nil) (defparameter *info-keys* nil) (defparameter *info-mouse* nil) (defparameter *query-keys* nil) (defparameter *circulate-keys* nil) (defparameter *circulate-keys-release* nil) (defparameter *expose-keys* nil) (defparameter *expose-mouse* nil) (defparameter *other-window-manager* nil) (defstruct menu name item doc) (defstruct menu-item key value) (defparameter *menu* (make-menu :name 'main :doc "Main menu")) (defconfig *binding-hook* nil 'Hook "Hook executed when keys/buttons are bounds") (defconfig *loop-hook* nil 'Hook "Hook executed on each event loop") (defconfig *main-entrance-hook* nil 'Hook "Hook executed on the main function entrance after loading configuration file and before opening the display.") (defparameter *in-second-mode* nil) ;;; Placement variables. A list of two absolute coordinates ;;; or a function: 'Y-X-placement' for absolute placement or ;;; 'Y-X-child-placement' for child relative placement. ;;; Where Y-X are one of: ;;; ;;; top-left top-middle top-right ;;; middle-left middle-middle middle-right ;;; bottom-left bottom-middle bottom-right ;;; (defconfig *banish-pointer-placement* 'bottom-right-placement 'Placement "Pointer banishment placement") (defconfig *second-mode-placement* 'top-middle-placement 'Placement "Second mode window placement") (defconfig *info-mode-placement* 'top-left-placement 'Placement "Info mode window placement") (defconfig *query-mode-placement* 'top-left-placement 'Placement "Query mode window placement") (defconfig *circulate-mode-placement* 'bottom-middle-placement 'Placement "Circulate mode window placement") (defconfig *expose-mode-placement* 'top-left-child-placement 'Placement "Expose mode window placement (Selection keys position)") (defconfig *notify-window-placement* 'bottom-right-placement 'Placement "Notify window placement") (defconfig *ask-close/kill-placement* 'top-right-placement 'Placement "Ask close/kill window placement") (defconfig *unmanaged-window-placement* 'middle-middle-child-placement 'PLACEMENT "Unmanager window placement") (defparameter *in-process-existing-windows* nil) ;; For debug - redefine defun ;;(shadow :defun) ;;(defmacro defun (name args &body body) ;; `(progn ;; (format t "defun: ~A ~A~%" ',name ',args) ;; (force-output) ;; (cl:defun ,name ,args ;; (handler-case ;; (progn ;; ,@body) ;; (error (c) ;; (format t "New defun: Error in ~A : ~A~%" ',name c) ;; (format t "Root tree=~A~%All windows=~A~%" ;; (xlib:query-tree *root*) (get-all-windows)) ;; (force-output)))))) clfswm-20111015.git51b0a02/src/tools.lisp000066400000000000000000000636021164636077000175570ustar00rootroot00000000000000;;; -------------------------------------------------------------------------- ;;; CLFSWM - FullScreen Window Manager ;;; ;;; -------------------------------------------------------------------------- ;;; Documentation: General tools ;;; -------------------------------------------------------------------------- ;;; ;;; (C) 2011 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;; ;;; -------------------------------------------------------------------------- (in-package :common-lisp-user) (defpackage tools (:use common-lisp) (:export :it :awhen :aif :defconfig :*config-var-table* :configvar-value :configvar-group :config-default-value :config-all-groups :config-group->string :find-in-hash :view-hash-table :copy-hash-table :nfuncall :pfuncall :symbol-search :symb :call-hook :add-hook :remove-hook :clear-timers :add-timer :at :with-timer :process-timers :erase-timer :timer-loop :dbg :dbgnl :dbgc :distance :with-all-internal-symbols :export-all-functions :export-all-variables :export-all-functions-and-variables :ensure-function :empty-string-p :find-common-string :setf/= :create-symbol :number->char :number->string :simple-type-of :repeat-chars :nth-insert :split-string :append-newline-space :expand-newline :ensure-list :ensure-printable :limit-length :ensure-n-elems :begin-with-2-spaces :string-equal-p :find-assoc-word :print-space :escape-string :first-position :find-free-number :date-string :do-execute :do-shell :getenv :uquit :urun-prog :ushell :ush :ushell-loop :cldebug :get-command-line-words :string-to-list :near-position :string-to-list-multichar :list-to-string :list-to-string-list :clean-string :one-in-list :exchange-one-in-list :rotate-list :anti-rotate-list :n-rotate-list :append-formated-list :shuffle-list :parse-integer-in-list :convert-to-number :next-in-list :prev-in-list :find-string :find-all-strings :subst-strings :test-find-string)) (in-package :tools) (setq *random-state* (make-random-state t)) (defmacro awhen (test &body body) `(let ((it ,test)) (when it ,@body))) (defmacro aif (test then &optional else) `(let ((it ,test)) (if it ,then ,else))) ;;; Configuration variables (defstruct configvar value group doc) (defparameter *config-var-table* (make-hash-table :test #'equal)) (defmacro defconfig (name value group doc) `(progn (setf (gethash ',name *config-var-table*) (make-configvar :value ,value :group (or ,group 'Miscellaneous))) (defparameter ,name ,value ,doc))) (defun config-default-value (var) (let ((config (gethash var *config-var-table*))) (when config (configvar-value config)))) (defun config-group->string (group) (format nil "~:(~A group~)" (substitute #\Space #\- (string group)))) ;;; Configuration variables (defun config-all-groups () (let (all-groups) (maphash (lambda (key val) (declare (ignore key)) (pushnew (configvar-group val) all-groups :test #'equal)) *config-var-table*) (sort all-groups (lambda (x y) (string< (string x) (string y)))))) (defun find-in-hash (val hashtable &optional (test #'equal)) "Return the key associated to val in the hashtable" (maphash #'(lambda (k v) (when (and (consp v) (funcall test (first v) val)) (return-from find-in-hash (values k v)))) hashtable)) (defun view-hash-table (title hashtable) (maphash (lambda (k v) (format t "[~A] ~A ~A~%" title k v)) hashtable)) (defun copy-hash-table (hashtable) (let ((rethash (make-hash-table :test (hash-table-test hashtable)))) (maphash (lambda (k v) (setf (gethash k rethash) v)) hashtable) rethash)) (defun nfuncall (function) (when function (funcall function))) (defun pfuncall (function &rest args) (when (and function (or (functionp function) (and (symbolp function) (fboundp function)))) (apply function args))) (defun symbol-search (search symbol) "Search the string 'search' in the symbol name of 'symbol'" (search search (symbol-name symbol) :test #'string-equal)) (eval-when (:compile-toplevel :load-toplevel :execute) (defun mkstr (&rest args) (with-output-to-string (s) (dolist (a args) (princ a s)))) (defun symb (&rest args) (values (intern (apply #'mkstr args))))) ;;;,----- ;;;| Minimal hook ;;;`----- (defun call-hook (hook &optional args) "Call a hook (a function, a symbol or a list of functions) Return the result of the last hook" (let ((result nil)) (labels ((rec (hook) (when hook (typecase hook (cons (dolist (h hook) (rec h))) (t (setf result (apply hook args))))))) (rec hook) result))) (defmacro add-hook (hook &rest value) `(setf ,hook (append (typecase ,hook (list ,hook) (t (list ,hook))) (list ,@value)))) (defmacro remove-hook (hook &rest value) (let ((i (gensym))) `(dolist (,i (list ,@value)) (setf ,hook (remove ,i ,hook))))) ;;;,----- ;;;| Timers tools ;;;`----- (defparameter *timer-list* nil) (declaim (inline realtime->s s->realtime)) (defun realtime->s (rtime) (float (/ rtime internal-time-units-per-second))) (defun s->realtime (second) (round (* second internal-time-units-per-second))) (defun clear-timers () (setf *timer-list* nil)) (defun add-timer (delay fun &optional (id (gensym))) "Start the function fun at delay seconds." (push (list id (let ((time (+ (get-internal-real-time) (s->realtime delay)))) (lambda () (when (>= (get-internal-real-time) time) (funcall fun) t)))) *timer-list*) id) (defun at (delay fun &optional (id (gensym))) "Start the function fun at delay seconds." (funcall #'add-timer delay fun id)) (defmacro with-timer ((delay &optional (id (gensym))) &body body) "Same thing as add-timer but with syntaxic sugar" `(add-timer ,delay (lambda () ,@body) ,id)) (defun process-timers () "Call each timers in *timer-list* if needed" (dolist (timer *timer-list*) (when (funcall (second timer)) (setf *timer-list* (remove timer *timer-list* :test #'equal))))) (defun erase-timer (id) "Erase the timer identified by its id" (dolist (timer *timer-list*) (when (equal id (first timer)) (setf *timer-list* (remove timer *timer-list* :test #'equal))))) (defun timer-test-loop () (loop (princ ".") (force-output) (process-timers) (sleep 0.5))) ;;(defun plop () ;; (princ 'plop) ;; (erase-timer :toto)) ;; ;;(defun toto () ;; (princ 'toto) ;; (add-timer 5 #'toto :toto)) ;; ;;(add-timer 5 #'toto :toto) ;;(add-timer 30 #'plop) ;; ;;(timer-test-loop) ;;;,----- ;;;| Debuging tools ;;;`----- (defvar *%dbg-name%* "dbg") (defvar *%dbg-count%* 0) (defmacro dbg (&rest forms) `(progn ,@(mapcar #'(lambda (form) (typecase form (string `(setf *%dbg-name%* ,form)) (number `(setf *%dbg-count%* ,form)))) forms) (format t "~&DEBUG[~A - ~A] " (incf *%dbg-count%*) *%dbg-name%*) ,@(mapcar #'(lambda (form) (typecase form ((or string number) nil) (t `(format t "~A=~S " ',form ,form)))) forms) (format t "~%") (force-output) ,@forms)) (defmacro dbgnl (&rest forms) `(progn ,@(mapcar #'(lambda (form) (typecase form (string `(setf *%dbg-name%* ,form)) (number `(setf *%dbg-count%* ,form)))) forms) (format t "~&DEBUG[~A - ~A] --------------------~%" (incf *%dbg-count%*) *%dbg-name%*) ,@(mapcar #'(lambda (form) (typecase form ((or string number) nil) (t `(format t " - ~A=~S~%" ',form ,form)))) forms) (force-output) ,@forms)) (defun dbgc (obj &optional newline) (princ obj) (when newline (terpri)) (force-output)) (defun distance (x1 y1 x2 y2) (+ (abs (- x2 x1)) (abs (- y2 y1)))) ;;; Symbols tools (defmacro with-all-internal-symbols ((var package) &body body) "Bind symbol to all internal symbols in package" `(do-symbols (,var ,package) (multiple-value-bind (sym status) (find-symbol (symbol-name ,var) ,package) (declare (ignore sym)) (when (eql status :internal) ,@body)))) (defun export-all-functions (package &optional (verbose nil)) (with-all-internal-symbols (symbol package) (when (fboundp symbol) (when verbose (format t "Exporting ~S~%" symbol)) (export symbol package)))) (defun export-all-variables (package &optional (verbose nil)) (with-all-internal-symbols (symbol package) (when (boundp symbol) (when verbose (format t "Exporting ~S~%" symbol)) (export symbol package)))) (defun export-all-functions-and-variables (package &optional (verbose nil)) (with-all-internal-symbols (symbol package) (when (or (fboundp symbol) (boundp symbol)) (when verbose (format t "Exporting ~S~%" symbol)) (export symbol package)))) (defun ensure-function (object) (if (functionp object) object (symbol-function object))) (defun empty-string-p (string) (string= string "")) (defun find-common-string (string list &optional orig) "Return the string in common in all string in list" (if list (let ((result (remove-if-not (lambda (x) (zerop (or (search string x :test #'string-equal) -1))) list))) (if (= (length result) (length list)) (if (> (length (first list)) (length string)) (find-common-string (subseq (first list) 0 (1+ (length string))) list string) string) orig)) string)) ;;; Tools (defmacro setf/= (var val) "Set var to val only when var not equal to val" (let ((gval (gensym))) `(let ((,gval ,val)) (when (/= ,var ,gval) (setf ,var ,gval))))) (defun create-symbol (&rest names) "Return a new symbol from names" (intern (string-upcase (apply #'concatenate 'string names)))) (defun number->char (number) (cond ((<= number 25) (code-char (+ (char-code #\a) number))) ((<= 26 number 35) (code-char (+ (char-code #\0) (- number 26)))) ((<= 36 number 61) (code-char (+ (char-code #\A) (- number 36)))) (t #\|))) (defun number->string (number) (string (number->char number))) (defun simple-type-of (object) (let ((type (type-of object))) (typecase type (cons (first type)) (t type)))) (defun repeat-chars (n char) "Return a string containing N CHARs." (make-string n :initial-element char)) (defun nth-insert (n elem list) "Insert elem in (nth n list)" (nconc (subseq list 0 n) (list elem) (subseq list n))) (defun split-string (string &optional (separator #\Space)) "Return a list from a string splited at each separators" (loop for i = 0 then (1+ j) as j = (position separator string :start i) as sub = (subseq string i j) unless (string= sub "") collect sub while j)) (defun append-newline-space (string) "Append spaces before Newline on each line" (with-output-to-string (stream) (loop for c across string do (when (equal c #\Newline) (princ " " stream)) (princ c stream)))) (defun expand-newline (list) "Expand all newline in strings in list" (let ((acc nil)) (dolist (l list) (setf acc (append acc (split-string l #\Newline)))) acc)) (defun ensure-list (object) "Ensure an object is a list" (if (listp object) object (list object))) (defun ensure-printable (string &optional (new #\?)) "Ensure a string is printable in ascii" (or (substitute-if-not new #'standard-char-p (or string "")) "")) (defun limit-length (string &optional (length 10)) (subseq string 0 (min (length string) length))) (defun ensure-n-elems (list n) "Ensure that list has exactly n elements" (let ((length (length list))) (cond ((= length n) list) ((< length n) (ensure-n-elems (append list '(nil)) n)) ((> length n) (ensure-n-elems (butlast list) n))))) (defun begin-with-2-spaces (string) (and (> (length string) 1) (eql (char string 0) #\Space) (eql (char string 1) #\Space))) (defun string-equal-p (x y) (when (stringp y) (string-equal x y))) (defun find-assoc-word (word line &optional (delim #\")) "Find a word pair" (let* ((pos (search word line)) (pos-1 (position delim line :start (or pos 0))) (pos-2 (position delim line :start (1+ (or pos-1 0))))) (when (and pos pos-1 pos-2) (subseq line (1+ pos-1) pos-2)))) (defun print-space (n &optional (stream *standard-output*)) "Print n spaces on stream" (dotimes (i n) (princ #\Space stream))) (defun escape-string (string &optional (escaper '(#\/ #\: #\) #\( #\Space #\; #\,)) (char #\_)) "Replace in string all characters found in the escaper list" (if escaper (escape-string (substitute char (car escaper) string) (cdr escaper) char) string)) (defun first-position (word string) "Return true only if word is at position 0 in string" (zerop (or (search word string) -1))) (defun find-free-number (l) ; stolen from stumpwm - thanks "Return a number that is not in the list l." (let* ((nums (sort l #'<)) (new-num (loop for n from 0 to (or (car (last nums)) 0) for i in nums when (/= n i) do (return n)))) (if new-num new-num ;; there was no space between the numbers, so use the last + 1 (if (car (last nums)) (1+ (car (last nums))) 0)))) ;;; Shell part (taken from ltk) (defun do-execute (program args &optional (wt nil) (io :stream)) "execute program with args a list containing the arguments passed to the program if wt is non-nil, the function will wait for the execution of the program to return. returns a two way stream connected to stdin/stdout of the program" #-CLISP (declare (ignore io)) (let ((fullstring program)) (dolist (a args) (setf fullstring (concatenate 'string fullstring " " a))) #+:cmu (let ((proc (ext:run-program program args :input :stream :output :stream :wait wt))) (unless proc (error "Cannot create process.")) (make-two-way-stream (ext:process-output proc) (ext:process-input proc))) #+:clisp (ext:run-program program :arguments args :input io :output io :wait wt) #+:sbcl (let ((proc (sb-ext:run-program program args :input :stream :output :stream :wait wt))) (unless proc (error "Cannot create process.")) (make-two-way-stream (sb-ext:process-output proc) (sb-ext:process-input proc))) #+:lispworks (system:open-pipe fullstring :direction :io) #+:allegro (let ((proc (excl:run-shell-command (apply #'vector program program args) :input :stream :output :stream :wait wt))) (unless proc (error "Cannot create process.")) proc) #+:ecl(ext:run-program program args :input :stream :output :stream :error :output) #+:openmcl (let ((proc (ccl:run-program program args :input :stream :output :stream :wait wt))) (unless proc (error "Cannot create process.")) (make-two-way-stream (ccl:external-process-output-stream proc) (ccl:external-process-input-stream proc))))) (defun do-shell (program &optional args (wait nil) (io :stream)) (do-execute "/bin/sh" `("-c" ,program ,@args) wait io)) (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)) #+(or mcl ccl) (ccl::getenv var) #+sbcl (sb-posix:getenv (string var)) #+ecl (si:getenv (string var)) #-(or allegro clisp cmu gcl lispworks lucid mcl sbcl scl ecl ccl) (error 'not-implemented :proc (list 'getenv var))) (defun (setf getenv) (val var) "Set an environment variable." #+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))) #+ecl (si:setenv (string var) (string val)) #+ccl (ccl::setenv (string var) (string val)) #-(or allegro clisp cmu gcl lispworks lucid sbcl scl ecl ccl) (error 'not-implemented :proc (list '(setf getenv) var))) (defun uquit () #+(or clisp cmu) (ext:quit) #+sbcl (sb-ext:quit) #+ecl (si:quit) #+gcl (lisp:quit) #+lispworks (lw:quit) #+(or allegro-cl allegro-cl-trial) (excl:exit) #+ccl (ccl:quit)) (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 urun-prog (prog &rest opts &key args (wait t) &allow-other-keys) "Common interface to shell. Does not return anything useful." #+gcl (declare (ignore wait)) (setq opts (remove-plist opts :args :wait)) #+allegro (apply #'excl:run-shell-command (apply #'vector prog prog args) :wait wait opts) #+(and clisp lisp=cl) (apply #'ext:run-program prog :arguments args :wait wait opts) #+(and clisp (not lisp=cl)) (if wait (apply #'lisp:run-program prog :arguments args opts) (lisp:shell (format nil "~a~{ '~a'~} &" prog args))) #+cmu (apply #'ext:run-program prog args :wait wait :output *standard-output* opts) #+gcl (apply #'si:run-process prog args) #+liquid (apply #'lcl:run-program prog args) #+lispworks (apply #'sys::call-system-showing-output (format nil "~a~{ '~a'~}~@[ &~]" prog args (not wait)) opts) #+lucid (apply #'lcl:run-program prog :wait wait :arguments args opts) #+sbcl (apply #'sb-ext:run-program prog args :wait wait :output *standard-output* opts) #+ecl (apply #'ext:run-program prog args opts) #+ccl (apply #'ccl:run-program prog args opts :wait wait) #-(or allegro clisp cmu gcl liquid lispworks lucid sbcl ecl ccl) (error 'not-implemented :proc (list 'run-prog prog opts))) ;;(defparameter *shell-cmd* "/usr/bin/env") ;;(defparameter *shell-cmd-opt* nil) #+UNIX (defparameter *shell-cmd* "/bin/sh") #+UNIX (defparameter *shell-cmd-opt* '("-c")) #+WIN32 (defparameter *shell-cmd* "cmd.exe") #+WIN32 (defparameter *shell-cmd-opt* '("/C")) (defun ushell (&rest strings) (urun-prog *shell-cmd* :args (append *shell-cmd-opt* strings))) (defun ush (string) (urun-prog *shell-cmd* :args (append *shell-cmd-opt* (list string)))) (defun set-shell-dispatch (&optional (shell-fun 'ushell)) (labels ((|shell-reader| (stream subchar arg) (declare (ignore subchar arg)) (list shell-fun (read stream t nil t)))) (set-dispatch-macro-character #\# #\# #'|shell-reader|))) (defun ushell-loop (&optional (shell-fun #'ushell)) (loop (format t "UNI-SHELL> ") (let* ((line (read-line))) (cond ((zerop (or (search "quit" line) -1)) (return)) ((zerop (or (position #\! line) -1)) (funcall shell-fun (subseq line 1))) (t (format t "~{~A~^ ;~%~}~%" (multiple-value-list (ignore-errors (eval (read-from-string line)))))))))) (defun cldebug (&rest rest) (princ "DEBUG: ") (dolist (i rest) (princ i)) (terpri)) (defun get-command-line-words () #+sbcl (cdr sb-ext:*posix-argv*) #+(or clozure ccl) (cddddr (ccl::command-line-arguments)) #+gcl (cdr si:*command-args*) #+ecl (loop for i from 1 below (si:argc) collect (si:argv i)) #+cmu (cdddr extensions:*command-line-strings*) #+allegro (cdr (sys:command-line-arguments)) #+lispworks (cdr sys:*line-arguments-list*) #+clisp ext:*args* #-(or sbcl clozure gcl ecl cmu allegro lispworks clisp) (error "get-command-line-arguments not supported for your implementation")) (defun string-to-list (str &key (split-char #\space)) (do* ((start 0 (1+ index)) (index (position split-char str :start start) (position split-char str :start start)) (accum nil)) ((null index) (unless (string= (subseq str start) "") (push (subseq str start) accum)) (nreverse accum)) (when (/= start index) (push (subseq str start index) accum)))) (defun near-position (chars str &key (start 0)) (do* ((char chars (cdr char)) (pos (position (car char) str :start start) (position (car char) str :start start)) (ret (when pos pos) (if pos (if ret (if (< pos ret) pos ret) pos) ret))) ((null char) ret))) ;;;(defun near-position2 (chars str &key (start 0)) ;;; (loop for i in chars ;;; minimize (position i str :start start))) ;;(format t "~S~%" (near-position '(#\! #\. #\Space #\;) "klmsqk ppii;dsdsqkl.jldfksj lkm" :start 0)) ;;(format t "~S~%" (near-position '(#\Space) "klmsqk ppii;dsdsqkl.jldfksj lkm" :start 0)) ;;(format t "~S~%" (near-position '(#\; #\l #\m) "klmsqk ppii;dsdsqkl.jldfksj lkm" :start 0)) ;;(format t "result=~S~%" (string-to-list-multichar "klmsqk ppii;dsdsqkl.jldfksj lkm" :preserve t)) ;;(format t "result=~S~%" (string-to-list-multichar "klmsqk ppii;dsd!sqkl.jldfksj lkm" ;; :split-chars '(#\k #\! #\. #\; #\m) ;; :preserve nil)) (defun string-to-list-multichar (str &key (split-chars '(#\space)) (preserve nil)) (do* ((start 0 (1+ index)) (index (near-position split-chars str :start start) (near-position split-chars str :start start)) (accum nil)) ((null index) (unless (string= (subseq str start) "") (push (subseq str start) accum)) (nreverse accum)) (let ((retstr (subseq str start (if preserve (1+ index) index)))) (unless (string= retstr "") (push retstr accum))))) (defun list-to-string (lst) (string-trim " () " (format nil "~A" lst))) (defun clean-string (string) "Remove Newline and upcase string" (string-upcase (string-right-trim '(#\Newline) string))) (defun one-in-list (lst) (nth (random (length lst)) lst)) (defun exchange-one-in-list (lst1 lst2) (let ((elem1 (one-in-list lst1)) (elem2 (one-in-list lst2))) (setf lst1 (append (remove elem1 lst1) (list elem2))) (setf lst2 (append (remove elem2 lst2) (list elem1))) (values lst1 lst2))) (defun rotate-list (list) (when list (append (cdr list) (list (car list))))) (defun anti-rotate-list (list) (when list (append (last list) (butlast list)))) (defun n-rotate-list (list n) (if (> n 0) (n-rotate-list (rotate-list list) (1- n)) list)) (defun append-formated-list (base-str lst &key (test-not-fun #'(lambda (x) x nil)) (print-fun #'(lambda (x) x)) (default-str "")) (let ((str base-str) (first t)) (dolist (i lst) (cond ((funcall test-not-fun i) nil) (t (setq str (concatenate 'string str (if first "" ", ") (format nil "~A" (funcall print-fun i)))) (setq first nil)))) (if (string= base-str str) (concatenate 'string str default-str) str))) (defun shuffle-list (list &key (time 1)) "Shuffle a list by swapping elements time times" (let ((result (copy-list list)) (ind1 0) (ind2 0) (swap 0)) (dotimes (i time) (setf ind1 (random (length result))) (setf ind2 (random (length result))) (setf swap (nth ind1 result)) (setf (nth ind1 result) (nth ind2 result)) (setf (nth ind2 result) swap)) result)) (defun convert-to-number (str) (cond ((stringp str) (parse-integer str :junk-allowed t)) ((numberp str) str))) (defun parse-integer-in-list (lst) "Convert all integer string in lst to integer" (mapcar #'(lambda (x) (convert-to-number x)) lst)) (defun next-in-list (item lst) (do ((x lst (cdr x))) ((null x)) (when (equal item (car x)) (return (if (cadr x) (cadr x) (car lst)))))) (defun prev-in-list (item lst) (next-in-list item (reverse lst))) (let ((jours '("Lundi" "Mardi" "Mercredi" "Jeudi" "Vendredi" "Samedi" "Dimanche")) (mois '("Janvier" "Fevrier" "Mars" "Avril" "Mai" "Juin" "Juillet" "Aout" "Septembre" "Octobre" "Novembre" "Decembre")) (days '("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday")) (months '("January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December"))) (defun date-string () (multiple-value-bind (second minute hour date month year day) (get-decoded-time) (if (search "fr" (getenv "LANG") :test #'string-equal) (format nil " ~2,'0D:~2,'0D:~2,'0D ~A ~2,'0D ~A ~A " hour minute second (nth day jours) date (nth (1- month) mois) year) (format nil " ~2,'0D:~2,'0D:~2,'0D ~A ~A ~2,'0D ~A " hour minute second (nth day days) (nth (1- month) months) date year))))) clfswm-20111015.git51b0a02/src/version.lisp000066400000000000000000000022001164636077000200670ustar00rootroot00000000000000;; Copyright (C) 2011 Xavier Maillard ;; Copyright (C) 2011 Martin Bishop ;; ;; Borrowed from Stumpwm ;; This file is part of clfswm. ;; ;; clfswm 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. ;; clfswm 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 :common-lisp-user) (defpackage version (:use :common-lisp :tools) (:export *version*)) (in-package :version) (defparameter *version* #.(concatenate 'string "Version: 1106 built " (date-string))) clfswm-20111015.git51b0a02/src/xlib-util.lisp000066400000000000000000000641161164636077000203310ustar00rootroot00000000000000;;; -------------------------------------------------------------------------- ;;; CLFSWM - FullScreen Window Manager ;;; ;;; -------------------------------------------------------------------------- ;;; Documentation: Utility functions ;;; -------------------------------------------------------------------------- ;;; ;;; (C) 2011 Philippe Brochard ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;; ;;; -------------------------------------------------------------------------- (in-package :clfswm) ;; Window states (defconstant +withdrawn-state+ 0) (defconstant +normal-state+ 1) (defconstant +iconic-state+ 3) (defparameter *window-events* '(:structure-notify :property-change :colormap-change :focus-change :enter-window :exposure) "The events to listen for on managed windows.") (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_CLIENT_LIST) "Supported NETWM properties. Window types are in +WINDOW-TYPES+.") (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.") (defmacro with-xlib-protect (&body body) "Prevent Xlib errors" `(handler-case (with-simple-restart (top-level "Return to clfswm's top level") ,@body) ((or xlib:match-error xlib:window-error xlib:drawable-error) (c) (progn (dbg "Ignore Xlib Error" c ',body) (unassoc-keyword-handle-event) (assoc-keyword-handle-event 'main-mode) (setf *in-second-mode* nil))))) (defmacro with-x-pointer (&body body) "Bind (x y) to mouse pointer positions" `(multiple-value-bind (x y) (xlib:query-pointer *root*) ,@body)) (declaim (inline window-x2 window-y2)) (defun window-x2 (window) (+ (xlib:drawable-x window) (xlib:drawable-width window))) (defun window-y2 (window) (+ (xlib:drawable-y window) (xlib:drawable-height window))) ;;; ;;; Events management functions. ;;; (defparameter *unhandled-events* nil) (defparameter *current-event-mode* nil) (eval-when (:compile-toplevel :load-toplevel :execute) (defun keyword->handle-event (mode keyword) (symb 'handle-event-fun "-" mode "-" keyword))) (defun handle-event->keyword (symbol) (let* ((name (string-downcase (symbol-name symbol))) (pos (search "handle-event-fun-" name))) (when (and pos (zerop pos)) (let ((pos-mod (search "mode" name))) (when pos-mod (values (intern (string-upcase (subseq name (+ pos-mod 5))) :keyword) (subseq name (length "handle-event-fun-") (1- pos-mod)))))))) (defparameter *handle-event-fun-symbols* nil) (defun fill-handle-event-fun-symbols () (with-all-internal-symbols (symbol :clfswm) (let ((pos (symbol-search "handle-event-fun-" symbol))) (when (and pos (zerop pos)) (pushnew symbol *handle-event-fun-symbols*))))) (defmacro with-handle-event-symbol ((mode) &body body) "Bind symbol to all handle event functions available in mode" `(let ((pattern (format nil "handle-event-fun-~A" ,mode))) (dolist (symbol *handle-event-fun-symbols*) (let ((pos (symbol-search pattern symbol))) (when (and pos (zerop pos)) ,@body))))) (defun find-handle-event-function (&optional (mode "")) "Print all handle event functions available in mode" (with-handle-event-symbol (mode) (print symbol))) (defun assoc-keyword-handle-event (mode) "Associate all keywords in mode to their corresponding handle event functions. For example: main-mode :key-press is bound to handle-event-fun-main-mode-key-press" (setf *current-event-mode* mode) (with-handle-event-symbol (mode) (let ((keyword (handle-event->keyword symbol))) (when (fboundp symbol) #+:event-debug (progn (format t "~&Associating: ~S with ~S~%" symbol keyword) (force-output)) (setf (symbol-function keyword) (symbol-function symbol)))))) (defun unassoc-keyword-handle-event (&optional (mode "")) "Unbound all keywords from their corresponding handle event functions." (setf *current-event-mode* nil) (with-handle-event-symbol (mode) (let ((keyword (handle-event->keyword symbol))) (when (fboundp keyword) #+:event-debug (progn (format t "~&Unassociating: ~S ~S~%" symbol keyword) (force-output)) (fmakunbound keyword))))) (defmacro define-handler (mode keyword args &body body) "Like a defun but with a name expanded as handle-event-fun-'mode'-'keyword' For example (define-handler main-mode :key-press (args) ...) Expand in handle-event-fun-main-mode-key-press" `(defun ,(keyword->handle-event mode keyword) (&rest event-slots &key #+:event-debug event-key ,@args &allow-other-keys) (declare (ignorable event-slots)) #+:event-debug (print (list *current-event-mode* event-key)) ,@body)) (defun handle-event (&rest event-slots &key event-key &allow-other-keys) (with-xlib-protect (if (fboundp event-key) (apply event-key event-slots) #+:event-debug (pushnew (list *current-event-mode* event-key) *unhandled-events* :test #'equal)) (xlib:display-finish-output *display*)) t) (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))) (defun banish-pointer () "Move the pointer to the lower right corner of the screen" (with-placement (*banish-pointer-placement* x y) (xlib:warp-pointer *root* x y))) (defun window-state (win) "Get the state (iconic, normal, withdrawn) of a window." (first (xlib:get-property win :WM_STATE))) (defun set-window-state (win state) "Set the state (iconic, normal, withdrawn) of a window." (xlib:change-property win :WM_STATE (list state) :WM_STATE 32)) (defsetf window-state set-window-state) (defun window-hidden-p (window) (eql (window-state window) +iconic-state+)) (defun null-size-window-p (window) (let ((hints (xlib:wm-normal-hints window))) (and hints (not (or (xlib:wm-size-hints-width hints) (xlib:wm-size-hints-height hints) (xlib:wm-size-hints-win-gravity hints))) (xlib:wm-size-hints-user-specified-position-p hints)))) (defun unhide-window (window) (when window (when (window-hidden-p window) (xlib:map-window window) (setf (window-state window) +normal-state+ (xlib:window-event-mask window) *window-events*)))) (defun map-window (window) (when window (xlib:map-window window))) (defun delete-window (window) (send-client-message window :WM_PROTOCOLS (xlib:intern-atom *display* "WM_DELETE_WINDOW"))) (defun destroy-window (window) (xlib:kill-client *display* (xlib:window-id window))) ;;(defconstant +exwm-atoms+ ;; (list "_NET_SUPPORTED" "_NET_CLIENT_LIST" ;; "_NET_CLIENT_LIST_STACKING" "_NET_NUMBER_OF_DESKTOPS" ;; "_NET_CURRENT_DESKTOP" "_NET_DESKTOP_GEOMETRY" ;; "_NET_DESKTOP_VIEWPORT" "_NET_DESKTOP_NAMES" ;; "_NET_ACTIVE_WINDOW" "_NET_WORKAREA" ;; "_NET_SUPPORTING_WM_CHECK" "_NET_VIRTUAL_ROOTS" ;; "_NET_DESKTOP_LAYOUT" ;; ;; "_NET_RESTACK_WINDOW" "_NET_REQUEST_FRAME_EXTENTS" ;; "_NET_MOVERESIZE_WINDOW" "_NET_CLOSE_WINDOW" ;; "_NET_WM_MOVERESIZE" ;; ;; "_NET_WM_SYNC_REQUEST" "_NET_WM_PING" ;; ;; "_NET_WM_NAME" "_NET_WM_VISIBLE_NAME" ;; "_NET_WM_ICON_NAME" "_NET_WM_VISIBLE_ICON_NAME" ;; "_NET_WM_DESKTOP" "_NET_WM_WINDOW_TYPE" ;; "_NET_WM_STATE" "_NET_WM_STRUT" ;; "_NET_WM_ICON_GEOMETRY" "_NET_WM_ICON" ;; "_NET_WM_PID" "_NET_WM_HANDLED_ICONS" ;; "_NET_WM_USER_TIME" "_NET_FRAME_EXTENTS" ;; ;; "_NET_WM_MOVE_ACTIONS" ;; ;; "_NET_WM_WINDOW_TYPE_DESKTOP" "_NET_WM_STATE_MODAL" ;; "_NET_WM_WINDOW_TYPE_DOCK" "_NET_WM_STATE_STICKY" ;; "_NET_WM_WINDOW_TYPE_TOOLBAR" "_NET_WM_STATE_MAXIMIZED_VERT" ;; "_NET_WM_WINDOW_TYPE_MENU" "_NET_WM_STATE_MAXIMIZED_HORZ" ;; "_NET_WM_WINDOW_TYPE_UTILITY" "_NET_WM_STATE_SHADED" ;; "_NET_WM_WINDOW_TYPE_SPLASH" "_NET_WM_STATE_SKIP_TASKBAR" ;; "_NET_WM_WINDOW_TYPE_DIALOG" "_NET_WM_STATE_SKIP_PAGER" ;; "_NET_WM_WINDOW_TYPE_NORMAL" "_NET_WM_STATE_HIDDEN" ;; "_NET_WM_STATE_FULLSCREEN" ;; "_NET_WM_STATE_ABOVE" ;; "_NET_WM_STATE_BELOW" ;; "_NET_WM_STATE_DEMANDS_ATTENTION" ;; ;; "_NET_WM_ALLOWED_ACTIONS" ;; "_NET_WM_ACTION_MOVE" ;; "_NET_WM_ACTION_RESIZE" ;; "_NET_WM_ACTION_SHADE" ;; "_NET_WM_ACTION_STICK" ;; "_NET_WM_ACTION_MAXIMIZE_HORZ" ;; "_NET_WM_ACTION_MAXIMIZE_VERT" ;; "_NET_WM_ACTION_FULLSCREEN" ;; "_NET_WM_ACTION_CHANGE_DESKTOP" ;; "_NET_WM_ACTION_CLOSE" ;; ;; )) ;; ;; ;;(defun intern-atoms (display) ;; (declare (type xlib:display display)) ;; (mapcar #'(lambda (atom-name) (xlib:intern-atom display atom-name)) ;; +exwm-atoms+) ;; (values)) ;; ;; ;; ;;(defun get-atoms-property (window property-atom atom-list-p) ;; "Returns a list of atom-name (if atom-list-p is t) otherwise returns ;; a list of atom-id." ;; (xlib:get-property window property-atom ;; :transform (when atom-list-p ;; (lambda (id) ;; (xlib:atom-name (xlib:drawable-display window) id))))) ;; ;;(defun set-atoms-property (window atoms property-atom &key (mode :replace)) ;; "Sets the property designates by `property-atom'. ATOMS is a list of atom-id ;; or a list of keyword atom-names." ;; (xlib:change-property window property-atom atoms :ATOM 32 ;; :mode mode ;; :transform (unless (integerp (car atoms)) ;; (lambda (atom-key) ;; (xlib:find-atom (xlib:drawable-display window) atom-key))))) ;; ;; ;; ;; ;;(defun net-wm-state (window) ;; (get-atoms-property window :_NET_WM_STATE t)) ;; ;;(defsetf net-wm-state (window &key (mode :replace)) (states) ;; `(set-atoms-property ,window ,states :_NET_WM_STATE :mode ,mode)) (defun hide-window (window) (when window (setf (window-state window) +iconic-state+ (xlib:window-event-mask window) (remove :structure-notify *window-events*)) (xlib:unmap-window window) (setf (xlib:window-event-mask window) *window-events*))) (defun window-type (window) "Return one of :desktop, :dock, :toolbar, :utility, :splash, :dialog, :transient, :maxsize and :normal." (or (and (let ((hints (xlib:wm-normal-hints window))) (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)))) :maxsize) (let ((net-wm-window-type (xlib:get-property window :_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 window :WM_TRANSIENT_FOR) :transient) :normal)) ;;; Stolen from Eclipse (defun send-configuration-notify (window x y w h bw) "Send a synthetic configure notify event to the given window (ICCCM 4.1.5)" (xlib:send-event window :configure-notify (xlib:make-event-mask :structure-notify) :event-window window :window window :x x :y y :width w :height h :border-width bw :propagate-p nil)) (defun send-client-message (window type &rest data) "Send a client message to a client's window." (xlib:send-event window :client-message nil :window window :type type :format 32 :data data)) (defun raise-window (window) "Map the window if needed and bring it to the top of the stack. Does not affect focus." (when (xlib:window-p window) (when (window-hidden-p window) (unhide-window window)) (setf (xlib:window-priority window) :above))) (defun focus-window (window) "Give the window focus." (when (xlib:window-p window) (xlib:set-input-focus *display* window :parent))) (defun raise-and-focus-window (window) "Raise and focus." (raise-window window) (focus-window window)) (defun no-focus () "don't focus any window but still read keyboard events." (xlib:set-input-focus *display* *no-focus-window* :pointer-root)) (defun lower-window (window sibling) "Map the window if needed and bring it just above sibling. Does not affect focus." (when (xlib:window-p window) (when (window-hidden-p window) (unhide-window window)) (setf (xlib:window-priority window sibling) :below))) (let ((cursor-font nil) (cursor nil) (pointer-grabbed nil)) (defun free-grab-pointer () (when cursor (xlib:free-cursor cursor) (setf cursor nil)) (when cursor-font (xlib:close-font cursor-font) (setf cursor-font nil))) (defun xgrab-init-pointer () (setf pointer-grabbed nil)) (defun xgrab-pointer-p () pointer-grabbed) (defun xgrab-pointer (root cursor-char cursor-mask-char &optional (pointer-mask '(:enter-window :pointer-motion :button-press :button-release)) owner-p) "Grab the pointer and set the pointer shape." (when pointer-grabbed (xungrab-pointer)) (setf pointer-grabbed t) (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))) (cond (cursor-char (setf cursor-font (xlib:open-font *display* "cursor") cursor (xlib:create-glyph-cursor :source-font cursor-font :source-char (or cursor-char 68) :mask-font cursor-font :mask-char (or cursor-mask-char 69) :foreground black :background white)) (xlib:grab-pointer root pointer-mask :owner-p owner-p :sync-keyboard-p nil :sync-pointer-p nil :cursor cursor)) (t (xlib:grab-pointer root pointer-mask :owner-p owner-p :sync-keyboard-p nil :sync-pointer-p nil))))) (defun xungrab-pointer () "Remove the grab on the cursor and restore the cursor shape." (setf pointer-grabbed nil) (xlib:ungrab-pointer *display*) (xlib:display-finish-output *display*) (free-grab-pointer))) (let ((keyboard-grabbed nil)) (defun xgrab-init-keyboard () (setf keyboard-grabbed nil)) (defun xgrab-keyboard-p () keyboard-grabbed) (defun xgrab-keyboard (root) (setf keyboard-grabbed t) (xlib:grab-keyboard root :owner-p nil :sync-keyboard-p nil :sync-pointer-p nil)) (defun xungrab-keyboard () (setf keyboard-grabbed nil) (xlib:ungrab-keyboard *display*))) (defun ungrab-all-buttons (window) (xlib:ungrab-button window :any :modifiers :any)) (defun grab-all-buttons (window) (ungrab-all-buttons window) (xlib:grab-button window :any '(:button-press :button-release :pointer-motion) :modifiers :any :owner-p nil :sync-pointer-p t :sync-keyboard-p nil)) (defun ungrab-all-keys (window) (xlib:ungrab-key window :any :modifiers :any)) (defun stop-button-event () (xlib:allow-events *display* :sync-pointer)) (defun replay-button-event () (xlib:allow-events *display* :replay-pointer)) ;;; Mouse action on window (let (add-fn add-arg dx dy window) (define-handler move-window-mode :motion-notify (root-x root-y) (unless (compress-motion-notify) (if add-fn (multiple-value-bind (move-x move-y) (apply add-fn add-arg) (when move-x (setf (xlib:drawable-x window) (+ root-x dx))) (when move-y (setf (xlib:drawable-y window) (+ root-y dy)))) (setf (xlib:drawable-x window) (+ root-x dx) (xlib:drawable-y window) (+ root-y dy))))) (define-handler move-window-mode :key-release () (throw 'exit-move-window-mode nil)) (define-handler move-window-mode :button-release () (throw 'exit-move-window-mode nil)) (defun move-window (orig-window orig-x orig-y &optional additional-fn additional-arg) (setf window orig-window add-fn additional-fn add-arg additional-arg dx (- (xlib:drawable-x window) orig-x) dy (- (xlib:drawable-y window) orig-y) (xlib:window-border window) (get-color *color-move-window*)) (raise-window window) (let ((pointer-grabbed-p (xgrab-pointer-p))) (unless pointer-grabbed-p (xgrab-pointer *root* nil nil)) (when additional-fn (apply additional-fn additional-arg)) (generic-mode 'move-window-mode 'exit-move-window-mode :original-mode '(main-mode)) (unless pointer-grabbed-p (xungrab-pointer))))) (let (add-fn add-arg window o-x o-y orig-width orig-height min-width max-width min-height max-height) (define-handler resize-window-mode :motion-notify (root-x root-y) (unless (compress-motion-notify) (if add-fn (multiple-value-bind (resize-w resize-h) (apply add-fn add-arg) (when resize-w (setf (xlib:drawable-width window) (min (max (+ orig-width (- root-x o-x)) 10 min-width) max-width))) (when resize-h (setf (xlib:drawable-height window) (min (max (+ orig-height (- root-y o-y)) 10 min-height) max-height)))) (setf (xlib:drawable-width window) (min (max (+ orig-width (- root-x o-x)) 10 min-width) max-width) (xlib:drawable-height window) (min (max (+ orig-height (- root-y o-y)) 10 min-height) max-height))))) (define-handler resize-window-mode :key-release () (throw 'exit-resize-window-mode nil)) (define-handler resize-window-mode :button-release () (throw 'exit-resize-window-mode nil)) (defun resize-window (orig-window orig-x orig-y &optional additional-fn additional-arg) (let* ((pointer-grabbed-p (xgrab-pointer-p)) (hints (xlib:wm-normal-hints orig-window))) (setf window orig-window add-fn additional-fn add-arg additional-arg o-x orig-x o-y orig-y orig-width (xlib:drawable-width window) orig-height (xlib:drawable-height window) min-width (or (and hints (xlib:wm-size-hints-min-width hints)) 0) min-height (or (and hints (xlib:wm-size-hints-min-height hints)) 0) max-width (or (and hints (xlib:wm-size-hints-max-width hints)) most-positive-fixnum) max-height (or (and hints (xlib:wm-size-hints-max-height hints)) most-positive-fixnum) (xlib:window-border window) (get-color *color-move-window*)) (raise-window window) (unless pointer-grabbed-p (xgrab-pointer *root* nil nil)) (when additional-fn (apply additional-fn additional-arg)) (generic-mode 'resize-window-mode 'exit-resize-window-mode :original-mode '(main-mode)) (unless pointer-grabbed-p (xungrab-pointer))))) (define-handler wait-mouse-button-release-mode :button-release () (throw 'exit-wait-mouse-button-release-mode nil)) (defun wait-mouse-button-release (&optional cursor-char cursor-mask-char) (let ((pointer-grabbed-p (xgrab-pointer-p))) (unless pointer-grabbed-p (xgrab-pointer *root* cursor-char cursor-mask-char)) (generic-mode 'wait-mouse-button-release 'exit-wait-mouse-button-release-mode) (unless pointer-grabbed-p (xungrab-pointer)))) (let ((color-hash (make-hash-table :test 'equal))) (defun get-color (color) (multiple-value-bind (val foundp) (gethash color color-hash) (if foundp val (setf (gethash color color-hash) (xlib:alloc-color (xlib:screen-default-colormap *screen*) color)))))) (defgeneric ->color (color)) (defmethod ->color ((color-name string)) color-name) (defmethod ->color ((color integer)) (labels ((hex->float (color) (/ (logand color #xFF) 256.0))) (xlib:make-color :blue (hex->float color) :green (hex->float (ash color -8)) :red (hex->float (ash color -16))))) (defmethod ->color ((color list)) (destructuring-bind (red green blue) color (xlib:make-color :blue red :green green :red blue))) (defmethod ->color ((color xlib:color)) color) (defmethod ->color (color) (format t "Wrong color type: ~A~%" color) "White") (defun color->rgb (color) (multiple-value-bind (r g b) (xlib:color-rgb color) (+ (ash (round (* 256 r)) +16) (ash (round (* 256 g)) +8) (round (* 256 b))))) (defmacro my-character->keysyms (ch) "Convert a char to a keysym" ;; XLIB:CHARACTER->KEYSYMS should probably be implemented in NEW-CLX ;; some day. Or just copied from MIT-CLX or some other CLX ;; implementation (see translate.lisp and keysyms.lisp). For now, ;; we do like this. It suffices for modifiers and ASCII symbols. (if (fboundp 'xlib:character->keysyms) `(xlib:character->keysyms ,ch) `(list (case ,ch (:character-set-switch #xFF7E) (:left-shift #xFFE1) (:right-shift #xFFE2) (:left-control #xFFE3) (:right-control #xFFE4) (:caps-lock #xFFE5) (:shift-lock #xFFE6) (:left-meta #xFFE7) (:right-meta #xFFE8) (:left-alt #xFFE9) (:right-alt #xFFEA) (:left-super #xFFEB) (:right-super #xFFEC) (:left-hyper #xFFED) (:right-hyper #xFFEE) (t (etypecase ,ch (character ;; Latin-1 characters have their own value as keysym (if (< 31 (char-code ,ch) 256) (char-code ,ch) (error "Don't know how to get keysym from ~A" ,ch))))))))) (defun char->keycode (char) "Convert a character to a keycode" (xlib:keysym->keycodes *display* (first (my-character->keysyms char)))) (defun keycode->char (code state) (xlib:keysym->character *display* (xlib:keycode->keysym *display* code 0) state)) (defun modifiers->state (modifier-list) (apply #'xlib:make-state-mask modifier-list)) (defun state->modifiers (state) (xlib:make-state-keys state)) (defun keycode->keysym (code modifiers) (xlib:keycode->keysym *display* code (cond ((member :shift modifiers) 1) ((member :mod-5 modifiers) 4) (t 0)))) (defmacro with-grab-keyboard-and-pointer ((cursor mask old-cursor old-mask) &body body) `(let ((pointer-grabbed (xgrab-pointer-p)) (keyboard-grabbed (xgrab-keyboard-p))) (xgrab-pointer *root* ,cursor ,mask) (unless keyboard-grabbed (xgrab-keyboard *root*)) (unwind-protect (progn ,@body) (if pointer-grabbed (xgrab-pointer *root* ,old-cursor ,old-mask) (xungrab-pointer)) (unless keyboard-grabbed (xungrab-keyboard))))) (let ((modifier-list nil)) (defun init-modifier-list () (dolist (name '("Shift_L" "Shift_R" "Control_L" "Control_R" "Alt_L" "Alt_R" "Meta_L" "Meta_R" "Hyper_L" "Hyper_R" "Mode_switch" "script_switch" "ISO_Level3_Shift" "Caps_Lock" "Scroll_Lock" "Num_Lock")) (awhen (xlib:keysym->keycodes *display* (keysym-name->keysym name)) (push it modifier-list)))) (defun modifier-p (code) (member code modifier-list))) (defun wait-no-key-or-button-press () (with-grab-keyboard-and-pointer (66 67 66 67) (loop (let ((key (loop for k across (xlib:query-keymap *display*) for code from 0 when (and (plusp k) (not (modifier-p code))) return t)) (button (loop for b in (xlib:make-state-keys (nth-value 4 (xlib:query-pointer *root*))) when (member b '(:button-1 :button-2 :button-3 :button-4 :button-5)) return t))) (when (and (not key) (not button)) (loop while (xlib:event-case (*display* :discard-p t :peek-p nil :timeout 0) (:motion-notify () t) (:key-press () t) (:key-release () t) (:button-press () t) (:button-release () t) (t nil))) (return)))))) (defun wait-a-key-or-button-press () (with-grab-keyboard-and-pointer (24 25 66 67) (loop (let ((key (loop for k across (xlib:query-keymap *display*) unless (zerop k) return t)) (button (loop for b in (xlib:make-state-keys (nth-value 4 (xlib:query-pointer *root*))) when (member b '(:button-1 :button-2 :button-3 :button-4 :button-5)) return t))) (when (or key button) (return)))))) (defun compress-motion-notify () (when *have-to-compress-notify* (loop while (xlib:event-cond (*display* :timeout 0) (:motion-notify () t))))) (defun display-all-cursors (&optional (display-time 1)) "Display all X11 cursors for display-time seconds" (loop for i from 0 to 152 by 2 do (xgrab-pointer *root* i (1+ i)) (dbg i) (sleep display-time) (xungrab-pointer))) ;;; Double buffering tools (defun clear-pixmap-buffer (window gc) (rotatef (xlib:gcontext-foreground gc) (xlib:gcontext-background gc)) (xlib:draw-rectangle *pixmap-buffer* gc 0 0 (xlib:drawable-width window) (xlib:drawable-height window) t) (rotatef (xlib:gcontext-foreground gc) (xlib:gcontext-background gc))) (defun copy-pixmap-buffer (window gc) (xlib:copy-area *pixmap-buffer* gc 0 0 (xlib:drawable-width window) (xlib:drawable-height window) window 0 0)) (defun is-a-key-pressed-p () (loop for k across (xlib:query-keymap *display*) when (plusp k) return t)) ;;; Windows wm class and name tests (defmacro defun-equal-wm-class (symbol class) `(defun ,symbol (window) (when (xlib:window-p window) (string-equal (xlib:get-wm-class window) ,class)))) (defmacro defun-equal-wm-name (symbol name) `(defun ,symbol (window) (when (xlib:window-p window) (string-equal (xlib:wm-name window) ,name))))