├── .gitignore ├── .travis.yml ├── LICENSE ├── Makefile.in ├── README.org ├── autogen.sh ├── backends ├── display-server.lisp └── gui.lisp ├── base ├── README.txt ├── data-dir.lisp ├── debug.lisp ├── helpers.lisp ├── hooks.lisp ├── load-rc.lisp ├── primitives.lisp └── timers.lisp ├── configure.ac ├── package.lisp ├── paulownia-tests.asd.in ├── paulownia.asd ├── paulownia.ros.in ├── project-log.org ├── tests ├── base │ ├── hooks.lisp │ └── timers.lisp └── paulownia.lisp └── version.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | *.FASL 2 | *.fasl 3 | *.lisp-temp 4 | /configure 5 | /autom4te.cache 6 | /Makefile 7 | /config.log 8 | /config.status 9 | /paulownia-tests.asd 10 | /paulownia.ros 11 | /paulownia 12 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: common-lisp 2 | sudo: false 3 | 4 | os: 5 | - linux 6 | 7 | env: 8 | global: 9 | - PATH=${HOME}/.roswell/bin:$PATH 10 | - ROSWELL_BRANCH=master 11 | - ROSWELL_INSTALL_DIR=${HOME}/.roswell 12 | matrix: 13 | - LISP=sbcl 14 | - LISP=ccl-bin 15 | install: 16 | - curl -L https://raw.githubusercontent.com/snmsts/roswell/$ROSWELL_BRANCH/scripts/install-for-ci.sh | sh 17 | - ros -e '(ql:update-all-dists :prompt nil)' 18 | - ros install prove 19 | cache: 20 | directories: 21 | - $HOME/.roswell 22 | - $HOME/.config/common-lisp 23 | before_script: 24 | - ros --version 25 | - ros install $LISP 26 | - ros use $LISP 27 | - ros config 28 | - ros run -- --version 29 | - ./autogen.sh 30 | - ./configure --with-lisp=$LISP 31 | script: 32 | - make 33 | - make tests 34 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | GNU GENERAL PUBLIC LICENSE 2 | Version 2, June 1991 3 | 4 | Copyright (C) 1989, 1991 Free Software Foundation, Inc., 5 | 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 6 | Everyone is permitted to copy and distribute verbatim copies 7 | of this license document, but changing it is not allowed. 8 | 9 | Preamble 10 | 11 | The licenses for most software are designed to take away your 12 | freedom to share and change it. By contrast, the GNU General Public 13 | License is intended to guarantee your freedom to share and change free 14 | software--to make sure the software is free for all its users. This 15 | General Public License applies to most of the Free Software 16 | Foundation's software and to any other program whose authors commit to 17 | using it. (Some other Free Software Foundation software is covered by 18 | the GNU Lesser General Public License instead.) You can apply it to 19 | your programs, too. 20 | 21 | When we speak of free software, we are referring to freedom, not 22 | price. Our General Public Licenses are designed to make sure that you 23 | have the freedom to distribute copies of free software (and charge for 24 | this service if you wish), that you receive source code or can get it 25 | if you want it, that you can change the software or use pieces of it 26 | in new free programs; and that you know you can do these things. 27 | 28 | To protect your rights, we need to make restrictions that forbid 29 | anyone to deny you these rights or to ask you to surrender the rights. 30 | These restrictions translate to certain responsibilities for you if you 31 | distribute copies of the software, or if you modify it. 32 | 33 | For example, if you distribute copies of such a program, whether 34 | gratis or for a fee, you must give the recipients all the rights that 35 | you have. You must make sure that they, too, receive or can get the 36 | source code. And you must show them these terms so they know their 37 | rights. 38 | 39 | We protect your rights with two steps: (1) copyright the software, and 40 | (2) offer you this license which gives you legal permission to copy, 41 | distribute and/or modify the software. 42 | 43 | Also, for each author's protection and ours, we want to make certain 44 | that everyone understands that there is no warranty for this free 45 | software. If the software is modified by someone else and passed on, we 46 | want its recipients to know that what they have is not the original, so 47 | that any problems introduced by others will not reflect on the original 48 | authors' reputations. 49 | 50 | Finally, any free program is threatened constantly by software 51 | patents. We wish to avoid the danger that redistributors of a free 52 | program will individually obtain patent licenses, in effect making the 53 | program proprietary. To prevent this, we have made it clear that any 54 | patent must be licensed for everyone's free use or not licensed at all. 55 | 56 | The precise terms and conditions for copying, distribution and 57 | modification follow. 58 | 59 | GNU GENERAL PUBLIC LICENSE 60 | TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 61 | 62 | 0. This License applies to any program or other work which contains 63 | a notice placed by the copyright holder saying it may be distributed 64 | under the terms of this General Public License. The "Program", below, 65 | refers to any such program or work, and a "work based on the Program" 66 | means either the Program or any derivative work under copyright law: 67 | that is to say, a work containing the Program or a portion of it, 68 | either verbatim or with modifications and/or translated into another 69 | language. (Hereinafter, translation is included without limitation in 70 | the term "modification".) Each licensee is addressed as "you". 71 | 72 | Activities other than copying, distribution and modification are not 73 | covered by this License; they are outside its scope. The act of 74 | running the Program is not restricted, and the output from the Program 75 | is covered only if its contents constitute a work based on the 76 | Program (independent of having been made by running the Program). 77 | Whether that is true depends on what the Program does. 78 | 79 | 1. You may copy and distribute verbatim copies of the Program's 80 | source code as you receive it, in any medium, provided that you 81 | conspicuously and appropriately publish on each copy an appropriate 82 | copyright notice and disclaimer of warranty; keep intact all the 83 | notices that refer to this License and to the absence of any warranty; 84 | and give any other recipients of the Program a copy of this License 85 | along with the Program. 86 | 87 | You may charge a fee for the physical act of transferring a copy, and 88 | you may at your option offer warranty protection in exchange for a fee. 89 | 90 | 2. You may modify your copy or copies of the Program or any portion 91 | of it, thus forming a work based on the Program, and copy and 92 | distribute such modifications or work under the terms of Section 1 93 | above, provided that you also meet all of these conditions: 94 | 95 | a) You must cause the modified files to carry prominent notices 96 | stating that you changed the files and the date of any change. 97 | 98 | b) You must cause any work that you distribute or publish, that in 99 | whole or in part contains or is derived from the Program or any 100 | part thereof, to be licensed as a whole at no charge to all third 101 | parties under the terms of this License. 102 | 103 | c) If the modified program normally reads commands interactively 104 | when run, you must cause it, when started running for such 105 | interactive use in the most ordinary way, to print or display an 106 | announcement including an appropriate copyright notice and a 107 | notice that there is no warranty (or else, saying that you provide 108 | a warranty) and that users may redistribute the program under 109 | these conditions, and telling the user how to view a copy of this 110 | License. (Exception: if the Program itself is interactive but 111 | does not normally print such an announcement, your work based on 112 | the Program is not required to print an announcement.) 113 | 114 | These requirements apply to the modified work as a whole. If 115 | identifiable sections of that work are not derived from the Program, 116 | and can be reasonably considered independent and separate works in 117 | themselves, then this License, and its terms, do not apply to those 118 | sections when you distribute them as separate works. But when you 119 | distribute the same sections as part of a whole which is a work based 120 | on the Program, the distribution of the whole must be on the terms of 121 | this License, whose permissions for other licensees extend to the 122 | entire whole, and thus to each and every part regardless of who wrote it. 123 | 124 | Thus, it is not the intent of this section to claim rights or contest 125 | your rights to work written entirely by you; rather, the intent is to 126 | exercise the right to control the distribution of derivative or 127 | collective works based on the Program. 128 | 129 | In addition, mere aggregation of another work not based on the Program 130 | with the Program (or with a work based on the Program) on a volume of 131 | a storage or distribution medium does not bring the other work under 132 | the scope of this License. 133 | 134 | 3. You may copy and distribute the Program (or a work based on it, 135 | under Section 2) in object code or executable form under the terms of 136 | Sections 1 and 2 above provided that you also do one of the following: 137 | 138 | a) Accompany it with the complete corresponding machine-readable 139 | source code, which must be distributed under the terms of Sections 140 | 1 and 2 above on a medium customarily used for software interchange; or, 141 | 142 | b) Accompany it with a written offer, valid for at least three 143 | years, to give any third party, for a charge no more than your 144 | cost of physically performing source distribution, a complete 145 | machine-readable copy of the corresponding source code, to be 146 | distributed under the terms of Sections 1 and 2 above on a medium 147 | customarily used for software interchange; or, 148 | 149 | c) Accompany it with the information you received as to the offer 150 | to distribute corresponding source code. (This alternative is 151 | allowed only for noncommercial distribution and only if you 152 | received the program in object code or executable form with such 153 | an offer, in accord with Subsection b above.) 154 | 155 | The source code for a work means the preferred form of the work for 156 | making modifications to it. For an executable work, complete source 157 | code means all the source code for all modules it contains, plus any 158 | associated interface definition files, plus the scripts used to 159 | control compilation and installation of the executable. However, as a 160 | special exception, the source code distributed need not include 161 | anything that is normally distributed (in either source or binary 162 | form) with the major components (compiler, kernel, and so on) of the 163 | operating system on which the executable runs, unless that component 164 | itself accompanies the executable. 165 | 166 | If distribution of executable or object code is made by offering 167 | access to copy from a designated place, then offering equivalent 168 | access to copy the source code from the same place counts as 169 | distribution of the source code, even though third parties are not 170 | compelled to copy the source along with the object code. 171 | 172 | 4. You may not copy, modify, sublicense, or distribute the Program 173 | except as expressly provided under this License. Any attempt 174 | otherwise to copy, modify, sublicense or distribute the Program is 175 | void, and will automatically terminate your rights under this License. 176 | However, parties who have received copies, or rights, from you under 177 | this License will not have their licenses terminated so long as such 178 | parties remain in full compliance. 179 | 180 | 5. You are not required to accept this License, since you have not 181 | signed it. However, nothing else grants you permission to modify or 182 | distribute the Program or its derivative works. These actions are 183 | prohibited by law if you do not accept this License. Therefore, by 184 | modifying or distributing the Program (or any work based on the 185 | Program), you indicate your acceptance of this License to do so, and 186 | all its terms and conditions for copying, distributing or modifying 187 | the Program or works based on it. 188 | 189 | 6. Each time you redistribute the Program (or any work based on the 190 | Program), the recipient automatically receives a license from the 191 | original licensor to copy, distribute or modify the Program subject to 192 | these terms and conditions. You may not impose any further 193 | restrictions on the recipients' exercise of the rights granted herein. 194 | You are not responsible for enforcing compliance by third parties to 195 | this License. 196 | 197 | 7. If, as a consequence of a court judgment or allegation of patent 198 | infringement or for any other reason (not limited to patent issues), 199 | conditions are imposed on you (whether by court order, agreement or 200 | otherwise) that contradict the conditions of this License, they do not 201 | excuse you from the conditions of this License. If you cannot 202 | distribute so as to satisfy simultaneously your obligations under this 203 | License and any other pertinent obligations, then as a consequence you 204 | may not distribute the Program at all. For example, if a patent 205 | license would not permit royalty-free redistribution of the Program by 206 | all those who receive copies directly or indirectly through you, then 207 | the only way you could satisfy both it and this License would be to 208 | refrain entirely from distribution of the Program. 209 | 210 | If any portion of this section is held invalid or unenforceable under 211 | any particular circumstance, the balance of the section is intended to 212 | apply and the section as a whole is intended to apply in other 213 | circumstances. 214 | 215 | It is not the purpose of this section to induce you to infringe any 216 | patents or other property right claims or to contest validity of any 217 | such claims; this section has the sole purpose of protecting the 218 | integrity of the free software distribution system, which is 219 | implemented by public license practices. Many people have made 220 | generous contributions to the wide range of software distributed 221 | through that system in reliance on consistent application of that 222 | system; it is up to the author/donor to decide if he or she is willing 223 | to distribute software through any other system and a licensee cannot 224 | impose that choice. 225 | 226 | This section is intended to make thoroughly clear what is believed to 227 | be a consequence of the rest of this License. 228 | 229 | 8. If the distribution and/or use of the Program is restricted in 230 | certain countries either by patents or by copyrighted interfaces, the 231 | original copyright holder who places the Program under this License 232 | may add an explicit geographical distribution limitation excluding 233 | those countries, so that distribution is permitted only in or among 234 | countries not thus excluded. In such case, this License incorporates 235 | the limitation as if written in the body of this License. 236 | 237 | 9. The Free Software Foundation may publish revised and/or new versions 238 | of the General Public License from time to time. Such new versions will 239 | be similar in spirit to the present version, but may differ in detail to 240 | address new problems or concerns. 241 | 242 | Each version is given a distinguishing version number. If the Program 243 | specifies a version number of this License which applies to it and "any 244 | later version", you have the option of following the terms and conditions 245 | either of that version or of any later version published by the Free 246 | Software Foundation. If the Program does not specify a version number of 247 | this License, you may choose any version ever published by the Free Software 248 | Foundation. 249 | 250 | 10. If you wish to incorporate parts of the Program into other free 251 | programs whose distribution conditions are different, write to the author 252 | to ask for permission. For software which is copyrighted by the Free 253 | Software Foundation, write to the Free Software Foundation; we sometimes 254 | make exceptions for this. Our decision will be guided by the two goals 255 | of preserving the free status of all derivatives of our free software and 256 | of promoting the sharing and reuse of software generally. 257 | 258 | NO WARRANTY 259 | 260 | 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY 261 | FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN 262 | OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES 263 | PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED 264 | OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 265 | MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS 266 | TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE 267 | PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, 268 | REPAIR OR CORRECTION. 269 | 270 | 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING 271 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR 272 | REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, 273 | INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING 274 | OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED 275 | TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY 276 | YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER 277 | PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE 278 | POSSIBILITY OF SUCH DAMAGES. 279 | 280 | END OF TERMS AND CONDITIONS 281 | 282 | How to Apply These Terms to Your New Programs 283 | 284 | If you develop a new program, and you want it to be of the greatest 285 | possible use to the public, the best way to achieve this is to make it 286 | free software which everyone can redistribute and change under these terms. 287 | 288 | To do so, attach the following notices to the program. It is safest 289 | to attach them to the start of each source file to most effectively 290 | convey the exclusion of warranty; and each file should have at least 291 | the "copyright" line and a pointer to where the full notice is found. 292 | 293 | {description} 294 | Copyright (C) {year} {fullname} 295 | 296 | This program is free software; you can redistribute it and/or modify 297 | it under the terms of the GNU General Public License as published by 298 | the Free Software Foundation; either version 2 of the License, or 299 | (at your option) any later version. 300 | 301 | This program is distributed in the hope that it will be useful, 302 | but WITHOUT ANY WARRANTY; without even the implied warranty of 303 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 304 | GNU General Public License for more details. 305 | 306 | You should have received a copy of the GNU General Public License along 307 | with this program; if not, write to the Free Software Foundation, Inc., 308 | 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 309 | 310 | Also add information on how to contact you by electronic and paper mail. 311 | 312 | If the program is interactive, make it output a short notice like this 313 | when it starts in an interactive mode: 314 | 315 | Gnomovision version 69, Copyright (C) year name of author 316 | Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. 317 | This is free software, and you are welcome to redistribute it 318 | under certain conditions; type `show c' for details. 319 | 320 | The hypothetical commands `show w' and `show c' should show the appropriate 321 | parts of the General Public License. Of course, the commands you use may 322 | be called something other than `show w' and `show c'; they could even be 323 | mouse-clicks or menu items--whatever suits your program. 324 | 325 | You should also get your employer (if you work as a programmer) or your 326 | school, if any, to sign a "copyright disclaimer" for the program, if 327 | necessary. Here is a sample; alter the names: 328 | 329 | Yoyodyne, Inc., hereby disclaims all copyright interest in the program 330 | `Gnomovision' (which makes passes at compilers) written by James Hacker. 331 | 332 | {signature of Ty Coon}, 1 April 1989 333 | Ty Coon, President of Vice 334 | 335 | This General Public License does not permit incorporating your program into 336 | proprietary programs. If your program is a subroutine library, you may 337 | consider it more useful to permit linking proprietary applications with the 338 | library. If this is what you want to do, use the GNU Lesser General 339 | Public License instead of this License. 340 | 341 | -------------------------------------------------------------------------------- /Makefile.in: -------------------------------------------------------------------------------- 1 | LISP=@LISP@ 2 | 3 | datarootdir = @datarootdir@ 4 | prefix=@prefix@ 5 | exec_prefix= @exec_prefix@ 6 | bindir=@bindir@ 7 | infodir=@infodir@ 8 | 9 | # You shouldn't have to edit past this 10 | 11 | FILES=paulownia.asd $(shell grep -o ":file \".*\"" paulownia.asd | sed 's,:file ",,g' | sed 's,",.lisp,g' ) 12 | 13 | all: paulownia # paulownia.info 14 | 15 | paulownia.info: paulownia.texi 16 | makeinfo paulownia.texi 17 | 18 | paulownia: $(FILES) paulownia.ros 19 | ros use $(LISP) 20 | ros build paulownia.ros 21 | tests: paulownia-tests.asd 22 | run-prove $^ 23 | @echo "\nDone!" 24 | clean: 25 | rm -f *.fasl *.fas *.lib *.*fsl 26 | rm -f *.log *.fns *.fn *.aux *.cp *.ky *.log *.toc *.pg *.tp *.vr *.vrs 27 | rm -f paulownia paulownia.texi paulownia.info 28 | 29 | install: paulownia.info paulownia 30 | test -z "$(destdir)$(bindir)" || mkdir -p "$(destdir)$(bindir)" 31 | install -m 755 paulownia "$(destdir)$(bindir)" 32 | test -z "$(destdir)$(infodir)" || mkdir -p "$(destdir)$(infodir)" 33 | install -m 644 paulownia.info "$(destdir)$(infodir)" 34 | install-info --info-dir="$(destdir)$(infodir)" "$(destdir)$(infodir)/paulownia.info" 35 | install-modules: 36 | git clone https://github.com/paulownia/stumpwm-contrib.git ~/.paulownia.d/modules 37 | uninstall: 38 | rm "$(destdir)$(bindir)/paulownia" 39 | install-info --info-dir="$(destdir)$(infodir)" --remove "$(destdir)$(infodir)/paulownia.info" 40 | rm "$(destdir)$(infodir)/paulownia.info" 41 | 42 | # End of file 43 | -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | * Paulownia is dead, long live stumpwm! This project is no longer developed. 2 | 3 | * Codename: Paulownia 4 | [[https://travis-ci.org/stumpwm/paulownia][https://travis-ci.org/stumpwm/paulownia.svg?branch=master]] 5 | 6 | StumpWM's codebase while stable is showing its age. Furthermore there 7 | have been recent developments in the common lisp ecosystem that 8 | stumpwm has been insulated from. 9 | 10 | This is an attempt to modernize the stumpwm codebase while fixing some 11 | of stumpwm's Achilles heels. 12 | ** Design Goals 13 | (From achievable to lofty) 14 | - Test driven design. Unit tests that matter 15 | - Re-use as much code from stumpwm as possible, don't reinvent the 16 | wheel unless its broken 17 | - Support for non-ascii input 18 | - Utilize existing libraries rather than re-implementing subsets of 19 | existing functionality 20 | - Tighter emacs integration 21 | - Support for multiple backends (wayland, mir, X11) 22 | ** Technology 23 | - [[roswell]] for building/deploying 24 | - [[https://github.com/fukamachi/prove][prove]] for unit testing 25 | - travis-ci for cloud CI testing 26 | - [[https://shinmera.github.io/qtools/][qtools]] for gui components 27 | - various packages carved out of the stumpwm codebase and re-packaged 28 | for quicklisp distribution 29 | * Why Paulownia? 30 | It seems like a strange name, stumpwm reminds me of a tree stump, the 31 | idea behind this is to burn stumpwm to the ground and grow it back up 32 | stronger and better than before. If you google [[https://www.google.com/search?q=phoenix%2Btree][phoenix tree]], the top 33 | hit is the wiki page describing the genus Paulownia. The wiki page 34 | actually draws a lot of analogies to the goals of this project, so the 35 | name was chosen. 36 | 37 | 38 | -------------------------------------------------------------------------------- /autogen.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # generate the configure script 4 | 5 | autoconf 6 | -------------------------------------------------------------------------------- /backends/display-server.lisp: -------------------------------------------------------------------------------- 1 | ;; Defines the generic methods for interacting with a display server. 2 | ;; Signatures are modeled after clx/xlib, but as long as the 3 | ;; equivalent is implemented in the native OS's language with the same 4 | ;; function signature, paulownia can operate 5 | (in-package :paulownia) 6 | (export '(*last-unhandled-error*)) 7 | (defvar *last-unhandled-error* nil 8 | "If an unrecoverable error occurs, this variable will contain the 9 | condition and the backtrace.") 10 | 11 | (defun parse-display-string (display) 12 | "Parse an X11 DISPLAY string and return the host and display from it." 13 | (ppcre:register-groups-bind (protocol host ('parse-integer display screen)) 14 | ("^(?:(.*?)/)?(.*?)?:(\\d+)(?:\\.(\\d+))?" display :sharedp t) 15 | (values 16 | ;; clx doesn't like (vector character *) 17 | (coerce (or host "") 18 | '(simple-array character (*))) 19 | display screen 20 | (cond (protocol 21 | (intern1 protocol :keyword)) 22 | ((or (string= host "") 23 | (string-equal host "unix")) 24 | :local) 25 | (t :internet))))) 26 | 27 | 28 | (defun error-handler (display error-key &rest key-vals &key asynchronous &allow-other-keys) 29 | "Handle X errors" 30 | (cond 31 | ;; ignore asynchronous window errors 32 | ((and asynchronous 33 | (find error-key '(xlib:window-error xlib:drawable-error xlib:match-error))) 34 | ;; (dformat 4 "Ignoring error: ~s~%" error-key) 35 | ) 36 | ((eq error-key 'xlib:access-error) 37 | (write-line "Another window manager is running.") 38 | (throw :top-level :quit)) 39 | ;; all other asynchronous errors are printed. 40 | ;; (asynchronous 41 | ;; (message "Caught Asynchronous X Error: ~s ~s" error-key key-vals)) 42 | (t 43 | (apply 'error error-key :display display :error-key error-key key-vals)))) 44 | -------------------------------------------------------------------------------- /backends/gui.lisp: -------------------------------------------------------------------------------- 1 | ;; Defines the generic methods for gui interaction so that paulownia 2 | ;; can call out to various constructs without worrying about how they 3 | ;; are created and rendered. paulownia provides its own 4 | ;; implementation in xlib, but others can be written in any gui 5 | ;; framework available in common lisp 6 | (in-package :paulownia) 7 | (export '(message 8 | )) 9 | 10 | (defgeneric message (control-string &rest args) 11 | (:documentation "Run @var{control-string} and @{args} through 12 | `format' and echo the result on the screen. ")) 13 | (defgeneric restarts-menu (err) 14 | (:documentation "Display a menu with the active restarts and let the 15 | user pick one. @var{err} is the error being recovered from. If the 16 | user aborts the menu, the error is re-signaled.")) 17 | 18 | (defmacro with-restarts-menu (&body body) 19 | "Execute BODY. If an error occurs allow the user to pick a 20 | restart from a menu of possible restarts. If a restart is not 21 | chosen, resignal the error." 22 | (let ((c (gensym))) 23 | `(handler-bind 24 | ((warning #'muffle-warning) 25 | ((or serious-condition error) 26 | (lambda (,c) 27 | (restarts-menu ,c) 28 | (signal ,c)))) 29 | ,@body))) 30 | 31 | (defmethod message (control-string &rest args) 32 | "Dummy method flushes message to stdout rather than displaying it in 33 | a gui window" 34 | (apply 'format t control-string args)) 35 | -------------------------------------------------------------------------------- /base/README.txt: -------------------------------------------------------------------------------- 1 | This is the stub README.txt for the "swm-timers" project. 2 | -------------------------------------------------------------------------------- /base/data-dir.lisp: -------------------------------------------------------------------------------- 1 | (in-package :paulownia) 2 | (export '(*data-dir* 3 | redirect-all-output 4 | data-dir-file 5 | with-data-file)) 6 | 7 | (defvar *data-dir* nil 8 | "The directory used by stumpwm to store data between sessions.") 9 | 10 | (defvar *redirect-stream* nil 11 | "This variable Keeps track of the stream all output is sent to when 12 | `redirect-all-output' is called so if it changes we can close it 13 | before reopening.") 14 | 15 | (defun redirect-all-output (file) 16 | "Elect to redirect all output to the specified file. For instance, 17 | if you want everything to go to ~/.stumpwm.d/debug-output.txt you would 18 | do: 19 | 20 | @example 21 | (redirect-all-output (data-dir-file \"debug-output\" \"txt\")) 22 | @end example 23 | " 24 | (when (typep *redirect-stream* 'file-stream) 25 | (close *redirect-stream*)) 26 | (setf *redirect-stream* (open file :direction :output :if-exists :append :if-does-not-exist :create) 27 | *error-output* *redirect-stream* 28 | *standard-output* *redirect-stream* 29 | *trace-output* *redirect-stream* 30 | *debug-stream* *redirect-stream*)) 31 | 32 | (defun data-dir-file (name &optional type) 33 | "Return a pathname inside stumpwm's data dir with the specified name and type" 34 | (ensure-directories-exist *data-dir*) 35 | (make-pathname :name name :type type :defaults *data-dir*)) 36 | 37 | (defmacro with-data-file ((s file &rest keys &key (if-exists :supersede) &allow-other-keys) &body body) 38 | "Open a file in StumpWM's data directory. keyword arguments are sent 39 | directly to OPEN. Note that IF-EXISTS defaults to :supersede, instead 40 | of :error." 41 | (declare (ignorable if-exists)) 42 | `(progn 43 | (ensure-directories-exist *data-dir*) 44 | (with-open-file (,s ,(merge-pathnames file *data-dir*) 45 | ,@keys) 46 | ,@body))) 47 | -------------------------------------------------------------------------------- /base/debug.lisp: -------------------------------------------------------------------------------- 1 | (in-package :paulownia) 2 | 3 | (export '(*debug-level* 4 | *debug-expose-events* 5 | *debug-stream* 6 | dformat)) 7 | 8 | 9 | (defvar *debug-level* 0 10 | "Set this variable to a number > 0 to turn on debugging. The greater the number the more debugging output.") 11 | 12 | (defvar *debug-expose-events* nil 13 | "Set this variable for a visual indication of expose events on internal StumpWM windows.") 14 | 15 | (defvar *debug-stream* *error-output* 16 | "This is the stream debugging output is sent to. It defaults to 17 | *error-output*. It may be more convenient for you to pipe debugging 18 | output directly to a file.") 19 | 20 | (defun dformat (level fmt &rest args) 21 | (when (>= *debug-level* level) 22 | (multiple-value-bind (sec m h) (decode-universal-time (get-universal-time)) 23 | (format *debug-stream* "~2,'0d:~2,'0d:~2,'0d " h m sec)) 24 | ;; strip out non base-char chars quick-n-dirty like 25 | (write-string (map 'string (lambda (ch) 26 | (if (typep ch 'standard-char) 27 | ch #\?)) 28 | (apply 'format nil fmt args)) 29 | *debug-stream*) 30 | (force-output *debug-stream*))) 31 | -------------------------------------------------------------------------------- /base/helpers.lisp: -------------------------------------------------------------------------------- 1 | (in-package :paulownia) 2 | 3 | 4 | (defun intern1 (thing &optional (package *package*) (rt *readtable*)) 5 | "A DWIM intern." 6 | (intern 7 | (ecase (readtable-case rt) 8 | (:upcase (string-upcase thing)) 9 | (:downcase (string-downcase thing)) 10 | ;; Prooobably this is what they want? It could make sense to 11 | ;; upcase them as well. 12 | (:preserve thing) 13 | (:invert (string-downcase thing))) 14 | package)) 15 | -------------------------------------------------------------------------------- /base/hooks.lisp: -------------------------------------------------------------------------------- 1 | (in-package :paulownia) 2 | 3 | (export '(*command-mode-start-hook* 4 | *command-mode-end-hook* 5 | *urgent-window-hook* 6 | *new-window-hook* 7 | *destroy-window-hook* 8 | *focus-window-hook* 9 | *place-window-hook* 10 | *start-hook* 11 | *quit-hook* 12 | *internal-loop-hook* 13 | *event-processing-hook* 14 | *focus-frame-hook* 15 | *new-frame-hook* 16 | *split-frame-hook* 17 | *message-hook* 18 | *top-level-error-hook* 19 | *focus-group-hook* 20 | *key-press-hook* 21 | *root-click-hook* 22 | *new-mode-line-hook* 23 | *destroy-mode-line-hook* 24 | *mode-line-click-hook* 25 | *pre-command-hook* 26 | *post-command-hook* 27 | add-hook 28 | remove-hook 29 | run-hook 30 | run-hook-with-args)) 31 | 32 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 33 | ;; Variables and parameters 34 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 35 | 36 | (defvar *command-mode-start-hook* '(command-mode-start-message) 37 | "A hook called whenever command mode is started") 38 | 39 | (defvar *command-mode-end-hook* '(command-mode-end-message) 40 | "A hook called whenever command mode is ended") 41 | 42 | (defvar *urgent-window-hook* '() 43 | "A hook called whenever a window sets the property indicating that 44 | it demands the user's attention") 45 | 46 | (defvar *map-window-hook* '() 47 | "A hook called whenever a window is mapped.") 48 | 49 | (defvar *unmap-window-hook* '() 50 | "A hook called whenever a window is withdrawn.") 51 | 52 | (defvar *new-window-hook* '() 53 | "A hook called whenever a window is added to the window list. This 54 | includes a genuinely new window as well as bringing a withdrawn window 55 | back into the window list.") 56 | 57 | (defvar *destroy-window-hook* '() 58 | "A hook called whenever a window is destroyed or withdrawn.") 59 | 60 | (defvar *focus-window-hook* '() 61 | "A hook called when a window is given focus. It is called with 2 62 | arguments: the current window and the last window (could be nil).") 63 | 64 | (defvar *place-window-hook* '() 65 | "A hook called whenever a window is placed by rule. Arguments are 66 | window group and frame") 67 | 68 | (defvar *start-hook* '() 69 | "A hook called when stumpwm starts.") 70 | 71 | (defvar *quit-hook* '() 72 | "A hook called when stumpwm quits.") 73 | 74 | (defvar *internal-loop-hook* '() 75 | "A hook called inside stumpwm's inner loop.") 76 | 77 | (defvar *event-processing-hook* '() 78 | "A hook called inside stumpwm's inner loop, before the default event 79 | processing takes place. This hook is run inside (with-event-queue ...).") 80 | 81 | (defvar *focus-frame-hook* '() 82 | "A hook called when a frame is given focus. The hook functions are 83 | called with 2 arguments: the current frame and the last frame.") 84 | 85 | (defvar *new-frame-hook* '() 86 | "A hook called when a new frame is created. the hook is called with 87 | the frame as an argument.") 88 | 89 | (defvar *split-frame-hook* '() 90 | "A hook called when a frame is split. the hook is called with 91 | the old frame (window is removed), and two new frames as arguments.") 92 | 93 | (defvar *message-hook* '() 94 | "A hook called whenever stumpwm displays a message. The hook 95 | function is passed any number of arguments. Each argument is a 96 | line of text.") 97 | 98 | (defvar *top-level-error-hook* '() 99 | "Called when a top level error occurs. Note that this hook is 100 | run before the error is dealt with according to 101 | *top-level-error-action*.") 102 | 103 | (defvar *focus-group-hook* '() 104 | "A hook called whenever stumpwm switches groups. It is called with 2 arguments: the current group and the last group.") 105 | 106 | (defvar *key-press-hook* '() 107 | "A hook called whenever a key under *top-map* is pressed. 108 | It is called with 3 argument: the key, the (possibly incomplete) key 109 | sequence it is a part of, and command value bound to the key.") 110 | 111 | (defvar *root-click-hook* '() 112 | "A hook called whenever there is a mouse click on the root 113 | window. Called with 4 arguments, the screen containing the root 114 | window, the button clicked, and the x and y of the pointer.") 115 | 116 | (defvar *new-mode-line-hook* '() 117 | "Called whenever the mode-line is created. It is called with argument, 118 | the mode-line") 119 | 120 | (defvar *destroy-mode-line-hook* '() 121 | "Called whenever the mode-line is destroyed. It is called with argument, 122 | the mode-line") 123 | 124 | (defvar *mode-line-click-hook* '() 125 | "Called whenever the mode-line is clicked. It is called with 4 arguments, 126 | the mode-line, the button clicked, and the x and y of the pointer.") 127 | 128 | (defvar *pre-command-hook* '() 129 | "Called before a command is called. It is called with 1 argument: 130 | the command as a symbol.") 131 | 132 | (defvar *post-command-hook* '() 133 | "Called after a command is called. It is called with 1 argument: 134 | the command as a symbol.") 135 | ;;;;;;;;;;;;;;;;;;;;;;;;; 136 | ;; Function definitions 137 | ;;;;;;;;;;;;;;;;;;;;;;;;; 138 | (defun run-hook-with-args (hook &rest args) 139 | "Call each function in HOOK and pass args to it." 140 | (handler-case 141 | (with-simple-restart (abort-hooks "Abort running the remaining hooks.") 142 | (with-restarts-menu 143 | (dolist (fn hook) 144 | (with-simple-restart (continue-hooks "Continue running the remaining hooks.") 145 | (apply fn args))))) 146 | (t (c) (message "^B^1*Error on hook ^b~S^B!~% ^n~A" hook c) (values nil c)))) 147 | 148 | (defun run-hook (hook) 149 | "Call each function in HOOK." 150 | (run-hook-with-args hook)) 151 | 152 | (defmacro add-hook (hook fn) 153 | "Add @var{function} to the hook @var{hook-variable}. For example, to 154 | display a message whenever you switch frames: 155 | 156 | @example 157 | \(defun my-rad-fn (to-frame from-frame) 158 | (stumpwm:message \"Mustard!\")) 159 | 160 | \(stumpwm:add-hook stumpwm:*focus-frame-hook* 'my-rad-fn) 161 | @end example" 162 | `(setf ,hook (adjoin ,fn ,hook))) 163 | 164 | (defmacro remove-hook (hook fn) 165 | "Remove the specified function from the hook." 166 | `(setf ,hook (remove ,fn ,hook))) 167 | -------------------------------------------------------------------------------- /base/load-rc.lisp: -------------------------------------------------------------------------------- 1 | (in-package :paulownia) 2 | (export '(load-rc-file)) 3 | 4 | (defun load-rc-file (&optional (catch-errors t)) 5 | "Load the user's .paulowniarc file or the system wide one if that 6 | doesn't exist. Returns a values list: whether the file loaded (t if no 7 | rc files exist), the error if it didn't, and the rc file that was 8 | loaded. When CATCH-ERRORS is nil, errors are left to be handled 9 | further up. " 10 | (let* ((xdg-config-dir 11 | (let ((dir (uiop:getenv "XDG_CONFIG_HOME"))) 12 | (if (or (not dir) (string= dir "")) 13 | (merge-pathnames #p".config/" (user-homedir-pathname)) 14 | dir))) 15 | (user-rc 16 | (probe-file (merge-pathnames #p".paulowniarc" (user-homedir-pathname)))) 17 | (dir-rc 18 | (probe-file (merge-pathnames #p".paulownia.d/init.lisp" (user-homedir-pathname)))) 19 | (conf-rc 20 | (probe-file (merge-pathnames #p"paulownia/config" xdg-config-dir))) 21 | (etc-rc (probe-file #p"/etc/paulowniarc")) 22 | (rc (or user-rc dir-rc conf-rc etc-rc))) 23 | (if rc 24 | (if catch-errors 25 | (handler-case (load rc) 26 | (error (c) (values nil (format nil "~a" c) rc)) 27 | (:no-error (&rest args) (declare (ignore args)) (values t nil rc))) 28 | (progn 29 | (load rc) 30 | (values t nil rc))) 31 | (values t nil nil)))) 32 | -------------------------------------------------------------------------------- /base/primitives.lisp: -------------------------------------------------------------------------------- 1 | ;; Copyright (C) 2003-2008 Shawn Betts 2 | ;; 3 | ;; This file is part of stumpwm. 4 | ;; 5 | ;; stumpwm is free software; you can redistribute it and/or modify 6 | ;; it under the terms of the GNU General Public License as published by 7 | ;; the Free Software Foundation; either version 2, or (at your option) 8 | ;; any later version. 9 | 10 | ;; stumpwm is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ;; GNU General Public License for more details. 14 | 15 | ;; You should have received a copy of the GNU General Public License 16 | ;; along with this software; see the file COPYING. If not, see 17 | ;; . 18 | 19 | ;; Commentary: 20 | ;; 21 | ;; This file contains primitive data structures and functions used 22 | ;; throughout stumpwm. 23 | ;; 24 | ;; Code: 25 | 26 | (in-package :stumpwm) 27 | 28 | #+ecl (require "clx") 29 | 30 | (export '(*suppress-window-placement-indicator* 31 | *timeout-wait* 32 | *timeout-frame-indicator-wait* 33 | *suppress-frame-indicator* 34 | ;; Frame settings 35 | *frame-indicator-text* 36 | *frame-indicator-timer* 37 | *frame-number-map* 38 | *min-frame-width* 39 | *min-frame-height* 40 | *new-frame-action* 41 | *new-window-preferred-frame* 42 | *root-click-focuses-frame* 43 | ;; Frame accessors 44 | frame-x 45 | frame-y 46 | frame-width 47 | frame-height 48 | define-frame-preference 49 | ;; Message settings 50 | *suppress-abort-messages* 51 | *message-window-timer* 52 | *message-window-padding* 53 | *message-window-gravity* 54 | *max-last-message-size* 55 | *suppress-deny-messages* 56 | *startup-message* 57 | command-mode-start-message 58 | command-mode-end-message 59 | 60 | *shell-program* 61 | *maxsize-border-width* 62 | *transient-border-width* 63 | *normal-border-width* 64 | *text-color* 65 | *window-events* 66 | *window-parent-events* 67 | *editor-bindings* 68 | *input-window-gravity* 69 | *normal-gravity* 70 | *maxsize-gravity* 71 | *transient-gravity* 72 | *top-level-error-action* 73 | *window-name-source* 74 | *all-modifiers* 75 | *modifiers* 76 | *screen-list* 77 | *initializing* 78 | *processing-existing-windows* 79 | *executing-stumpwm-command* 80 | *debug-level* 81 | *debug-expose-events* 82 | *debug-stream* 83 | *window-formatters* 84 | *window-format* 85 | *group-formatters* 86 | *group-format* 87 | *list-hidden-groups* 88 | *x-selection* 89 | *last-command* 90 | *record-last-msg-override* 91 | *suppress-echo-timeout* 92 | *run-or-raise-all-groups* 93 | *run-or-raise-all-screens* 94 | *deny-map-request* 95 | *deny-raise-request* 96 | *honor-window-moves* 97 | *resize-hides-windows* 98 | *default-package* 99 | *window-placement-rules* 100 | *mouse-focus-policy* 101 | *banish-pointer-to* 102 | *xwin-to-window* 103 | *resize-map* 104 | *default-group-name* 105 | *window-border-style* 106 | ;; Lisp utils 107 | concat 108 | flatten 109 | split-string 110 | move-to-head 111 | format-expand 112 | ;; Stumpwm utils 113 | clear-window-placement-rules 114 | dformat 115 | 116 | 117 | ;; Screen accessors 118 | screen-heads 119 | screen-root 120 | screen-focus 121 | screen-float-focus-color 122 | screen-float-unfocus-color 123 | 124 | ;; Window states 125 | +withdrawn-state+ 126 | +normal-state+ 127 | +iconic-state+ 128 | 129 | ;; Modifiers 130 | modifiers 131 | modifiers-p 132 | modifiers-alt 133 | modifiers-altgr 134 | modifiers-super 135 | modifiers-meta 136 | modifiers-hyper 137 | modifiers-numlock 138 | ;; Conditions 139 | stumpwm-condition 140 | stumpwm-error 141 | stumpwm-warning)) 142 | 143 | 144 | ;;; Message Timer 145 | (defvar *suppress-abort-messages* nil 146 | "Suppress abort message when non-nil.") 147 | 148 | (defvar *timeout-wait* 5 149 | "Specifies, in seconds, how long a message will appear for. This must 150 | be an integer.") 151 | 152 | (defvar *timeout-frame-indicator-wait* 1 153 | "The amount of time a frame indicator timeout takes.") 154 | 155 | (defvar *frame-indicator-timer* nil 156 | "Keep track of the timer that hides the frame indicator.") 157 | 158 | (defvar *frame-indicator-text* " Current Frame " 159 | "What appears in the frame indicator window?") 160 | 161 | (defvar *suppress-frame-indicator* nil 162 | "Set this to T if you never want to see the frame indicator.") 163 | 164 | (defvar *suppress-window-placement-indicator* nil 165 | "Set to T if you never want to see messages that windows were placed 166 | according to rules.") 167 | 168 | (defvar *message-window-timer* nil 169 | "Keep track of the timer that hides the message window.") 170 | 171 | ;;; Grabbed pointer 172 | 173 | (defvar *grab-pointer-count* 0 174 | "The number of times the pointer has been grabbed.") 175 | 176 | (defvar *grab-pointer-font* "cursor" 177 | "The font used for the grabbed pointer.") 178 | 179 | (defvar *grab-pointer-character* 64 180 | "ID of a character used for the grabbed pointer.") 181 | 182 | (defvar *grab-pointer-character-mask* 65 183 | "ID of a character mask used for the grabbed pointer.") 184 | 185 | (defvar *grab-pointer-foreground* 186 | (xlib:make-color :red 0.0 :green 0.0 :blue 0.0) 187 | "The foreground color of the grabbed pointer.") 188 | 189 | (defvar *grab-pointer-background* 190 | (xlib:make-color :red 1.0 :green 1.0 :blue 1.0) 191 | "The background color of the grabbed pointer.") 192 | 193 | ;; Data types and globals used by stumpwm 194 | 195 | 196 | (defvar *shell-program* "/bin/sh" 197 | "The shell program used by @code{run-shell-command}.") 198 | 199 | (defvar *maxsize-border-width* 1 200 | "The width in pixels given to the borders of windows with maxsize or ratio hints.") 201 | 202 | (defvar *transient-border-width* 1 203 | "The width in pixels given to the borders of transient or pop-up windows.") 204 | 205 | (defvar *normal-border-width* 1 206 | "The width in pixels given to the borders of regular windows.") 207 | 208 | (defvar *text-color* "white" 209 | "The color of message text.") 210 | 211 | (defvar *menu-maximum-height* nil 212 | "Defines the maxium number of lines to display in the menu before enabling 213 | scrolling. If NIL scrolling is disabled.") 214 | 215 | (defvar *menu-scrolling-step* 1 216 | "Number of lines to scroll when hitting the menu list limit.") 217 | 218 | (defparameter +netwm-supported+ 219 | '(:_NET_SUPPORTING_WM_CHECK 220 | :_NET_NUMBER_OF_DESKTOPS 221 | :_NET_DESKTOP_GEOMETRY 222 | :_NET_DESKTOP_VIEWPORT 223 | :_NET_CURRENT_DESKTOP 224 | :_NET_WM_WINDOW_TYPE 225 | :_NET_WM_STATE 226 | :_NET_WM_STATE_MODAL 227 | :_NET_WM_ALLOWED_ACTIONS 228 | :_NET_WM_STATE_FULLSCREEN 229 | :_NET_WM_STATE_HIDDEN 230 | :_NET_WM_STATE_DEMANDS_ATTENTION 231 | :_NET_WM_FULL_WINDOW_PLACEMENT 232 | :_NET_CLOSE_WINDOW 233 | :_NET_CLIENT_LIST 234 | :_NET_CLIENT_LIST_STACKING 235 | :_NET_ACTIVE_WINDOW 236 | :_NET_WM_DESKTOP 237 | :_KDE_NET_SYSTEM_TRAY_WINDOW_FOR) 238 | "Supported NETWM properties. 239 | Window types are in +WINDOW-TYPES+.") 240 | 241 | (defparameter +netwm-allowed-actions+ 242 | '(:_NET_WM_ACTION_CHANGE_DESKTOP 243 | :_NET_WM_ACTION_FULLSCREEN 244 | :_NET_WM_ACTION_CLOSE) 245 | "Allowed NETWM actions for managed windows") 246 | 247 | (defparameter +netwm-window-types+ 248 | '( 249 | ;; (:_NET_WM_WINDOW_TYPE_DESKTOP . :desktop) 250 | (:_NET_WM_WINDOW_TYPE_DOCK . :dock) 251 | ;; (:_NET_WM_WINDOW_TYPE_TOOLBAR . :toolbar) 252 | ;; (:_NET_WM_WINDOW_TYPE_MENU . :menu) 253 | ;; (:_NET_WM_WINDOW_TYPE_UTILITY . :utility) 254 | ;; (:_NET_WM_WINDOW_TYPE_SPLASH . :splash) 255 | (:_NET_WM_WINDOW_TYPE_DIALOG . :dialog) 256 | (:_NET_WM_WINDOW_TYPE_NORMAL . :normal)) 257 | "Alist mapping NETWM window types to keywords. 258 | Include only those we are ready to support.") 259 | 260 | ;; Window states 261 | (defconstant +withdrawn-state+ 0) 262 | (defconstant +normal-state+ 1) 263 | (defconstant +iconic-state+ 3) 264 | 265 | (defvar *window-events* '(:structure-notify 266 | :property-change 267 | :colormap-change 268 | :focus-change 269 | :enter-window) 270 | "The events to listen for on managed windows.") 271 | 272 | (defvar *window-parent-events* '(:substructure-notify 273 | :substructure-redirect) 274 | 275 | "The events to listen for on managed windows' parents.") 276 | 277 | ;; Message window variables 278 | (defvar *message-window-padding* 5 279 | "The number of pixels that pad the text in the message window.") 280 | 281 | (defvar *message-window-gravity* :top-right 282 | "This variable controls where the message window appears. The follow 283 | are valid values. 284 | @table @asis 285 | @item :top-left 286 | @item :top-right 287 | @item :bottom-left 288 | @item :bottom-right 289 | @item :center 290 | @item :top 291 | @item :left 292 | @item :right 293 | @item :bottom 294 | @end table") 295 | 296 | ;; line editor 297 | (defvar *editor-bindings* nil 298 | "A list of key-bindings for line editing.") 299 | 300 | (defvar *input-window-gravity* :top-right 301 | "This variable controls where the input window appears. The follow 302 | are valid values. 303 | @table @asis 304 | @item :top-left 305 | @item :top-right 306 | @item :bottom-left 307 | @item :bottom-right 308 | @item :center 309 | @item :top 310 | @item :left 311 | @item :right 312 | @item :bottom 313 | @end table") 314 | 315 | ;; default values. use the set-* functions to these attributes 316 | (defparameter +default-foreground-color+ "White") 317 | (defparameter +default-background-color+ "Black") 318 | (defparameter +default-window-background-color+ "Black") 319 | (defparameter +default-border-color+ "White") 320 | (defparameter +default-font-name+ "9x15") 321 | (defparameter +default-focus-color+ "White") 322 | (defparameter +default-unfocus-color+ "Black") 323 | (defparameter +default-float-focus-color+ "Orange") 324 | (defparameter +default-float-unfocus-color+ "SteelBlue4") 325 | (defparameter +default-frame-outline-width+ 2) 326 | 327 | ;; Don't set these variables directly, use set- instead 328 | (defvar *normal-gravity* :center) 329 | (defvar *maxsize-gravity* :center) 330 | (defvar *transient-gravity* :center) 331 | 332 | (defvar *top-level-error-action* :abort 333 | "If an error is encountered at the top level, in 334 | STUMPWM-INTERNAL-LOOP, then this variable decides what action 335 | shall be taken. By default it will print a message to the screen 336 | and to *standard-output*. 337 | 338 | Valid values are :message, :break, :abort. :break will break to the 339 | debugger. This can be problematic because if the user hit's a 340 | mapped key the ENTIRE keyboard will be frozen and you will have 341 | to login remotely to regain control. :abort quits stumpwm.") 342 | 343 | (defvar *window-name-source* :title 344 | "This variable controls what is used for the window's name. The default is @code{:title}. 345 | 346 | @table @code 347 | @item :title 348 | Use the window's title given to it by its owner. 349 | 350 | @item :class 351 | Use the window's resource class. 352 | 353 | @item :resource-name 354 | Use the window's resource name. 355 | @end table") 356 | 357 | (defstruct frame 358 | (number nil :type integer) 359 | x 360 | y 361 | width 362 | height 363 | window) 364 | 365 | (defstruct (head (:include frame)) 366 | ;; point back to the screen this head belongs to 367 | screen 368 | ;; a bar along the top or bottom that displays anything you want. 369 | mode-line) 370 | 371 | (defclass screen () 372 | ((id :initform nil :accessor screen-id) 373 | (host :initform nil :accessor screen-host) 374 | (number :initform nil :accessor screen-number) 375 | (heads :initform nil :accessor screen-heads :documentation 376 | "heads of screen") 377 | (groups :initform nil :accessor screen-groups :documentation 378 | "the list of groups available on this screen") 379 | (current-group :initform nil :accessor screen-current-group) 380 | ;; various colors (as returned by alloc-color) 381 | (border-color :initform nil :accessor screen-border-color) 382 | (fg-color :initform nil :accessor screen-fg-color) 383 | (bg-color :initform nil :accessor screen-bg-color) 384 | (win-bg-color :initform nil :accessor screen-win-bg-color) 385 | (focus-color :initform nil :accessor screen-focus-color) 386 | (unfocus-color :initform nil :accessor screen-unfocus-color) 387 | (float-focus-color :initform nil :accessor screen-float-focus-color) 388 | (float-unfocus-color :initform nil :accessor screen-float-unfocus-color) 389 | (msg-border-width :initform nil :accessor screen-msg-border-width) 390 | (frame-outline-width :initform nil :accessor screen-frame-outline-width) 391 | (fonts :initform '(nil) :accessor screen-fonts) 392 | (mapped-windows :initform nil :accessor screen-mapped-windows :documentation 393 | "A list of all mapped windows. These are the raw xlib:window's. window structures are stored in groups.") 394 | (withdrawn-windows :initform nil :accessor screen-withdrawn-windows :documentation 395 | "A list of withdrawn windows. These are of type stumpwm::window 396 | and when they're mapped again they'll be put back in the group 397 | they were in when they were unmapped unless that group doesn't 398 | exist, in which case they go into the current group.") 399 | (urgent-windows :initform nil :accessor screen-urgent-windows :documentation 400 | "a list of windows for which (window-urgent-p) currently true.") 401 | (input-window :initform nil :accessor screen-input-window) 402 | 403 | (key-window :initform nil :accessor screen-key-window :documentation 404 | "the window that accepts further keypresses after a toplevel key has been pressed.") 405 | (focus-window :initform nil :accessor screen-focus-window :documentation 406 | "The window that gets focus when no window has focus") 407 | ;; 408 | (frame-window :initform nil :accessor screen-frame-window) 409 | (frame-outline-gc :initform nil :accessor screen-frame-outline-gc) 410 | ;; color contexts 411 | (message-cc :initform nil :accessor screen-message-cc) 412 | (mode-line-cc :initform nil :accessor screen-mode-line-cc) 413 | ;; color maps 414 | (color-map-normal :initform nil :accessor screen-color-map-normal) 415 | (color-map-bright :initform nil :accessor screen-color-map-bright) 416 | (ignore-msg-expose :initform nil :accessor screen-ignore-msg-expose :documentation 417 | "used to ignore the first expose even when mapping the message window.") 418 | ;; the window that has focus 419 | (focus :initform nil :accessor screen-focus) 420 | (current-msg :initform nil :accessor screen-current-msg) 421 | (current-msg-highlights :initform nil :accessor screen-current-msg-highlights) 422 | (last-msg :initform nil :accessor screen-last-msg) 423 | (last-msg-highlights :initform nil :accessor screen-last-msg-highlights))) 424 | 425 | (defstruct ccontext 426 | screen 427 | win 428 | px 429 | gc 430 | default-fg 431 | default-bright 432 | default-bg 433 | fg 434 | bg 435 | brightp 436 | reversep 437 | color-stack 438 | font) 439 | 440 | (defun screen-message-window (screen) 441 | (ccontext-win (screen-message-cc screen))) 442 | 443 | (defun screen-message-pixmap (screen) 444 | (ccontext-px (screen-message-cc screen))) 445 | 446 | (defun screen-message-gc (screen) 447 | (ccontext-gc (screen-message-cc screen))) 448 | 449 | (defun screen-font (screen) 450 | (first (screen-fonts screen))) 451 | 452 | (defmethod print-object ((object frame) stream) 453 | (format stream "#S(frame ~d ~a ~d ~d ~d ~d)" 454 | (frame-number object) (frame-window object) (frame-x object) (frame-y object) (frame-width object) (frame-height object))) 455 | 456 | (defvar *window-number-map* "0123456789" 457 | "Set this to a string to remap the window numbers to something more convenient.") 458 | 459 | (defvar *group-number-map* "1234567890" 460 | "Set this to a string to remap the group numbers to something more convenient.") 461 | 462 | (defvar *frame-number-map* "0123456789abcdefghijklmnopqrstuvxwyz" 463 | "Set this to a string to remap the frame numbers to more convenient keys. 464 | For instance, 465 | 466 | \"hutenosa\" 467 | 468 | would map frame 0 to 7 to be selectable by hitting the appropriate 469 | homerow key on a dvorak keyboard. Currently, only single char keys are 470 | supported. By default, the frame labels are the 36 (lower-case) 471 | alphanumeric characters, starting with numbers 0-9.") 472 | 473 | (defun get-frame-number-translation (frame) 474 | "Given a frame return its number translation using *frame-number-map* as a 475 | char." 476 | (let ((num (frame-number frame))) 477 | (if (< num (length *frame-number-map*)) 478 | (char *frame-number-map* num) 479 | ;; translate the frame number to a char. FIXME: it loops after 9 480 | (char (prin1-to-string num) 0)))) 481 | 482 | (defstruct modifiers 483 | (meta nil) 484 | (alt nil) 485 | (hyper nil) 486 | (super nil) 487 | (altgr nil) 488 | (numlock nil)) 489 | 490 | (defvar *all-modifiers* nil 491 | "A list of all keycodes that are considered modifiers") 492 | 493 | (defvar *modifiers* nil 494 | "A mapping from modifier type to x11 modifier.") 495 | 496 | (defmethod print-object ((object screen) stream) 497 | (format stream "#S" (screen-number object))) 498 | 499 | (defvar *screen-list* '() 500 | "The list of screens managed by stumpwm.") 501 | 502 | (defvar *initializing* nil 503 | "True when starting stumpwm. Use this variable in your rc file to 504 | run code that should only be executed once, when stumpwm starts up and 505 | loads the rc file.") 506 | 507 | (defvar *processing-existing-windows* nil 508 | "True when processing pre-existing windows at startup.") 509 | 510 | (defvar *executing-stumpwm-command* nil 511 | "True when executing external commands.") 512 | 513 | (defvar *interactivep* nil 514 | "True when a defcommand is executed from colon or a keybinding") 515 | 516 | ;; Misc. utility functions 517 | 518 | (defun conc1 (list arg) 519 | "Append arg to the end of list" 520 | (nconc list (list arg))) 521 | 522 | (defun sort1 (list sort-fn &rest keys &key &allow-other-keys) 523 | "Return a sorted copy of list." 524 | (let ((copy (copy-list list))) 525 | (apply 'sort copy sort-fn keys))) 526 | 527 | (defun mapcar-hash (fn hash) 528 | "Just like maphash except it accumulates the result in a list." 529 | (let ((accum nil)) 530 | (labels ((mapfn (key val) 531 | (push (funcall fn key val) accum))) 532 | (maphash #'mapfn hash)) 533 | accum)) 534 | 535 | (defun find-free-number (l &optional (min 0) dir) 536 | "Return a number that is not in the list l. If dir is :negative then 537 | look for a free number in the negative direction. anything else means 538 | positive direction." 539 | (let* ((dirfn (if (eq dir :negative) '> '<)) 540 | ;; sort it and crop numbers below/above min depending on dir 541 | (nums (sort (remove-if (lambda (n) 542 | (funcall dirfn n min)) 543 | l) dirfn)) 544 | (max (car (last nums))) 545 | (inc (if (eq dir :negative) -1 1)) 546 | (new-num (loop for n = min then (+ n inc) 547 | for i in nums 548 | when (/= n i) 549 | do (return n)))) 550 | (dformat 3 "Free number: ~S~%" nums) 551 | (if new-num 552 | new-num 553 | ;; there was no space between the numbers, so use the max+inc 554 | (if max 555 | (+ inc max) 556 | min)))) 557 | 558 | (defun remove-plist (plist &rest keys) 559 | "Remove the keys from the plist. 560 | Useful for re-using the &REST arg after removing some options." 561 | (do (copy rest) 562 | ((null (setq rest (nth-value 2 (get-properties plist keys)))) 563 | (nreconc copy plist)) 564 | (do () ((eq plist rest)) 565 | (push (pop plist) copy) 566 | (push (pop plist) copy)) 567 | (setq plist (cddr plist)))) 568 | 569 | (defun screen-display-string (screen &optional (assign t)) 570 | (format nil 571 | (if assign "DISPLAY=~a:~d.~d" "~a:~d.~d") 572 | (screen-host screen) 573 | (xlib:display-display *display*) 574 | (screen-id screen))) 575 | 576 | (defun split-seq (seq separators &key test default-value) 577 | "split a sequence into sub sequences given the list of seperators." 578 | (let ((seps separators)) 579 | (labels ((sep (c) 580 | (find c seps :test test))) 581 | (or (loop for i = (position-if (complement #'sep) seq) 582 | then (position-if (complement #'sep) seq :start j) 583 | as j = (position-if #'sep seq :start (or i 0)) 584 | while i 585 | collect (subseq seq i j) 586 | while j) 587 | ;; the empty seq causes the above to return NIL, so help 588 | ;; it out a little. 589 | default-value)))) 590 | 591 | (defun split-string (string &optional (separators " 592 | ")) 593 | "Splits STRING into substrings where there are matches for SEPARATORS. 594 | Each match for SEPARATORS is a splitting point. 595 | The substrings between the splitting points are made into a list 596 | which is returned. 597 | ***If SEPARATORS is absent, it defaults to \"[ \f\t\n\r\v]+\". 598 | 599 | If there is match for SEPARATORS at the beginning of STRING, we do not 600 | include a null substring for that. Likewise, if there is a match 601 | at the end of STRING, we don't include a null substring for that. 602 | 603 | Modifies the match data; use `save-match-data' if necessary." 604 | (split-seq string separators :test #'char= :default-value '(""))) 605 | 606 | 607 | (defun insert-before (list item nth) 608 | "Insert ITEM before the NTH element of LIST." 609 | (declare (type (integer 0 *) nth)) 610 | (let* ((nth (min nth (length list))) 611 | (pre (subseq list 0 nth)) 612 | (post (subseq list nth))) 613 | (nconc pre (list item) post))) 614 | 615 | 616 | 617 | 618 | ;;; 619 | ;;; formatting routines 620 | (defun format-expand (fmt-alist fmt &rest args) 621 | (let* ((chars (coerce fmt 'list)) 622 | (output "") 623 | (cur chars)) 624 | ;; FIXME: this is horribly inneficient 625 | (loop 626 | (cond ((null cur) 627 | (return-from format-expand output)) 628 | ;; if % is the last char in the string then it's a literal. 629 | ((and (char= (car cur) #\%) 630 | (cdr cur)) 631 | (setf cur (cdr cur)) 632 | (let* ((tmp (loop while (and cur (char<= #\0 (car cur) #\9)) 633 | collect (pop cur))) 634 | (len (and tmp (parse-integer (coerce tmp 'string)))) 635 | ;; So that eg "%25^t" will trim from the left 636 | (from-left-p (when (char= #\^ (car cur)) (pop cur)))) 637 | (if (null cur) 638 | (format t "%~a~@[~a~]" len from-left-p) 639 | (let* ((fmt (cadr (assoc (car cur) fmt-alist :test 'char=))) 640 | (str (cond (fmt 641 | ;; it can return any type, not jut as string. 642 | (format nil "~a" (apply fmt args))) 643 | ((char= (car cur) #\%) 644 | (string #\%)) 645 | (t 646 | (concatenate 'string (string #\%) (string (car cur))))))) 647 | ;; crop string if needed 648 | (setf output (concatenate 'string output 649 | (cond ((null len) str) 650 | ((not from-left-p) ; Default behavior 651 | (subseq str 0 (min len (length str)))) 652 | ;; New behavior -- trim from the left 653 | (t (subseq str (max 0 (- (length str) len))))))) 654 | (setf cur (cdr cur)))))) 655 | (t 656 | (setf output (concatenate 'string output (string (car cur))) 657 | cur (cdr cur))))))) 658 | 659 | (defvar *window-formatters* '((#\n window-map-number) 660 | (#\s fmt-window-status) 661 | (#\t window-name) 662 | (#\c window-class) 663 | (#\i window-res) 664 | (#\r window-role) 665 | (#\m fmt-window-marked) 666 | (#\h window-height) 667 | (#\w window-width) 668 | (#\g gravity-for-window)) 669 | "an alist containing format character format function pairs for formatting window lists.") 670 | 671 | (defvar *window-format* "%m%n%s%50t" 672 | "This variable decides how the window list is formatted. It is a string 673 | with the following formatting options: 674 | 675 | @table @asis 676 | @item %n 677 | Substitutes the windows number translated via *window-number-map*, if there 678 | are more windows than *window-number-map* then will use the window-number. 679 | @item %s 680 | Substitute the window's status. * means current window, + means last 681 | window, and - means any other window. 682 | @item %t 683 | Substitute the window's name. 684 | @item %c 685 | Substitute the window's class. 686 | @item %i 687 | Substitute the window's resource ID. 688 | @item %m 689 | Draw a # if the window is marked. 690 | @end table 691 | 692 | Note, a prefix number can be used to crop the argument to a specified 693 | size. For instance, @samp{%20t} crops the window's title to 20 694 | characters.") 695 | 696 | (defvar *window-info-format* "%wx%h %n (%t)" 697 | "The format used in the info command. 698 | @var{*window-format*} for formatting details.") 699 | 700 | (defparameter *window-format-by-class* "%m%n %c %s%50t" 701 | "The format used in the info winlist-by-class command. 702 | @var{*window-format*} for formatting details.") 703 | 704 | (defvar *group-formatters* '((#\n group-map-number) 705 | (#\s fmt-group-status) 706 | (#\t group-name)) 707 | "An alist of characters and formatter functions. The character can be 708 | used as a format character in @var{*group-format*}. When the character 709 | is encountered in the string, the corresponding function is called 710 | with a group as an argument. The functions return value is inserted 711 | into the string. If the return value isn't a string it is converted to 712 | one using @code{prin1-to-string}.") 713 | 714 | (defvar *group-format* "%n%s%t" 715 | "The format string that decides what information will show up in the 716 | group listing. The following format options are available: 717 | 718 | @table @asis 719 | @item %n 720 | Substitutes the group number translated via *group-number-map*, if there 721 | are more windows than *group-number-map* then will use the group-number. 722 | 723 | @item %s 724 | The group's status. Similar to a window's status. 725 | 726 | @item %t 727 | The group's name. 728 | @end table") 729 | 730 | (defvar *list-hidden-groups* nil 731 | "Controls whether hidden groups are displayed by 'groups' and 'vgroups' commands") 732 | 733 | ;; (defun font-height (font) 734 | ;; (+ (font-descent font) 735 | ;; (font-ascent font))) 736 | 737 | (defvar *x-selection* nil 738 | "This is a plist of stumpwm's current selections. The different properties are 739 | generally set when killing text in the input bar.") 740 | 741 | (defvar *last-command* nil 742 | "Set to the last interactive command run.") 743 | 744 | (defvar *max-last-message-size* 20 745 | "how many previous messages to keep.") 746 | 747 | (defvar *record-last-msg-override* nil 748 | "assign this to T and messages won't be recorded. It is 749 | recommended this is assigned using LET.") 750 | 751 | (defvar *suppress-echo-timeout* nil 752 | "Assign this T and messages will not time out. It is recommended this is assigned using LET.") 753 | 754 | (defvar *ignore-echo-timeout* nil 755 | "Assign this T and the message time out won't be touched. It is recommended this is assigned using LET.") 756 | 757 | (defvar *run-or-raise-all-groups* t 758 | "When this is @code{T} the @code{run-or-raise} function searches all groups for a 759 | running instance. Set it to NIL to search only the current group.") 760 | 761 | (defvar *run-or-raise-all-screens* nil 762 | "When this is @code{T} the @code{run-or-raise} function searches all screens for a 763 | running instance. Set it to @code{NIL} to search only the current screen. If 764 | @var{*run-or-raise-all-groups*} is @code{NIL} this variable has no effect.") 765 | 766 | (defvar *deny-map-request* nil 767 | "A list of window properties that stumpwm should deny matching windows' 768 | requests to become mapped for the first time.") 769 | 770 | (defvar *deny-raise-request* nil 771 | "Exactly the same as @var{*deny-map-request*} but for raise requests. 772 | 773 | Note that no denial message is displayed if the window is already visible.") 774 | 775 | (defvar *suppress-deny-messages* nil 776 | "For complete focus on the task at hand, set this to @code{T} and no 777 | raise/map denial messages will be seen.") 778 | 779 | (defvar *honor-window-moves* t 780 | "Allow windows to move between frames.") 781 | 782 | (defvar *resize-hides-windows* nil 783 | "Set to T to hide windows during interactive resize") 784 | 785 | (defun deny-request-p (window deny-list) 786 | (or (eq deny-list t) 787 | (and 788 | (listp deny-list) 789 | (find-if (lambda (props) 790 | (apply 'window-matches-properties-p window props)) 791 | deny-list) 792 | t))) 793 | 794 | (defun flatten (list) 795 | "Flatten LIST" 796 | (labels ( (mklist (x) (if (listp x) x (list x))) ) 797 | (mapcan #'(lambda (x) (if (atom x) (mklist x) (flatten x))) list))) 798 | 799 | (defun list-splice-replace (item list &rest replacements) 800 | "splice REPLACEMENTS into LIST where ITEM is, removing 801 | ITEM. Return the new list." 802 | (let ((p (position item list))) 803 | (if p 804 | (nconc (subseq list 0 p) replacements (subseq list (1+ p))) 805 | list))) 806 | 807 | (defvar *min-frame-width* 50 808 | "The minimum width a frame can be. A frame will not shrink below this 809 | width. Splitting will not affect frames if the new frame widths are 810 | less than this value.") 811 | 812 | (defvar *min-frame-height* 50 813 | "The minimum height a frame can be. A frame will not shrink below this 814 | height. Splitting will not affect frames if the new frame heights are 815 | less than this value.") 816 | 817 | (defvar *new-frame-action* :last-window 818 | "When a new frame is created, this variable controls what is put in the 819 | new frame. Valid values are 820 | 821 | @table @code 822 | @item :empty 823 | The frame is left empty 824 | 825 | @item :last-window 826 | The last focused window that is not currently visible is placed in the 827 | frame. This is the default. 828 | @end table") 829 | 830 | (defvar *new-window-preferred-frame* '(:focused) 831 | "This variable controls what frame a new window appears in. It is a 832 | list of preferences. The first preference that is satisfied is 833 | used. Valid list elements are as follows: 834 | 835 | @table @code 836 | @item :focused 837 | Choose the focused frame. 838 | 839 | @item :last 840 | Choose the last focused frame. 841 | 842 | @item :empty 843 | Choose any empty frame. 844 | 845 | @item :unfocused 846 | Choose any unfocused frame. 847 | @end table 848 | 849 | Alternatively, it can be set to a function that takes one argument, the new 850 | window, and returns the preferred frame or a list of the above preferences.") 851 | 852 | (defun backtrace-string () 853 | "Similar to print-backtrace, but return the backtrace as a string." 854 | (with-output-to-string (*standard-output*) 855 | (print-backtrace))) 856 | 857 | (defvar *startup-message* "^2*Welcome to The ^BStump^b ^BW^bindow ^BM^banager! 858 | Press ^5*~a ?^2* for help." 859 | "This is the message StumpWM displays when it starts. Set it to NIL to 860 | suppress.") 861 | 862 | (defvar *default-package* (find-package '#:stumpwm-user) 863 | "This is the package eval reads and executes in. You might want to set 864 | this to @code{:stumpwm} if you find yourself using a lot of internal 865 | stumpwm symbols. Setting this variable anywhere but in your rc file 866 | will have no effect.") 867 | 868 | (defun concat (&rest strings) 869 | (apply 'concatenate 'string strings)) 870 | 871 | (defvar *window-placement-rules* '() 872 | "List of rules governing window placement. Use define-frame-preference to 873 | add rules") 874 | 875 | (defmacro define-frame-preference (target-group &rest frame-rules) 876 | "Create a rule that matches windows and automatically places them in 877 | a specified group and frame. Each frame rule is a lambda list: 878 | @example 879 | \(frame-number raise lock &key create restore dump-name class instance type role title) 880 | @end example 881 | 882 | @table @var 883 | @item frame-number 884 | The frame number to send matching windows to 885 | 886 | @item raise 887 | When non-nil, raise and focus the window in its frame 888 | 889 | @item lock 890 | When this is nil, this rule will only match when the current group 891 | matches @var{target-group}. When non-nil, this rule matches regardless 892 | of the group and the window is sent to @var{target-group}. If 893 | @var{lock} and @var{raise} are both non-nil, then stumpwm will jump to 894 | the specified group and focus the matched window. 895 | 896 | @item create 897 | When non-NIL the group is created and eventually restored when the value of 898 | create is a group dump filename in *DATA-DIR*. Defaults to NIL. 899 | 900 | @item restore 901 | When non-NIL the group is restored even if it already exists. This arg should 902 | be set to the dump filename to use for forced restore. Defaults to NIL 903 | 904 | @item class 905 | The window's class must match @var{class}. 906 | 907 | @item instance 908 | The window's instance/resource name must match @var{instance}. 909 | 910 | @item type 911 | The window's type must match @var{type}. 912 | 913 | @item role 914 | The window's role must match @var{role}. 915 | 916 | @item title 917 | The window's title must match @var{title}. 918 | @end table" 919 | (let ((x (gensym "X"))) 920 | `(dolist (,x ',frame-rules) 921 | ;; verify the correct structure 922 | (destructuring-bind (frame-number raise lock 923 | &rest keys 924 | &key create restore class instance type role title) ,x 925 | (declare (ignore create restore class instance type role title)) 926 | (push (list* ,target-group frame-number raise lock keys) 927 | *window-placement-rules*))))) 928 | 929 | (defun clear-window-placement-rules () 930 | "Clear all window placement rules." 931 | (setf *window-placement-rules* nil)) 932 | 933 | (defvar *mouse-focus-policy* :ignore 934 | "The mouse focus policy decides how the mouse affects input 935 | focus. Possible values are :ignore, :sloppy, and :click. :ignore means 936 | stumpwm ignores the mouse. :sloppy means input focus follows the 937 | mouse; the window that the mouse is in gets the focus. :click means 938 | input focus is transfered to the window you click on.") 939 | 940 | (defvar *root-click-focuses-frame* t 941 | "Set to NIL if you don't want clicking the root window to focus the frame 942 | containing the pointer.") 943 | 944 | (defvar *banish-pointer-to* :head 945 | "Where to put the pointer when no argument is given to (banish-pointer) or the banish 946 | command. May be one of :screen :head :frame or :window") 947 | 948 | (defvar *xwin-to-window* (make-hash-table) 949 | "Hash table for looking up windows quickly.") 950 | 951 | (defvar *resize-map* nil 952 | "The keymap used for resizing a window") 953 | 954 | (defvar *default-group-name* "Default" 955 | "The name of the default group.") 956 | 957 | (defmacro with-focus (xwin &body body) 958 | "Set the focus to xwin, do body, then restore focus" 959 | `(progn 960 | (grab-keyboard ,xwin) 961 | (unwind-protect 962 | (progn ,@body) 963 | (ungrab-keyboard)))) 964 | 965 | 966 | (defvar *show-command-backtrace* nil 967 | "When this is T a backtrace is displayed with errors that occurred 968 | within an interactive call to a command.") 969 | 970 | (defvar *window-border-style* :thick 971 | "This controls the appearance of the border around windows. valid 972 | values are: 973 | @table @var 974 | @item :thick 975 | All space within the frame not used by the window is dedicated to the 976 | border. 977 | 978 | @item :thin 979 | Only the border width as controlled by *maxsize-border-width* 980 | *normal-border-width* and *transient-border-width* is used as the 981 | border. The rest is filled with the unfocus color. 982 | 983 | @item :tight 984 | The same as :thin but the border surrounds the window and the wasted 985 | space within the frame is not obscured, revealing the background. 986 | 987 | @item :none 988 | Like :tight but no border is ever visible. 989 | @end table 990 | 991 | After changing this variable you may need to call 992 | sync-all-frame-windows to see the change.") 993 | 994 | 995 | (defmacro move-to-head (list elt) 996 | "Move the specified element in in LIST to the head of the list." 997 | `(progn 998 | (setf ,list (remove ,elt ,list)) 999 | (push ,elt ,list))) 1000 | 1001 | (define-condition stumpwm-condition (condition) 1002 | ((message :initarg :message :reader warning-message)) 1003 | (:documentation "Any stumpmwm specific condition should inherit from this.") 1004 | (:report (lambda (condition stream) 1005 | (format stream "~A~%" (warning-message condition))))) 1006 | 1007 | (define-condition stumpwm-error (stumpwm-condition error) 1008 | () 1009 | (:documentation "Any stumpwm specific error should inherit this.")) 1010 | 1011 | (define-condition stumpwm-warning (warning stumpwm-condition) 1012 | () 1013 | (:documentation "Adds a message slot to warning. Any stumpwm specific warning 1014 | should inherit from this.")) 1015 | 1016 | 1017 | (defun command-mode-start-message () 1018 | (message "Press C-g to exit command-mode.")) 1019 | 1020 | (defun command-mode-end-message () 1021 | (message "Exited command-mode.")) 1022 | -------------------------------------------------------------------------------- /base/timers.lisp: -------------------------------------------------------------------------------- 1 | (in-package :paulownia) 2 | 3 | (export '(run-with-timer 4 | cancel-timer 5 | timer-p)) 6 | 7 | (defvar *timer-list* nil 8 | "List of active timers.") 9 | 10 | (defstruct timer 11 | time repeat function args) 12 | 13 | (defun run-with-timer (secs repeat function &rest args) 14 | "Perform an action after a delay of SECS seconds. 15 | Repeat the action every REPEAT seconds, if repeat is non-nil. 16 | SECS and REPEAT may be reals. 17 | The action is to call FUNCTION with arguments ARGS." 18 | (check-type secs (real 0 *)) 19 | (check-type repeat (or null (real 0 *))) 20 | (check-type function (or function symbol)) 21 | (let ((timer (make-timer 22 | :repeat repeat 23 | :function function 24 | :args args))) 25 | (schedule-timer timer secs) 26 | (setf *timer-list* (merge 'list *timer-list* (list timer) #'< :key #'timer-time)) 27 | timer)) 28 | 29 | (defun cancel-timer (timer) 30 | "Remove TIMER from the list of active timers." 31 | (check-type timer timer) 32 | (setf *timer-list* (remove timer *timer-list*))) 33 | 34 | (defun schedule-timer (timer when) 35 | (setf (timer-time timer) (+ (get-internal-real-time) 36 | (* when internal-time-units-per-second)))) 37 | 38 | (defun run-expired-timers () 39 | (let ((now (get-internal-real-time)) 40 | (timers *timer-list*) 41 | (pending '()) 42 | (remaining '())) 43 | (setf *timer-list* 44 | (dolist (timer timers (sort remaining #'< :key #'timer-time)) 45 | (if (<= (timer-time timer) now) 46 | (progn (push timer pending) 47 | (when (timer-repeat timer) 48 | (schedule-timer timer (timer-repeat timer)) 49 | (push timer remaining))) 50 | (push timer remaining)))) 51 | (dolist (timer pending) 52 | (apply (timer-function timer) (timer-args timer))))) 53 | 54 | (defun get-next-timeout (timers) 55 | "Return the number of seconds until the next timeout or nil if there are no timers." 56 | (when timers 57 | (max (/ (- (timer-time (car timers)) (get-internal-real-time)) 58 | internal-time-units-per-second) 59 | 0))) 60 | -------------------------------------------------------------------------------- /configure.ac: -------------------------------------------------------------------------------- 1 | # -*- Autoconf -*- 2 | # Process this file with autoconf to produce a configure script. 3 | 4 | AC_PREREQ(2.59) 5 | AC_INIT(Stump Window Manager, esyscmd(grep :version paulownia.asd | cut -d\" -f2 | tr -d \\n), dbjergaard@gmail.com, sabetts@gmail.com) 6 | 7 | AC_SUBST(MODULE_DIR) 8 | AC_SUBST(LISP) 9 | AC_SUBST(PAULOWNIA_ASDF_DIR) 10 | 11 | # Checks for programs. 12 | AC_ARG_WITH(lisp, [ --with-lisp=IMPL use the specified lisp (sbcl or ccl)], LISP=$withval, LISP="any") 13 | AC_ARG_WITH(ros, [ --with-ros=PATH specify location of roswell, ROS_PATH=$withval, ROS_PATH=""]) 14 | 15 | AC_ARG_WITH(module-dir, 16 | [ --with-module-dir=PATH specify location of contrib modules], 17 | MODULE_DIR=$withval, MODULE_DIR="${HOME}/.paulownia.d/modules") 18 | 19 | PAULOWNIA_ASDF_DIR="`pwd`" 20 | 21 | if test -x "$ROS_PATH"; then 22 | ROS=$ROS_PATH 23 | AC_MSG_CHECKING([for ros]) 24 | AC_MSG_RESULT($ROS) 25 | else 26 | AC_PATH_PROG([ROS], ros,"") 27 | fi 28 | HAS_SBCL="$(ros list installed | awk '{print $1}' | grep sbcl)" 29 | HAS_CCL="$(ros list installed | awk '{print $1}' | grep ccl)" 30 | 31 | if test "x$LISP" = "xany"; then 32 | if test "x$HAS_SBCL"="xsbcl-bin"; then 33 | LISP=sbcl-bin 34 | elif test "x$HAS_CCL"="xccl-bin"; then 35 | LISP=ccl 36 | fi 37 | fi 38 | 39 | if test "x$LISP" = "xany"; then 40 | AC_MSG_ERROR([*** No lisp is available. Install one with "$ROS install foo"]) 41 | fi 42 | 43 | AC_MSG_NOTICE([Using $LISP with ros: ros use $LISP]) 44 | 45 | # check for makeinfo 46 | 47 | AC_CHECK_PROG(MAKEINFO,makeinfo,yes,no) 48 | 49 | if test "$MAKEINFO" = "no"; then 50 | AC_MSG_WARN([Please install makeinfo for the manual.]) 51 | fi 52 | # Checks for libraries. 53 | 54 | # Checks for header files. 55 | 56 | # Checks for typedefs, structures, and compiler characteristics. 57 | 58 | # Checks for library functions. 59 | AC_OUTPUT(Makefile) 60 | AC_OUTPUT(paulownia.ros) 61 | AC_OUTPUT(paulownia-tests.asd) 62 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | ;; package.lisp -- 2 | ;; Copyright (C) 2003-2008 Shawn Betts 3 | ;; 2015 David Bjergaard 4 | ;; 5 | ;; This file is part of paulownia. 6 | ;; 7 | ;; paulownia is free software; you can redistribute it and/or modify 8 | ;; it under the terms of the GNU General Public License as published by 9 | ;; the Free Software Foundation; either version 2, or (at your option) 10 | ;; any later version. 11 | 12 | ;; paulownia is distributed in the hope that it will be useful, 13 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | ;; GNU General Public License for more details. 16 | 17 | ;; You should have received a copy of the GNU General Public License 18 | ;; along with this software; see the file COPYING. If not, see 19 | ;; . 20 | 21 | (defpackage :paulownia 22 | (:use :cl) 23 | (:shadow #:yes-or-no-p #:y-or-n-p)) 24 | 25 | -------------------------------------------------------------------------------- /paulownia-tests.asd.in: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage paulownia-test-asd 3 | (:use :cl :asdf)) 4 | (in-package :paulownia-test-asd) 5 | 6 | (asdf:initialize-source-registry 7 | '(:source-registry 8 | (:directory "@PAULOWNIA_ASDF_DIR@") 9 | :inherit-configuration)) 10 | 11 | (defsystem paulownia-tests 12 | :depends-on (:paulownia 13 | :prove) 14 | :components ((:module "tests/" 15 | :components ((:test-file "paulownia") 16 | (:test-file "base/hooks") 17 | (:test-file "base/timers")))) 18 | 19 | :defsystem-depends-on (:prove-asdf) 20 | :perform (test-op :after (op c) 21 | (funcall (intern #.(string :run-test-system) :prove.asdf) c) 22 | (asdf:clear-system c))) 23 | -------------------------------------------------------------------------------- /paulownia.asd: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Lisp -*- 2 | 3 | (defpackage :paulownia-system 4 | (:use :cl :asdf :uiop)) 5 | (in-package :paulownia-system) 6 | 7 | (defsystem :paulownia 8 | :name "Paulownia" 9 | :author "David Bjergaard , Shawn Betts " 10 | :version "2.0.0" 11 | :maintainer "David Bjergaard " 12 | :license "GNU General Public License" 13 | :description "A tiling, keyboard driven window manager" 14 | :serial t 15 | :depends-on (:cl-ppcre 16 | #+sbcl :sb-posix 17 | :uiop 18 | :clx) 19 | :components ((:file "package") 20 | (:file "base/helpers") 21 | (:file "base/debug") 22 | (:file "base/load-rc") 23 | (:file "base/timers") 24 | (:file "base/hooks") 25 | (:file "base/data-dir") 26 | (:file "backends/display-server") 27 | (:file "backends/gui") 28 | ;; keep this last so it always gets recompiled if 29 | ;; anything changes 30 | (:file "version") 31 | )) 32 | -------------------------------------------------------------------------------- /paulownia.ros.in: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | #|-*- mode:lisp -*-|# 3 | #| 4 | exec ros -Q -- $0 "$@" 5 | |# 6 | (asdf:initialize-source-registry 7 | '(:source-registry 8 | (:directory "@PAULOWNIA_ASDF_DIR@") 9 | :inherit-configuration)) 10 | (setf asdf:*central-registry* 11 | (append (list (merge-pathnames "@PAULOWNIA_ASDF_DIR@/base/")) 12 | asdf:*central-registry*)) 13 | (ql:quickload :paulownia) 14 | 15 | (in-package :paulownia) 16 | (export '(*display*)) 17 | 18 | (defvar *display* nil 19 | "The display for the X server") 20 | 21 | (defparameter *mods* '(:mod-1)) 22 | (defparameter *move* 1) 23 | (defparameter *resize* 3) 24 | (defparameter *lower* 4) 25 | (defparameter *raise* 5) 26 | (defparameter *display* nil) ; set this to an integer to do testing with xnest 27 | 28 | (defun paulownia () 29 | (let* ((screen (first (xlib:display-roots *display*))) 30 | (root (xlib:screen-root screen))) 31 | (dolist (button (list *move* *resize* *lower* *raise*)) 32 | (xlib:grab-button root button '(:button-press) :modifiers *mods*)) 33 | 34 | (unwind-protect 35 | (let (last-button last-x last-y) 36 | (do () (nil) ; infinite loop 37 | (xlib:event-case (*display* :discard-p t) 38 | (:button-press (code child) 39 | (cond ((= code *raise*) 40 | (xlib:circulate-window-up root)) 41 | ((= code *lower*) 42 | (xlib:circulate-window-down root)) 43 | ((or (= code *move*) 44 | (= code *resize*)) 45 | (when child ; do nothing if we're not over a window 46 | (setf last-button code) 47 | (xlib:grab-pointer child '(:pointer-motion :button-release)) 48 | (let ((lst (multiple-value-list (xlib:query-pointer root)))) 49 | (setf last-x (sixth lst) 50 | last-y (seventh lst))))))) 51 | (:motion-notify 52 | (event-window root-x root-y) 53 | (cond ((= last-button *move*) 54 | (setf (xlib:drawable-x event-window) root-x 55 | (xlib:drawable-y event-window) root-y)) 56 | ((= last-button *resize*) 57 | (setf (xlib:drawable-width event-window) 58 | (max 1 (- root-x (xlib:drawable-x event-window))) 59 | (xlib:drawable-height event-window) 60 | (max 1 (- root-y (xlib:drawable-y event-window))))))) 61 | (:button-release () 62 | (xlib:ungrab-pointer *display*))))) 63 | (xlib:close-display *display*)) 64 | ) 65 | ) 66 | 67 | (defun main (&rest argv) 68 | (declare (ignorable argv)) 69 | "Start the window manager, this is the \"main\" of the program" 70 | ;; Setup variables that need a global state for pauwlonia to run 71 | ;; Setup the data directory for logging/modules 72 | (setf *data-dir* 73 | (make-pathname :directory (append (pathname-directory (user-homedir-pathname)) 74 | (list ".paulownia.d")))) 75 | ;; Setup the load-path for modules 76 | ;; (init-load-path (merge-pathnames *data-dir* "modules/")) 77 | 78 | ;; Start the top level loop. We have to follow the standard unix 79 | ;; interfaces and respond to events when we're suspended 80 | ;; (hup-process) 81 | (let ((display-str (car argv))) 82 | (when (null display-str) 83 | (setf display-str (uiop:getenv "DISPLAY"))) 84 | (format t "Opening display: ~a ~%" display-str) 85 | (loop 86 | (let ((ret (catch :top-level 87 | (multiple-value-bind (host display screen protocol) (parse-display-string display-str) 88 | 89 | (declare (ignore screen)) 90 | (setf *display* (xlib:open-display host :display display :protocol protocol) 91 | (xlib:display-error-handler *display*) 'error-handler) 92 | (paulownia))))) 93 | (setf *last-unhandled-error* nil) 94 | (cond ((and (consp ret) 95 | (typep (first ret) 'condition)) 96 | (format t "~&Caught '~a' at the top level. Please report this.~%~a" 97 | (first ret) (second ret)) 98 | (setf *last-unhandled-error* ret)) 99 | ;; we need to jump out of the event loop in order to hup 100 | ;; the process because otherwise we get errors. 101 | ((eq ret :hup-process) 102 | (apply 'execv (first (list argv)) (list argv))) 103 | ((eq ret :restart)) 104 | (t 105 | (run-hook *quit-hook*) 106 | ;; the number is the unix return code 107 | (return-from main 0)))))) 108 | ) 109 | -------------------------------------------------------------------------------- /project-log.org: -------------------------------------------------------------------------------- 1 | #+TITLE: Jet Charge in W+Jets 2 | #+OPTIONS: H:5 num:nil toc:nil \n:nil @:t ::t |:t ^:t f:t TeX:t 3 | * Entries 4 | ** <2015-10-04 Sun> Introduction 5 | I'm re-writing StumpWM. Since I have infrastructure in place to parse 6 | org files and produce posts from a file like this I thought I would 7 | keep a log of what I've been doing and maybe expand them into 8 | pedagogical posts about how to build a more complex lisp project in 9 | the 2010's (as opposed to the 90's or earlier). 10 | 11 | StumpWM built a lot of infrastructure that has been re-implemented 12 | outside of StumpWM's ecosystem. In a re-write such as the one I'm 13 | doing this leaves two options: 14 | 1. Keep the existing infrastructure and spin it out into their own 15 | projects for the benefit of others 16 | 2. Replace parts of the infrastructure with external options 17 | 18 | One of StumpWM's original selling points was its lack of 19 | dependencies. This is a blessing and a curse, and in order to make 20 | StumpWM more lean and focused on managing windows, I've decided to 21 | introduce dependencies. 22 | 23 | I struggled with this decision for a long time, but ultimately decided 24 | that it was appropriate since with the advent of quicklisp 25 | dependencies are easy to obtain, and those who are building from 26 | source should know what their doing. If a user is installing from a 27 | package manager, then the dependencies are already managed by other 28 | software. This wasn't the case when StumpWM originally came on the 29 | scene, and then installing and loading dependencies for lisp systems 30 | required much more expertise. 31 | 32 | Going forward, option 2 when possible, and option 1 when no better 33 | alternative exists. 34 | 35 | As for the rest of the goals, they can be found in the project 36 | README.org. 37 | ** <2015-10-04 Sun> Roswell 38 | Roswell is a neat little lisp implementation manager that provides 39 | (among other things) a uniform interface for interacting with 40 | different lisp implementations as well as the ability to dump images 41 | of lisp-scripts. This replaces StumpWM's =make-image.lisp= and 42 | =load-image.lisp= (and all their implementation specific hacks). 43 | 44 | Getting roswell is as easy as (note the release branch to ensure we 45 | get a stable version): 46 | #+BEGIN_SRC sh 47 | git clone -b release https://github.com/snmsts/roswell.git 48 | #+END_SRC 49 | then we can use the industry standard "=./configure; make; make 50 | install=" process: 51 | #+BEGIN_SRC sh 52 | sh bootstrap 53 | ./configure --prefix=${HOME}/local 54 | make 55 | make install 56 | #+END_SRC 57 | I prefer =${HOME}/local= to =${HOME}/.local= because other programs 58 | use =.local= and I can keep track of what I've added vs what other 59 | programs have added themselves. This is purely a matter of taste. Of 60 | course it also assumes that =${HOME}/local= is in your path. 61 | 62 | Interestingly roswell is a mixture of C and Common Lisp. It handles 63 | downloading and installing lisp implementations and it comes with 64 | recipes for the various Continuous Integration cloud suites that have 65 | been popping up (travis-ci, circlci, etc). So with roswell installed, 66 | installing =sbcl= and =ccl= is matter of: 67 | #+BEGIN_SRC sh 68 | ros install sbcl-bin 69 | ros install ccl-bin 70 | #+END_SRC 71 | 72 | There are examples of how to get going from here on the wiki and in 73 | the project's [[https://github.com/snmsts/roswell][readme]]. 74 | 75 | The command =ros init paulownia= will produce file that defines a main 76 | for our program. Here's a first practical problem that needs to be 77 | solved, namely how do we load the rest of our system into the main 78 | file? If this was a simple script we could just 79 | =(ql:quickload :paulownia)= but this would require that we tell 80 | quicklisp where to find our source tree. Since quicklisp 81 | intelligently wraps a call to asdf, we can dispense with quicklisp 82 | entirely and write: 83 | #+BEGIN_SRC lisp 84 | (setf asdf:*central-registry* (list* #P"/home/dave/paulownia/" 85 | asdf:*central-registry*)) 86 | (asdf:operate 'asdf:load-op 'paulownia) 87 | #+END_SRC 88 | This works great except that the path is hard-coded. That's where the 89 | =autoconf= comes in, it processes =.ac= =.in= files and produces a 90 | system that can be built using the make tools. 91 | 92 | So far my =paulownia.ros.in= file contains: 93 | #+BEGIN_SRC lisp 94 | #!/bin/sh 95 | #|-*- mode:lisp -*-|# 96 | #| 97 | exec ros -Q -- $0 "$@" 98 | |# 99 | (asdf:initialize-source-registry 100 | '(:source-registry 101 | (:directory "@PAULOWNIA_ASDF_DIR@") 102 | :inherit-configuration)) 103 | 104 | (asdf:oos 'asdf:load-op 'paulownia) 105 | 106 | (defun main (&rest argv) 107 | (declare (ignorable argv)) 108 | (paulownia:paulownia argv)) 109 | #+END_SRC 110 | 111 | Now, with the appropriate =Makefile= recipe: 112 | #+BEGIN_EXAMPLE 113 | paulownia: $(FILES) paulownia.ros 114 | ros use $(LISP) 115 | ros build paulownia.ros 116 | #+END_EXAMPLE 117 | We're in business. 118 | ** <2015-10-04 Sun> Adding a testing framework 119 | I've settled on [[https://github.com/fukamachi/prove][prove]] as the testing framework for StumpWM. Getting it 120 | going was harder than anticipated. Prove provides a ros script 121 | =run-prove= that processes a list of asd files and runs the testing 122 | packages defined in them. I kept getting a stack trace saying: 123 | #+BEGIN_EXAMPLE 124 | Unhandled ASDF/FIND-SYSTEM:MISSING-COMPONENT in thread #: 127 | Component "paulownia-tests" not found 128 | 129 | #+END_EXAMPLE 130 | I could not figure this out until I desperately renamed my system from 131 | =paulownia-test= to =paulownia-tests=. Then I remembered that =asd= 132 | files must define a system with the same name as the file. Anyway, 133 | this worked, but I still needed to tell =asdf= where to find 134 | paulownia, so I ended up making a =paulownia-tests.asd.in= and added 135 | the correct call in the configure.ac file. Now I can go from an empty 136 | repo to testing and I'm ready to get the travis build going. 137 | 138 | ** <2015-10-04 Sun> Integrating with travis-ci 139 | Now that I've got the configure script working, the unit testing 140 | framework going, and the roswell build in place, its time to 141 | incorporate travis-ci to put the build verification and all the 142 | wonderful little badges in the readme. 143 | ** <2016-03-07 Mon> Adding dependencies with roswell 144 | Since roswell containerizes the environment, you need to do: 145 | #+BEGIN_EXAMPLE 146 | ros run 147 | (ql:quickload :clx) 148 | #+END_EXAMPLE 149 | In order to get the =clx= depedency installed to the current lisp 150 | version used by roswell. I'll update the build scripts to do this 151 | automagically. 152 | -------------------------------------------------------------------------------- /tests/base/hooks.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage hooks-test 3 | (:use :cl 4 | :paulownia 5 | :prove)) 6 | (in-package :hooks-test) 7 | (plan nil) 8 | (defvar *test-hook* '() 9 | "A test hook") 10 | (defun test-fn () 11 | (format nil "Hi!")) 12 | (is (add-hook *test-hook* 'test-fn) (list 'test-fn)) 13 | (is (remove-hook *test-hook* 'test-fn) nil) 14 | (add-hook *test-hook* 'test-fn) 15 | 16 | ;; This doesn't really capture all the states that the run-hook code 17 | ;; can be in. Hopefully the other tests will exercise the parts of the 18 | ;; code this doesn't 19 | (is (run-hook *test-hook*) nil) 20 | 21 | 22 | (finalize) 23 | -------------------------------------------------------------------------------- /tests/base/timers.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage timers-test 3 | (:use :cl 4 | :paulownia 5 | :prove)) 6 | (in-package :timers-test) 7 | (plan nil) 8 | 9 | (is (paulownia::get-next-timeout paulownia::*timer-list*) nil) 10 | 11 | (defvar *test-timer* (run-with-timer 10 nil (lambda () 12 | (format t "Hello ~%")) 13 | nil)) 14 | (isnt (paulownia::schedule-timer *test-timer* 10) nil) 15 | (isnt (paulownia::get-next-timeout paulownia::*timer-list*) nil) 16 | (is (cancel-timer *test-timer*) nil) 17 | 18 | (finalize) 19 | -------------------------------------------------------------------------------- /tests/paulownia.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage paulownia-test 3 | (:use :cl 4 | :paulownia 5 | :prove)) 6 | (in-package :paulownia-test) 7 | (plan nil) 8 | ;; Check if rc file exists, and if so don't touch it 9 | (let ((rc-file (merge-pathnames #p".paulowniarc" 10 | (user-homedir-pathname)))) 11 | (if (probe-file rc-file) 12 | ;; one of the user's rc file(s) exists so we expect to be able to 13 | ;; load it without errors, and that the file we got back isn't nil 14 | (multiple-value-bind (success error file) (load-rc-file) 15 | (ok success) 16 | (ok (not error)) 17 | (ok file)) 18 | (progn 19 | ;; First test when the rc file doesn't exist 20 | (multiple-value-bind (success error file) (load-rc-file t) 21 | (ok success) 22 | (ok (not error)) 23 | (is file nil)) 24 | ;; now make one and say that we'll deal with the errors 25 | (with-open-file (stream rc-file 26 | :direction :output 27 | :if-exists :supersede 28 | :if-does-not-exist :create) 29 | (format stream "foo ~%")) 30 | (multiple-value-bind (success error file) (load-rc-file t) 31 | (ok (not success)) 32 | (isnt error nil) 33 | (is file rc-file)) 34 | ;; now delete it and make another one that is a valid lisp 35 | ;; program 36 | (uiop:delete-file-if-exists rc-file) 37 | (with-open-file (stream rc-file 38 | :direction :output 39 | :if-exists :supersede 40 | :if-does-not-exist :create) 41 | (format stream "(eq 'foo 'foo) ~%")) 42 | (multiple-value-bind (success error file) (load-rc-file t) 43 | (ok success) 44 | (is error nil) 45 | (is file rc-file)) 46 | ;; file didn't exist so remove it 47 | (uiop:delete-file-if-exists rc-file)))) 48 | 49 | (finalize) 50 | -------------------------------------------------------------------------------- /version.lisp: -------------------------------------------------------------------------------- 1 | ;; Copyright (C) 2006-2008 Martin Bishop, Ivy Foster 2 | ;; 3 | ;; This file is part of paulownia. 4 | ;; 5 | ;; paulownia is free software; you can redistribute it and/or modify 6 | ;; it under the terms of the GNU General Public License as published by 7 | ;; the Free Software Foundation; either version 2, or (at your option) 8 | ;; any later version. 9 | 10 | ;; paulownia is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ;; GNU General Public License for more details. 14 | 15 | ;; You should have received a copy of the GNU General Public License 16 | ;; along with this software; see the file COPYING. If not, see 17 | ;; . 18 | 19 | ;; Commentary: 20 | ;; 21 | ;; This file contains version information. 22 | ;; 23 | ;; Code: 24 | 25 | (in-package :paulownia) 26 | 27 | ;; (export '(*version* version)) 28 | 29 | ;; (defparameter *version* 30 | ;; #.(concatenate 31 | ;; 'string 32 | ;; (let* ((sys (asdf:find-system :paulownia)) 33 | ;; (git-dir (probe-path (asdf:system-relative-pathname sys ".git")))) 34 | ;; (if git-dir 35 | ;; (string-trim '(#\Newline) 36 | ;; (run-shell-command 37 | ;; (format nil "GIT_DIR=~a git describe --tags" git-dir) t)) 38 | ;; (asdf:component-version sys))) 39 | ;; " Compiled On " 40 | ;; (format-expand *time-format-string-alist* 41 | ;; *time-format-string-default*))) 42 | 43 | ;; (defcommand version () () 44 | ;; "Print version information and compilation date." 45 | ;; (message *version*)) 46 | 47 | ;; End of file 48 | --------------------------------------------------------------------------------