├── .gitignore ├── COPYING ├── NEWS.md ├── README.md ├── TODO.org ├── lein-swank ├── README.md ├── project.clj ├── resources │ └── swank_elisp_payloads.clj └── src │ ├── leiningen │ ├── jack_in.clj │ ├── swank.clj │ └── swank_wrap.clj │ └── swank │ └── payload │ ├── slime-compile-presave.el │ ├── slime-eldoc.el │ ├── slime-frame-colors.el │ ├── slime-repl.el │ └── slime.el ├── project.clj ├── resources └── swank_elisp_payloads.clj ├── src └── swank │ ├── cdt.clj │ ├── clj_contrib │ ├── macroexpand.clj │ └── pprint.clj │ ├── commands.clj │ ├── commands │ ├── basic.clj │ ├── cljs.clj │ ├── completion.clj │ ├── contrib.clj │ ├── contrib │ │ ├── swank_arglists.clj │ │ ├── swank_c_p_c.clj │ │ ├── swank_c_p_c │ │ │ └── internal.clj │ │ └── swank_fuzzy.clj │ ├── indent.clj │ ├── inspector.clj │ └── xref.clj │ ├── core.clj │ ├── core │ ├── cdt_backends.clj │ ├── cdt_utils.clj │ ├── connection.clj │ ├── debugger_backends.clj │ ├── hooks.clj │ ├── protocol.clj │ ├── server.clj │ └── threadmap.clj │ ├── dev.clj │ ├── loader.clj │ ├── payload │ ├── slime-compile-presave.el │ ├── slime-eldoc.el │ ├── slime-frame-colors.el │ ├── slime-repl.el │ └── slime.el │ ├── rpc.clj │ ├── swank.clj │ ├── util.clj │ └── util │ ├── class_browse.clj │ ├── clj_stacktrace_compat.clj │ ├── clojure.clj │ ├── concurrent │ ├── mbox.clj │ └── thread.clj │ ├── hooks.clj │ ├── io.clj │ ├── java.clj │ ├── net │ └── sockets.clj │ ├── string.clj │ └── sys.clj └── test ├── data └── test.jar └── swank ├── test_swank.clj └── test_swank ├── commands ├── basic.clj └── contrib │ └── swank_c_p_c.clj ├── core └── protocol.clj ├── util.clj └── util ├── class_browse.clj └── net └── sockets.clj /.gitignore: -------------------------------------------------------------------------------- 1 | classes/ 2 | lib/ 3 | multi-lib/ 4 | *jar 5 | pom.xml 6 | .lein-failures 7 | .lein-deps-sum 8 | /lein-swank/.lein-plugins/checksum 9 | -------------------------------------------------------------------------------- /COPYING: -------------------------------------------------------------------------------- 1 | Eclipse Public License - v 1.0 2 | 3 | THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE 4 | PUBLIC LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR DISTRIBUTION OF 5 | THE PROGRAM CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS AGREEMENT. 6 | 7 | 1. DEFINITIONS 8 | 9 | "Contribution" means: 10 | 11 | a) in the case of the initial Contributor, the initial code and 12 | documentation distributed under this Agreement, and 13 | 14 | b) in the case of each subsequent Contributor: 15 | 16 | i) changes to the Program, and 17 | 18 | ii) additions to the Program; 19 | 20 | where such changes and/or additions to the Program originate from and 21 | are distributed by that particular Contributor. A Contribution 22 | 'originates' from a Contributor if it was added to the Program by such 23 | Contributor itself or anyone acting on such Contributor's 24 | behalf. Contributions do not include additions to the Program which: 25 | (i) are separate modules of software distributed in conjunction with 26 | the Program under their own license agreement, and (ii) are not 27 | derivative works of the Program. 28 | 29 | "Contributor" means any person or entity that distributes the Program. 30 | 31 | "Licensed Patents" mean patent claims licensable by a Contributor 32 | which are necessarily infringed by the use or sale of its Contribution 33 | alone or when combined with the Program. 34 | 35 | "Program" means the Contributions distributed in accordance with this 36 | Agreement. 37 | 38 | "Recipient" means anyone who receives the Program under this 39 | Agreement, including all Contributors. 40 | 41 | 2. GRANT OF RIGHTS 42 | 43 | a) Subject to the terms of this Agreement, each Contributor hereby 44 | grants Recipient a non-exclusive, worldwide, royalty-free copyright 45 | license to reproduce, prepare derivative works of, publicly display, 46 | publicly perform, distribute and sublicense the Contribution of such 47 | Contributor, if any, and such derivative works, in source code and 48 | object code form. 49 | 50 | b) Subject to the terms of this Agreement, each Contributor hereby 51 | grants Recipient a non-exclusive, worldwide, royalty-free patent 52 | license under Licensed Patents to make, use, sell, offer to sell, 53 | import and otherwise transfer the Contribution of such Contributor, if 54 | any, in source code and object code form. This patent license shall 55 | apply to the combination of the Contribution and the Program if, at 56 | the time the Contribution is added by the Contributor, such addition 57 | of the Contribution causes such combination to be covered by the 58 | Licensed Patents. The patent license shall not apply to any other 59 | combinations which include the Contribution. No hardware per se is 60 | licensed hereunder. 61 | 62 | c) Recipient understands that although each Contributor grants the 63 | licenses to its Contributions set forth herein, no assurances are 64 | provided by any Contributor that the Program does not infringe the 65 | patent or other intellectual property rights of any other entity. Each 66 | Contributor disclaims any liability to Recipient for claims brought by 67 | any other entity based on infringement of intellectual property rights 68 | or otherwise. As a condition to exercising the rights and licenses 69 | granted hereunder, each Recipient hereby assumes sole responsibility 70 | to secure any other intellectual property rights needed, if any. For 71 | example, if a third party patent license is required to allow 72 | Recipient to distribute the Program, it is Recipient's responsibility 73 | to acquire that license before distributing the Program. 74 | 75 | d) Each Contributor represents that to its knowledge it has sufficient 76 | copyright rights in its Contribution, if any, to grant the copyright 77 | license set forth in this Agreement. 78 | 79 | 3. REQUIREMENTS 80 | 81 | A Contributor may choose to distribute the Program in object code form 82 | under its own license agreement, provided that: 83 | 84 | a) it complies with the terms and conditions of this Agreement; and 85 | 86 | b) its license agreement: 87 | 88 | i) effectively disclaims on behalf of all Contributors all warranties 89 | and conditions, express and implied, including warranties or 90 | conditions of title and non-infringement, and implied warranties or 91 | conditions of merchantability and fitness for a particular purpose; 92 | 93 | ii) effectively excludes on behalf of all Contributors all liability 94 | for damages, including direct, indirect, special, incidental and 95 | consequential damages, such as lost profits; 96 | 97 | iii) states that any provisions which differ from this Agreement are 98 | offered by that Contributor alone and not by any other party; and 99 | 100 | iv) states that source code for the Program is available from such 101 | Contributor, and informs licensees how to obtain it in a reasonable 102 | manner on or through a medium customarily used for software exchange. 103 | 104 | When the Program is made available in source code form: 105 | 106 | a) it must be made available under this Agreement; and 107 | 108 | b) a copy of this Agreement must be included with each copy of the Program. 109 | 110 | Contributors may not remove or alter any copyright notices contained 111 | within the Program. 112 | 113 | Each Contributor must identify itself as the originator of its 114 | Contribution, if any, in a manner that reasonably allows subsequent 115 | Recipients to identify the originator of the Contribution. 116 | 117 | 4. COMMERCIAL DISTRIBUTION 118 | 119 | Commercial distributors of software may accept certain 120 | responsibilities with respect to end users, business partners and the 121 | like. While this license is intended to facilitate the commercial use 122 | of the Program, the Contributor who includes the Program in a 123 | commercial product offering should do so in a manner which does not 124 | create potential liability for other Contributors. Therefore, if a 125 | Contributor includes the Program in a commercial product offering, 126 | such Contributor ("Commercial Contributor") hereby agrees to defend 127 | and indemnify every other Contributor ("Indemnified Contributor") 128 | against any losses, damages and costs (collectively "Losses") arising 129 | from claims, lawsuits and other legal actions brought by a third party 130 | against the Indemnified Contributor to the extent caused by the acts 131 | or omissions of such Commercial Contributor in connection with its 132 | distribution of the Program in a commercial product offering. The 133 | obligations in this section do not apply to any claims or Losses 134 | relating to any actual or alleged intellectual property 135 | infringement. In order to qualify, an Indemnified Contributor must: a) 136 | promptly notify the Commercial Contributor in writing of such claim, 137 | and b) allow the Commercial Contributor tocontrol, and cooperate with 138 | the Commercial Contributor in, the defense and any related settlement 139 | negotiations. The Indemnified Contributor may participate in any such 140 | claim at its own expense. 141 | 142 | For example, a Contributor might include the Program in a commercial 143 | product offering, Product X. That Contributor is then a Commercial 144 | Contributor. If that Commercial Contributor then makes performance 145 | claims, or offers warranties related to Product X, those performance 146 | claims and warranties are such Commercial Contributor's responsibility 147 | alone. Under this section, the Commercial Contributor would have to 148 | defend claims against the other Contributors related to those 149 | performance claims and warranties, and if a court requires any other 150 | Contributor to pay any damages as a result, the Commercial Contributor 151 | must pay those damages. 152 | 153 | 5. NO WARRANTY 154 | 155 | EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, THE PROGRAM IS 156 | PROVIDED ON AN "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY 157 | KIND, EITHER EXPRESS OR IMPLIED INCLUDING, WITHOUT LIMITATION, ANY 158 | WARRANTIES OR CONDITIONS OF TITLE, NON-INFRINGEMENT, MERCHANTABILITY 159 | OR FITNESS FOR A PARTICULAR PURPOSE. Each Recipient is solely 160 | responsible for determining the appropriateness of using and 161 | distributing the Program and assumes all risks associated with its 162 | exercise of rights under this Agreement , including but not limited to 163 | the risks and costs of program errors, compliance with applicable 164 | laws, damage to or loss of data, programs or equipment, and 165 | unavailability or interruption of operations. 166 | 167 | 6. DISCLAIMER OF LIABILITY 168 | 169 | EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, NEITHER RECIPIENT NOR 170 | ANY CONTRIBUTORS SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT, 171 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING 172 | WITHOUT LIMITATION LOST PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF 173 | LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 174 | NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OR 175 | DISTRIBUTION OF THE PROGRAM OR THE EXERCISE OF ANY RIGHTS GRANTED 176 | HEREUNDER, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. 177 | 178 | 7. GENERAL 179 | 180 | If any provision of this Agreement is invalid or unenforceable under 181 | applicable law, it shall not affect the validity or enforceability of 182 | the remainder of the terms of this Agreement, and without further 183 | action by the parties hereto, such provision shall be reformed to the 184 | minimum extent necessary to make such provision valid and enforceable. 185 | 186 | If Recipient institutes patent litigation against any entity 187 | (including a cross-claim or counterclaim in a lawsuit) alleging that 188 | the Program itself (excluding combinations of the Program with other 189 | software or hardware) infringes such Recipient's patent(s), then such 190 | Recipient's rights granted under Section 2(b) shall terminate as of 191 | the date such litigation is filed. 192 | 193 | All Recipient's rights under this Agreement shall terminate if it 194 | fails to comply with any of the material terms or conditions of this 195 | Agreement and does not cure such failure in a reasonable period of 196 | time after becoming aware of such noncompliance. If all Recipient's 197 | rights under this Agreement terminate, Recipient agrees to cease use 198 | and distribution of the Program as soon as reasonably 199 | practicable. However, Recipient's obligations under this Agreement and 200 | any licenses granted by Recipient relating to the Program shall 201 | continue and survive. 202 | 203 | Everyone is permitted to copy and distribute copies of this Agreement, 204 | but in order to avoid inconsistency the Agreement is copyrighted and 205 | may only be modified in the following manner. The Agreement Steward 206 | reserves the right to publish new versions (including revisions) of 207 | this Agreement from time to time. No one other than the Agreement 208 | Steward has the right to modify this Agreement. The Eclipse Foundation 209 | is the initial Agreement Steward. The Eclipse Foundation may assign 210 | the responsibility to serve as the Agreement Steward to a suitable 211 | separate entity. Each new version of the Agreement will be given a 212 | distinguishing version number. The Program (including Contributions) 213 | may always be distributed subject to the version of the Agreement 214 | under which it was received. In addition, after a new version of the 215 | Agreement is published, Contributor may elect to distribute the 216 | Program (including its Contributions) under the new version. Except as 217 | expressly stated in Sections 2(a) and 2(b) above, Recipient receives 218 | no rights or licenses to the intellectual property of any Contributor 219 | under this Agreement, whether expressly, by implication, estoppel or 220 | otherwise. All rights in the Program not expressly granted under this 221 | Agreement are reserved. 222 | 223 | This Agreement is governed by the laws of the State of Washington and 224 | the intellectual property laws of the United States of America. No 225 | party to this Agreement will bring a legal action under this Agreement 226 | more than one year after the cause of action arose. Each party waives 227 | its rights to a jury trial in any resulting litigation. 228 | -------------------------------------------------------------------------------- /NEWS.md: -------------------------------------------------------------------------------- 1 | # Swank Clojure NEWS -- history of user-visible changes 2 | 3 | ## 1.5.0 / ??? 4 | 5 | * Spun lein-swank off into its own project for `:plugins` compatibility. 6 | * Add support for clearing existing namespace with load-file. 7 | 8 | ## 1.4.1 / 2012-03-23 9 | 10 | * Add stop-server functionality. 11 | 12 | ## 1.4.0 / 2012-01-27 13 | 14 | * Added CDT debugger. 15 | * Support jacking into remote machines over tramp. 16 | 17 | ## 1.3.4 / 2011-12-27 18 | 19 | * Integrate clj-stacktrace with slime debugger buffers. 20 | * Inspector now supports showing constructors and interfaces on classes. 21 | * Make `clojure-jack-in` more forgiving of boot-time lein output. 22 | 23 | ## 1.3.3 / 2011-10-04 24 | 25 | * Load elisp payloads from various jars during jack-in. 26 | * Add support for \*out\* root value going to repl buffer. 27 | * Check for $PORT as default port. 28 | * Byte-compile elisp source to disk rather than spitting afresh every time. 29 | 30 | ## 1.3.2 / 2011-07-12 31 | 32 | * Cause the Swank server to explicitly block. 33 | 34 | ## 1.3.1 / 2011-05-16 35 | 36 | * Allow for customized announce message. 37 | * Add lein jack-in task. 38 | * Support :repl-init option from project.clj. 39 | 40 | ## 1.3.0 / 2011-03-22 41 | 42 | * Add Clojure 1.3 support. 43 | * M-x slime-load-file (C-c C-l) causes full :reload-all. 44 | * Better support for running on the bootstrap classpath. 45 | * Get encoding from locale. 46 | * Bind to localhost by default rather than 0.0.0.0. 47 | * Include Leiningen shell wrapper for standalone sessions. 48 | * Support completion on class names. 49 | 50 | ## 1.2.0 / 2010-05-15 51 | 52 | * Move lein-swank plugin to be bundled with swank-clojure. 53 | * Support M-x slime-who-calls. List all the callers of a given function. 54 | * Add swank.core/break. 55 | * Support slime-pprint-eval-last-expression. 56 | * Improve support for trunk slime. 57 | * Completion for static Java members. 58 | * Show causes of exceptions in debugger. 59 | * Preserve line numbers when compiling a region/defn. 60 | * Relicense to the EPL (same as Clojure). 61 | * Better compatibility with Clojure 1.2. 62 | 63 | ## 1.1.0 / 2010-01-01 64 | 65 | * Added slime-list-threads, killing threads. 66 | * Dim irrelevant sldb stack frames. 67 | * Emacs 22 support. 68 | 69 | ## 1.0.0 / 2009-11-10 70 | 71 | * First versioned release. 72 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Swank Clojure 2 | 3 | [Swank Clojure](http://github.com/technomancy/swank-clojure) is a 4 | server that allows SLIME (the Superior Lisp Interaction Mode for 5 | Emacs) to connect to Clojure projects. 6 | 7 | ## Deprecated 8 | 9 | This project is no longer under active development. 10 | 11 | New users are strongly encouraged to try out 12 | [nrepl.el](https://github.com/kingtim/nrepl.el) instead. If you need 13 | an advanced debugger, [Ritz](https://github.com/pallet/ritz) might be 14 | a better fit. 15 | 16 | ## Usage 17 | 18 | The simplest way is to just "jack in" from an existing project 19 | using [Leiningen](http://github.com/technomancy/leiningen): 20 | 21 | * Install `clojure-mode` either from 22 | [Marmalade](http://marmalade-repo.org) or from 23 | [git](http://github.com/technomancy/clojure-mode). 24 | * Add `[lein-swank "1.4.5"]` to the `:plugins` section of either 25 | `project.clj` or your user profile. 26 | * From an Emacs buffer inside a project, invoke `M-x clojure-jack-in` 27 | 28 | If you are still using a version of Leiningen older than 1.7.0, you 29 | will need to do `lein plugin install swank-clojure 1.4.3` instead. 30 | 31 | That's all it takes; there are no extra install steps beyond 32 | `clojure-mode` on the Emacs side and the `swank-clojure` plugin on the 33 | Leiningen side. In particular, be sure you **don't have any other 34 | versions of SLIME loaded**; see "Troubleshooting" below. 35 | 36 | ## SLIME Commands 37 | 38 | Commonly-used SLIME commands: 39 | 40 | * **M-.**: Jump to the definition of a var 41 | * **M-TAB** or **C-c TAB**: Autocomplete symbol at point 42 | * **C-x C-e**: Eval the form under the point 43 | * **C-c C-k**: Compile the current buffer 44 | * **C-c C-l**: Load current buffer and force required namespaces to reload 45 | * **C-M-x**: Compile the whole top-level form under the point. 46 | * **C-c S-i**: Inspect a value 47 | * **C-c C-m**: Macroexpand the call under the point 48 | * **C-c C-d C-d**: Look up documentation for a var 49 | * **C-c C-z**: Switch from a Clojure buffer to the repl buffer 50 | * **C-c M-p**: Switch the repl namespace to match the current buffer 51 | * **C-c C-w c**: List all callers of a given function 52 | 53 | Pressing "v" on a stack trace a debug buffer will jump to the file and 54 | line referenced by that frame if possible. 55 | 56 | Note that SLIME was designed to work with Common Lisp, which has a 57 | distinction between interpreted code and compiled code. Clojure has no 58 | such distinction, so the load-file functionality is overloaded to add 59 | :reload-all behaviour. 60 | 61 | ## Alternate Usage 62 | 63 | There are other ways to use Swank for different specific 64 | circumstances. For each of these methods you will have to install the 65 | slime and slime-repl Emacs Lisp libraries manually as outlined in 66 | "Connecting with SLIME" below. 67 | 68 | ### Standalone Server 69 | 70 | If you just want a standalone swank server with no third-party 71 | libraries, you can use the shell wrapper that Leiningen installs for 72 | you: 73 | 74 | $ lein plugin install swank-clojure 1.4.3 75 | $ ~/.lein/bin/swank-clojure 76 | 77 | M-x slime-connect 78 | 79 | If you put `~/.lein/bin` on your $PATH it's even more 80 | convenient. 81 | 82 | ### Manual Swank in Project 83 | 84 | You can also start a swank server by hand from inside your project. 85 | You'll need to have installed using `lein plugin 86 | install`, then launch the server from the shell: 87 | 88 | $ lein swank # you can specify PORT and HOST optionally 89 | 90 | If you're using Maven, add this to your pom.xml under the 91 | \ section: 92 | 93 | ```xml 94 | 95 | swank-clojure 96 | swank-clojure 97 | 1.4.3 98 | 99 | ``` 100 | 101 | Then you can launch a swank server like so: 102 | 103 | $ mvn clojure:swank 104 | 105 | Note that due to a bug in clojure-maven-plugin, you currently cannot 106 | include it as a test-scoped dependency; it must be compile-scoped. You 107 | also cannot change the port from Maven; it's hard-coded to 4005. 108 | 109 | ### Embedding 110 | 111 | You can embed Swank Clojure in your project, start the server from 112 | within your own code, and connect via Emacs to that instance: 113 | 114 | ```clj 115 | (ns my-app 116 | (:require [swank.swank])) 117 | (swank.swank/start-server) ;; optionally takes :host/:port keyword args 118 | ``` 119 | 120 | To make this work in production, swank-clojure needs to be in 121 | `:dependencies` in project.clj in addition to being installed 122 | as a user-level plugin. If you do this, you can also start the server 123 | directly from the `java` command-line launcher if you're using Clojure 124 | 1.3 or newer: 125 | 126 | $ java -cp my-project-standalone-1.0.0.jar clojure.main -m swank.swank 127 | 128 | ## Connecting with SLIME 129 | 130 | If you're not using the `M-x clojure-jack-in` method mentioned 131 | above, you'll have to install SLIME yourself. The easiest way is to 132 | use package.el. If you are using Emacs 24 or the 133 | [Emacs Starter Kit](http://github.com/technomancy/emacs-starter-kit), 134 | then you have it already. If not, get it 135 | [from Emacs's own repository](http://bit.ly/pkg-el23). 136 | 137 | Then add Marmalade as an archive source in your Emacs config: 138 | 139 | ```lisp 140 | (require 'package) 141 | (add-to-list 'package-archives 142 | '("marmalade" . "https://marmalade-repo.org/packages/") t) 143 | (package-initialize) 144 | ``` 145 | 146 | Evaluate that, then run M-x package-refresh-contents to 147 | pull in the latest source lists. Then you can do M-x 148 | package-install and choose slime-repl. 149 | 150 | When you perform the installation, you will see warnings related to 151 | the byte-compilation of the packages. This is **normal**; the packages 152 | will work just fine even if there are problems byte-compiling it upon 153 | installation. 154 | 155 | Then you should be able to connect to the swank server you launched: 156 | 157 | M-x slime-connect 158 | 159 | It will prompt you for your host (usually localhost) and port. It may 160 | also warn you that your SLIME version doesn't match your Swank 161 | version; this should be OK. 162 | 163 | To get syntax highlighting in your repl buffer, use this elisp: 164 | 165 | ```lisp 166 | (add-hook 'slime-repl-mode-hook 167 | (defun clojure-mode-slime-font-lock () 168 | (require 'clojure-mode) 169 | (let (font-lock-mode) 170 | (clojure-mode-font-lock-setup)))) 171 | ``` 172 | 173 | To get colors in stack traces, load the elisp in 174 | `src/swank/payload/slime-frame-colors.el` inside Emacs and use 175 | `lein swank $PORT localhost :colors? true` to launch the swank server. 176 | 177 | ## Troubleshooting 178 | 179 | Currently having multiple versions of swank-clojure on the classpath 180 | can cause issues when running `lein swank` or `lein jack-in`. It's 181 | recommended to not put swank-clojure in your `:dev-dependencies` but 182 | run `lein plugin install` to have it installed globally for all 183 | projects instead. This also means that people hacking on your project 184 | won't have to pull it in if they are not Emacs users. 185 | 186 | It's also possible for some packages to pull in old versions of 187 | swank-clojure transitively, so check the `lib/` directory if 188 | you are having issues. In particular, Incanter is known to exhibit 189 | this problem. Judicious use of `:exclusions` make it work: 190 | 191 | ```clj 192 | :dependencies [[incanter "1.2.3" :exclusions [swank-clojure]]] 193 | ``` 194 | 195 | Since swank-clojure 1.3.4, having versions of clj-stacktrace older 196 | than 0.2.1 in your project or user-level plugins will cause `Unable to 197 | resolve symbol: pst-elem-str` errors. Keep in mind that user-level 198 | plugins in `~/.lein/plugins` are uberjars in Leiningen 1.x, so it's 199 | possible that one of your plugins (such as `lein-difftest` before 200 | version 1.3.7) contains an old clj-stacktrace even if it doesn't have 201 | its own file there. Specifying a newer version should be enough if 202 | you're having trouble: 203 | 204 | ```clj 205 | :dependencies [[clj-stacktrace "0.2.4"]] 206 | ``` 207 | 208 | Having old versions of SLIME installed either manually or using a 209 | system-wide package manager like apt-get may cause issues. Also the 210 | official CVS version of SLIME is not supported; it often breaks 211 | compatibility with Clojure. In addition, the `slime-clj` packages are 212 | incompatible with swank-clojure. 213 | 214 | It's possible to have Emacs configured for both Common Lisp and 215 | Clojure if you defer loading of Slime until it's needed. 216 | [This issue](https://github.com/technomancy/swank-clojure/issues/66) 217 | has details on how that is done. It's not possible to have a single 218 | instance of Emacs connect to both though. 219 | 220 | Swank-clojure and SLIME are only tested with GNU Emacs; forks such as 221 | Aquamacs and XEmacs may work but are not officially supported. 222 | 223 | On Mac OS X, Emacs sessions launched from the GUI don't always respect 224 | your configured $PATH. If Emacs can't find `lein`, you may need to 225 | give it some help. The quickest way is probably to add this elisp to 226 | your config: 227 | 228 | ```lisp 229 | (setenv "PATH" (shell-command-to-string "echo $PATH")) 230 | ``` 231 | 232 | When using `clojure-jack-in`, standard out for the Leiningen process 233 | appears in the `*swank*` buffer, but the `*out*` var gets rebound to a 234 | writer that is able to redirect to the `*slime-repl*` buffer. So in 235 | general most Clojure output will show up in your repl buffer just 236 | fine, but for output coming from Java libraries you may need to check 237 | the `*swank*` buffer. 238 | 239 | ## Cygwin 240 | 241 | If you are running Emacs from Cygwin, you'll need to add the following to your 242 | .emacs.d/init.el file: 243 | 244 | ```lisp 245 | (defun cyg-slime-to-lisp-translation (filename) 246 | (replace-regexp-in-string "\n" "" 247 | (shell-command-to-string 248 | (format "cygpath.exe --windows %s" filename)))) 249 | 250 | (defun cyg-lisp-to-slime-translation (filename) 251 | (replace-regexp-in-string "\n" "" (shell-command-to-string 252 | (format "cygpath.exe --unix %s filename")))) 253 | 254 | (setq slime-to-lisp-filename-function #'cyg-slime-to-lisp-translation) 255 | (setq lisp-to-slime-filename-function #'cyg-lisp-to-slime-translation) 256 | ``` 257 | 258 | This is required because the jvm runs as a normal Windows exe and uses 259 | Windows style paths rather than Cygwin unix style paths. 260 | 261 | ## How it Works 262 | 263 | Swank Clojure is simply a server that communicates over the Slime 264 | protocol with an Emacs process. As such it runs in a JVM process, 265 | usually launched by Leiningen. Slime is a client that runs within 266 | Emacs to communicate with Swank. You can start the two of them 267 | separately as explained in "Connecting with SLIME" above, but `M-x 268 | clojure-jack-in` will send the elisp code for Slime to the Emacs 269 | process to ensure that it uses a version of Slime that is compatible 270 | with that version of Swank. Once the Swank server is finished loading, 271 | it sends a signal to Emacs to connect to it. 272 | 273 | ## Debugger 274 | 275 | You can set repl-aware breakpoints using `swank.core/break`. 276 | For now, see 277 | [Hugo Duncan's blog](http://hugoduncan.org/post/2010/swank_clojure_gets_a_break_with_the_local_environment.xhtml) 278 | for an explanation of this excellent feature. 279 | 280 | [CDT](http://georgejahad.com/clojure/swank-cdt.html) (included in 281 | Swank Clojure since 1.4.0) is a more comprehensive debugging tool 282 | that includes support for stepping, seting breakpoints, catching 283 | exceptions, and eval clojure expressions in the context of the current 284 | lexical scope. 285 | 286 | Note that the CDT does not work with `:eval-in-leiningen` without 287 | extra manual configuration. 288 | 289 | ## TODO 290 | 291 | * unmap-ns command 292 | * show method argument names in slime inspector (theoretically possible?) 293 | * show better metadata on functions in inspector 294 | * offer restarts for class/var not found exceptions (slamhound integration?) 295 | * add elisp payload for cdt commands 296 | * suppress false "warning: unabled to add tools.jar to classpath" message 297 | 298 | ## Community 299 | 300 | The [swank-clojure mailing list](http://groups.google.com/group/swank-clojure) 301 | and clojure channel on Freenode are the best places to bring up 302 | questions/issues. 303 | 304 | Contributions are preferred as either Github pull requests or using 305 | "git format-patch". Please use standard indentation with no tabs, 306 | trailing whitespace, or lines longer than 80 columns. See [this post 307 | on submitting good patches](http://technomancy.us/135) for some 308 | tips. If you've got some time on your hands, reading this [style 309 | guide](http://mumble.net/~campbell/scheme/style.txt) wouldn't hurt 310 | either. 311 | 312 | ## License 313 | 314 | Copyright © 2008-2012 Jeffrey Chu, Phil Hagelberg, Hugo Duncan, and 315 | contributors 316 | 317 | Licensed under the EPL. (See the file COPYING.) 318 | -------------------------------------------------------------------------------- /TODO.org: -------------------------------------------------------------------------------- 1 | TODO 2 | 3 | * New commands 4 | ** unmap-ns 5 | ** classpath-completion (unify with import) 6 | ** unknown vars should search known namespaces and prompt for use insertion 7 | Maybe implement as a restart? 8 | ** M-. should work for namespaces 9 | ** xref for all callers of a function? 10 | * Piggyback elisp code in jars 11 | * Type-hint-based completion for java interop 12 | * optionally pprint return values at repl 13 | * Known bugs 14 | ** TODO SLIME Inspector breaks in Emacs 22 15 | ** TODO *in* only works from *inferior-lisp* 16 | ** TODO certain project classes break class-browse: (unconfirmed) 17 | http://groups.google.com/group/swank-clojure/msg/7ab11f8698ad52d9 18 | -------------------------------------------------------------------------------- /lein-swank/README.md: -------------------------------------------------------------------------------- 1 | # lein-swank 2 | 3 | Leiningen plugin for launching a swank server. 4 | 5 | ## Usage 6 | 7 | From version 1.7.0 on, Leiningen uses a separate list for plugins 8 | rather than `:dev-dependencies`. If you are using Leiningen 1.6 or 9 | earlier, continue adding the main `swank-clojure` entry into your 10 | `:dev-dependencies`. 11 | 12 | Add `[lein-swank "1.4.5"]` to `:plugins` in `project.clj`. 13 | Then you should have access to the `swank` and `jack-in` tasks. 14 | 15 | ## License 16 | 17 | Copyright © 2012 Phil Hagelberg 18 | 19 | Distributed under the Eclipse Public License, the same as Clojure. 20 | -------------------------------------------------------------------------------- /lein-swank/project.clj: -------------------------------------------------------------------------------- 1 | (defproject lein-swank "1.4.5" 2 | :description "A Leiningen plugin for launching a Swank server for Slime." 3 | :license {:name "Eclipse Public License - v 1.0" 4 | :url "http://www.eclipse.org/legal/epl-v10.html" 5 | :distribution :repo} 6 | :url "http://github.com/technomancy/swank-clojure" 7 | :eval-in-leiningen true) 8 | -------------------------------------------------------------------------------- /lein-swank/resources/swank_elisp_payloads.clj: -------------------------------------------------------------------------------- 1 | ["swank/payload/slime.el" 2 | "swank/payload/slime-repl.el" 3 | "swank/payload/slime-frame-colors.el" 4 | "swank/payload/slime-eldoc.el"] 5 | -------------------------------------------------------------------------------- /lein-swank/src/leiningen/jack_in.clj: -------------------------------------------------------------------------------- 1 | (ns leiningen.jack-in 2 | (:require [clojure.java.io :as io] 3 | [clojure.string :as string] 4 | [leiningen.swank :as swank]) 5 | (:import (java.security MessageDigest))) 6 | 7 | (def ^:private payloads-file-name "swank_elisp_payloads.clj") 8 | 9 | (defn elisp-payload-files [] 10 | ;; TODO: this may not work with lein2 plugins 11 | (->> (.getResources (.getContextClassLoader (Thread/currentThread)) 12 | payloads-file-name) 13 | (enumeration-seq) 14 | (map (comp read-string slurp)) 15 | (apply concat) 16 | (set))) 17 | 18 | (defn hex-digest [file] 19 | (format "%x" (BigInteger. 1 (.digest (MessageDigest/getInstance "SHA1") 20 | (-> file io/resource slurp .getBytes))))) 21 | 22 | (defn loader [resource] 23 | (let [feature (second (re-find #".*/(.*?).el$" resource)) 24 | checksum (subs (hex-digest resource) 0 8) 25 | filename (format "%s-%s" feature checksum) 26 | basename (-> (or (System/getenv "HOME") 27 | (System/getProperty "user.home")) 28 | (io/file ".emacs.d" "swank" filename) 29 | (.getAbsolutePath) 30 | (.replaceAll "\\\\" "/")) 31 | elisp (str basename ".el") 32 | bytecode (str basename ".elc") 33 | elisp-file (io/file elisp)] 34 | (when-not (.exists elisp-file) 35 | (.mkdirs (.getParentFile elisp-file)) 36 | (with-open [r (.openStream (io/resource resource))] 37 | (io/copy r elisp-file)) 38 | (with-open [w (io/writer elisp-file :append true)] 39 | (.write w (format "\n(provide '%s-%s)\n" feature checksum)))) 40 | (format "(when (not (featurep '%s-%s)) 41 | (if (file-readable-p \"%s\") 42 | (load-file \"%s\") 43 | (byte-compile-file \"%s\" t)))" 44 | feature checksum bytecode bytecode elisp))) 45 | 46 | (defn jack-in 47 | "Jack in to a Clojure SLIME session from Emacs. 48 | 49 | This task is intended to be launched from Emacs using M-x clojure-jack-in, 50 | which is part of the clojure-mode library." 51 | [project port] 52 | (println ";;; Bootstrapping bundled version of SLIME; please wait...\n\n") 53 | (let [loaders (string/join "\n" (map loader (elisp-payload-files))) 54 | colors? (.contains loaders "slime-frame-colors")] 55 | (println loaders) 56 | (println "(sleep-for 0.1)") ; TODO: remove 57 | (println "(run-hooks 'slime-load-hook) ; on port" port) 58 | (println ";;; Done bootstrapping.") 59 | (swank/swank project port "localhost" ":colors?" (str colors?) 60 | ":message" "\";;; proceed to jack in\""))) 61 | -------------------------------------------------------------------------------- /lein-swank/src/leiningen/swank.clj: -------------------------------------------------------------------------------- 1 | (ns leiningen.swank 2 | "Launch swank server for Emacs to connect." 3 | (:require [clojure.java.io :as io])) 4 | 5 | (defn opts-list [project-opts port host cli-opts] 6 | (apply concat (merge {:repl-out-root true :block true 7 | :host "localhost" :port 4005} 8 | project-opts 9 | (apply hash-map (map read-string cli-opts)) 10 | (if host {:host host}) 11 | (if port {:port (Integer. port)})))) 12 | 13 | (defn swank-form [project port host cli-opts] 14 | ;; bootclasspath workaround: http://dev.clojure.org/jira/browse/CLJ-673 15 | (when (:eval-in-leiningen project) 16 | (require '[clojure walk template stacktrace])) 17 | `(do 18 | (when-let [repl-init# '~(:repl-init project)] 19 | (require repl-init#)) 20 | (swank.swank/start-server ~@(opts-list (:swank-options project) 21 | port host cli-opts)))) 22 | 23 | (def ^{:private true} jvm-opts 24 | "-agentlib:jdwp=transport=dt_socket,server=y,suspend=n") 25 | 26 | (defn- add-cdt-jvm-opts [project] 27 | (if (seq (filter #(re-find #"jdwp" %) 28 | (:jvm-opts project))) 29 | project 30 | (update-in project [:jvm-opts] conj jvm-opts))) 31 | 32 | (defn add-cdt-project-args 33 | "CDT requires the JDK's tools.jar and sa-jdi.jar. Add them to the classpath." 34 | [project] 35 | (if (:swank-cdt project true) 36 | (let [libdir (io/file (System/getProperty "java.home") ".." "lib") 37 | extra-cp (for [j ["tools.jar" "sa-jdi.jar"] 38 | :when (.exists (io/file libdir j))] 39 | (.getAbsolutePath (io/file libdir j)))] 40 | (-> project 41 | (update-in [:extra-classpath-dirs] concat extra-cp) 42 | add-cdt-jvm-opts)) 43 | project)) 44 | 45 | (defn eval-in-project 46 | "Support eval-in-project in both Leiningen 1.x and 2.x." 47 | [project form init] 48 | (let [[eip two?] (or (try (require 'leiningen.core.eval) 49 | [(resolve 'leiningen.core.eval/eval-in-project) 50 | true] 51 | (catch java.io.FileNotFoundException _)) 52 | (try (require 'leiningen.compile) 53 | [(resolve 'leiningen.compile/eval-in-project)] 54 | (catch java.io.FileNotFoundException _)))] 55 | (if two? 56 | (eip project form init) 57 | (eip project form nil nil init)))) 58 | 59 | (defn add-swank-dep [project] 60 | (if (some #(= 'swank-clojure (first %)) (:dependencies project)) 61 | project 62 | (update-in project [:dependencies] conj ['swank-clojure "1.4.3"]))) 63 | 64 | (defn swank 65 | "Launch swank server for Emacs to connect. Optionally takes PORT and HOST." 66 | ([project port host & opts] 67 | ;; TODO: only add the dependency if it's not already present 68 | (eval-in-project (-> project 69 | (add-cdt-project-args) 70 | (add-swank-dep)) 71 | (swank-form project port host opts) 72 | '(require 'swank.swank))) 73 | ([project port] (swank project port nil)) 74 | ([project] (swank project nil))) 75 | -------------------------------------------------------------------------------- /lein-swank/src/leiningen/swank_wrap.clj: -------------------------------------------------------------------------------- 1 | (ns leiningen.swank-wrap 2 | (:require [leiningen.swank :as swank] 3 | [leiningen.run])) 4 | 5 | (defn swank-wrap 6 | "Launch a swank server on the specified port, then run a -main function. 7 | 8 | ALPHA: subject to change." 9 | [project port main & args] 10 | (swank/eval-in-project (-> project 11 | (swank/add-cdt-project-args) 12 | (swank/add-swank-dep)) 13 | `(do ~(swank/swank-form project port "localhost" 14 | [":block" "false"]) 15 | ~((resolve 'leiningen.run/run-form) main args)) 16 | `(require '~(symbol main) '~'swank.swank))) -------------------------------------------------------------------------------- /lein-swank/src/swank/payload/slime-compile-presave.el: -------------------------------------------------------------------------------- 1 | ;;; slime-compile-presave.el --- Refuse to save non-compiling Slime buffers 2 | 3 | ;; Copyright © 2011 Phil Hagelberg 4 | ;; 5 | ;; Authors: Phil Hagelberg 6 | ;; URL: http://github.com/technomancy/swank-clojure 7 | ;; Version: 1.0.0 8 | ;; Keywords: languages, lisp 9 | 10 | ;; This file is not part of GNU Emacs. 11 | 12 | ;;; Code: 13 | 14 | (defvar slime-compile-presave? nil 15 | "Refuse to save slime-enabled buffers if they don't compile.") 16 | 17 | ;;;###autoload 18 | (defun slime-compile-presave-toggle () 19 | (interactive) 20 | (message "slime-compile-presave %s." 21 | (if (setq slime-compile-presave? (not slime-compile-presave?)) 22 | "enabled" "disabled"))) 23 | 24 | ;;;###autoload 25 | (defun slime-compile-presave-enable () 26 | (make-local-variable 'before-save-hook) 27 | (add-hook 'before-save-hook (defun slime-compile-presave () 28 | (when slime-compile-presave? 29 | (slime-eval `(swank:eval-and-grab-output 30 | ,(buffer-substring-no-properties 31 | (point-min) (point-max)))))))) 32 | 33 | ;;;###autoload 34 | (add-hook 'slime-mode-hook 'slime-compile-presave-enable) 35 | 36 | (provide 'slime-compile-presave) 37 | ;;; slime-compile-presave.el ends here 38 | -------------------------------------------------------------------------------- /lein-swank/src/swank/payload/slime-eldoc.el: -------------------------------------------------------------------------------- 1 | (require 'eldoc) 2 | (defun clojure-slime-eldoc-message () 3 | (when (and (featurep 'slime) 4 | (slime-background-activities-enabled-p)) 5 | (slime-echo-arglist) ; async, return nil for now 6 | nil)) 7 | 8 | (defun clojure-localize-documentation-function () 9 | (set (make-local-variable 'eldoc-documentation-function) 10 | 'clojure-slime-eldoc-message)) 11 | 12 | (add-hook 'slime-mode-hook 'clojure-localize-documentation-function) 13 | -------------------------------------------------------------------------------- /lein-swank/src/swank/payload/slime-frame-colors.el: -------------------------------------------------------------------------------- 1 | (require 'ansi-color) 2 | 3 | (defadvice sldb-insert-frame (around colorize-clj-trace (frame &optional face)) 4 | (progn 5 | (ad-set-arg 0 (list (sldb-frame.number frame) 6 | (ansi-color-apply (sldb-frame.string frame)) 7 | (sldb-frame.plist frame))) 8 | ad-do-it 9 | (save-excursion 10 | (forward-line -1) 11 | (skip-chars-forward "0-9 :") 12 | (let ((beg-line (point))) 13 | (end-of-line) 14 | (remove-text-properties beg-line (point) '(face nil)))))) 15 | 16 | (ad-activate #'sldb-insert-frame) 17 | 18 | (provide 'slime-frame-colors) 19 | -------------------------------------------------------------------------------- /lein-swank/src/swank/payload/slime.el: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/technomancy/swank-clojure/1000bbd0a035c923e1bf98fecdc9162a282ecea3/lein-swank/src/swank/payload/slime.el -------------------------------------------------------------------------------- /project.clj: -------------------------------------------------------------------------------- 1 | (defproject swank-clojure "1.5.0-SNAPSHOT" 2 | :description "Swank server connecting Clojure to Emacs SLIME" 3 | :url "http://github.com/technomancy/swank-clojure" 4 | :dependencies [[org.clojure/clojure "1.2.1"] 5 | [clj-stacktrace "0.2.4"] 6 | [org.clojure/tools.namespace "0.1.0"] 7 | [cdt "1.2.6.2"]] 8 | :dev-dependencies [[lein-multi "1.0.0"]] 9 | :multi-deps {"1.3" [[org.clojure/clojure "1.3.0"] 10 | [clj-stacktrace "0.2.4"] 11 | [cdt "1.2.6.2"]]} 12 | :warn-on-reflection true 13 | :shell-wrapper {:main swank.swank}) 14 | -------------------------------------------------------------------------------- /resources/swank_elisp_payloads.clj: -------------------------------------------------------------------------------- 1 | ["swank/payload/slime.el" 2 | "swank/payload/slime-repl.el" 3 | "swank/payload/slime-frame-colors.el" 4 | "swank/payload/slime-eldoc.el"] 5 | -------------------------------------------------------------------------------- /src/swank/cdt.clj: -------------------------------------------------------------------------------- 1 | (ns swank.cdt 2 | ;; convenience namespace to give users easy access to main functions 3 | (:refer-clojure :exclude [next]) 4 | (:require [cdt.ui :as cdt] 5 | [cdt.events] 6 | [swank.core] 7 | [swank.core.cdt-backends :as cbackends])) 8 | 9 | (def swank-cdt-release "1.5.0a") 10 | 11 | (cdt/expose cbackends/set-catch cbackends/set-bp cbackends/reval 12 | cdt/delete-catch cdt/delete-bp cdt/delete-all-breakpoints 13 | cdt/bg) 14 | 15 | (defn print-bps [] 16 | (swank.core/send-to-emacs 17 | `(:write-string 18 | ~(apply str "\nCDT Breakpoints:\n" 19 | (for [[n k] (keep-indexed vector (keys @cdt.events/bp-list))] 20 | (format "%s: %s\n" n k))) 21 | :repl-result))) 22 | 23 | (cbackends/cdt-backend-init swank-cdt-release) 24 | -------------------------------------------------------------------------------- /src/swank/clj_contrib/macroexpand.clj: -------------------------------------------------------------------------------- 1 | (ns swank.clj-contrib.macroexpand) 2 | 3 | (def 4 | #^{:private true} 5 | walk-enabled? 6 | (.getResource (clojure.lang.RT/baseLoader) "clojure/contrib/macro_utils.clj")) 7 | 8 | (when walk-enabled? 9 | (require 'clojure.contrib.macro-utils)) 10 | 11 | (defmacro macroexpand-all* [form] 12 | (if walk-enabled? 13 | `(clojure.contrib.macro-utils/mexpand-all ~form) 14 | `(macroexpand ~form))) 15 | 16 | (defn macroexpand-all [form] 17 | (macroexpand-all* form)) -------------------------------------------------------------------------------- /src/swank/clj_contrib/pprint.clj: -------------------------------------------------------------------------------- 1 | (ns swank.clj-contrib.pprint) 2 | 3 | (def #^{:private true} pprint-enabled? 4 | (try ;; 1.2+ 5 | (.getResource (clojure.lang.RT/baseLoader) "clojure/pprint") 6 | (require '[clojure.pprint :as pp]) 7 | (defmacro #^{:private true} pretty-pr-code* 8 | ([code] 9 | (if pprint-enabled? 10 | `(binding [pp/*print-suppress-namespaces* true] 11 | (pp/with-pprint-dispatch pp/code-dispatch 12 | (pp/write ~code :pretty true :stream nil))) 13 | `(pr-str ~code)))) 14 | true 15 | (catch Exception e 16 | (try ;; 1.0, 1.1 17 | (.loadClass (clojure.lang.RT/baseLoader) 18 | "clojure.contrib.pprint.PrettyWriter") 19 | (require '[clojure.contrib.pprint :as pp]) 20 | (defmacro #^{:private true} pretty-pr-code* 21 | ([code] 22 | (if pprint-enabled? 23 | `(binding [pp/*print-suppress-namespaces* true] 24 | (pp/with-pprint-dispatch pp/*code-dispatch* 25 | (pp/write ~code :pretty true :stream nil))) 26 | `(pr-str ~code)))) 27 | true 28 | ;; if you just don't have contrib, be silent. 29 | (catch ClassNotFoundException _) 30 | (catch Exception e 31 | (println e)))))) 32 | 33 | (defn pretty-pr-code [code] 34 | (pretty-pr-code* code)) 35 | -------------------------------------------------------------------------------- /src/swank/commands.clj: -------------------------------------------------------------------------------- 1 | (ns swank.commands) 2 | 3 | (defonce slime-fn-map {}) 4 | 5 | (defmacro defslimefn 6 | ([fname & body] 7 | `(alter-var-root #'slime-fn-map 8 | assoc 9 | (symbol "swank" ~(name fname)) 10 | (defn ~fname ~@body))) 11 | {:indent 'defun}) 12 | 13 | (defn slime-fn [sym] 14 | (slime-fn-map (symbol "swank" (name sym)))) -------------------------------------------------------------------------------- /src/swank/commands/basic.clj: -------------------------------------------------------------------------------- 1 | (ns swank.commands.basic 2 | (:refer-clojure :exclude [load-file print-doc]) 3 | (:use (swank util commands core) 4 | (swank.util.concurrent thread) 5 | (swank.util string clojure) 6 | (swank.clj-contrib pprint macroexpand)) 7 | (:require (swank.util [sys :as sys]) 8 | [swank.core.debugger-backends :as dbe] 9 | [clojure.tools.namespace :as ns] 10 | [clojure.string] 11 | ) 12 | (:import 13 | (java.lang.ThreadGroup) 14 | (java.util.jar JarFile) 15 | (java.io File StringReader 16 | FileInputStream LineNumberReader 17 | InputStreamReader Reader PushbackReader) 18 | 19 | (clojure.lang LineNumberingPushbackReader Symbol))) 20 | 21 | ;;;; Connection 22 | 23 | (defslimefn connection-info [] 24 | `(:pid ~(sys/get-pid) 25 | :style :spawn 26 | :lisp-implementation (:type "Clojure" 27 | :name "clojure" 28 | :version ~(clojure-version)) 29 | :package (:name ~(name (ns-name *ns*)) 30 | :prompt ~(name (ns-name *ns*))) 31 | :version ~(deref protocol-version))) 32 | 33 | (defslimefn quit-lisp [] 34 | (and @exit-on-quit? 35 | (System/exit 0))) 36 | 37 | (defslimefn toggle-debug-on-swank-error [] 38 | (alter-var-root #'swank.core/debug-swank-clojure not)) 39 | 40 | ;;;; Evaluation 41 | 42 | (defn- eval-region 43 | "Evaluate string, return the results of the last form as a list and 44 | a secondary value the last form." 45 | ([string] 46 | (eval-region string "NO_SOURCE_FILE" 1)) 47 | ([string file line] 48 | (with-open [rdr (proxy [LineNumberingPushbackReader] 49 | ((StringReader. string)) 50 | (getLineNumber [] line))] 51 | (binding [*file* file] 52 | (loop [form (read rdr false rdr), value nil, last-form nil] 53 | (if (= form rdr) 54 | [value last-form] 55 | (recur (read rdr false rdr) 56 | (dbe/swank-eval form) 57 | form))))))) 58 | 59 | (defn- compile-region 60 | "Compile region." 61 | ([string file line] 62 | (with-open [rdr1 (proxy [LineNumberingPushbackReader] 63 | ((StringReader. string))) 64 | rdr (proxy [LineNumberingPushbackReader] (rdr1) 65 | (getLineNumber [] (+ line (.getLineNumber rdr1) -1)))] 66 | (clojure.lang.Compiler/load rdr file (.getName (File. #^String file)))))) 67 | 68 | 69 | (defslimefn interactive-eval-region [string] 70 | (with-emacs-package 71 | (pr-str (first (eval-region string))))) 72 | 73 | (defslimefn interactive-eval [string] 74 | (with-emacs-package 75 | (pr-str 76 | (let [value (first (eval-region string))] 77 | ;; If the result is a seq, consume it here instead of getting evaluated 78 | ;; from pr-str to allow side-effects to go to the repl. 79 | (if (instance? clojure.lang.LazySeq value) 80 | (doall value) 81 | value) 82 | )))) 83 | 84 | (defslimefn listener-eval [form] 85 | (with-emacs-package 86 | (with-package-tracking 87 | (let [[value last-form] (eval-region form)] 88 | (when (and last-form (not (one-of? last-form '*1 '*2 '*3 '*e))) 89 | (set! *3 *2) 90 | (set! *2 *1) 91 | (set! *1 value)) 92 | (send-repl-results-to-emacs value))))) 93 | 94 | (defslimefn eval-and-grab-output [string] 95 | (with-emacs-package 96 | (let [retval (promise)] 97 | (list (with-out-str 98 | (deliver retval (pr-str (first (eval-region string))))) 99 | @retval)))) 100 | 101 | (defslimefn pprint-eval [string] 102 | (with-emacs-package 103 | (pretty-pr-code (first (eval-region string))))) 104 | 105 | ;;;; Macro expansion 106 | 107 | (defn- apply-macro-expander [expander string] 108 | (pretty-pr-code (expander (read-string string)))) 109 | 110 | (defslimefn swank-macroexpand-1 [string] 111 | (apply-macro-expander macroexpand-1 string)) 112 | 113 | (defslimefn swank-macroexpand [string] 114 | (apply-macro-expander macroexpand string)) 115 | 116 | ;; not implemented yet, needs walker 117 | (defslimefn swank-macroexpand-all [string] 118 | (apply-macro-expander macroexpand-all string)) 119 | 120 | ;;;; Compiler / Execution 121 | 122 | (def compiler-exception-location-re #"Exception:.*\(([^:]+):([0-9]+)(:[0-9]+)?\)") 123 | (defn- guess-compiler-exception-location [#^Throwable t] 124 | (when (instance? clojure.lang.Compiler$CompilerException t) 125 | (let [[match file line] (re-find compiler-exception-location-re (str t))] 126 | (when (and file line) 127 | `(:location (:file ~file) (:line ~(Integer/parseInt line)) nil))))) 128 | 129 | ;; TODO: Make more and better guesses 130 | (defn- exception-location [#^Throwable t] 131 | (or (guess-compiler-exception-location t) 132 | '(:error "No error location available"))) 133 | 134 | ;; plist of message, severity, location, references, short-message 135 | (defn- exception-to-message [#^Throwable t] 136 | `(:message ~(.toString t) 137 | :severity :error 138 | :location ~(exception-location t) 139 | :references nil 140 | :short-message ~(.toString t))) 141 | 142 | (defn destroy-ns 143 | [ns] 144 | (doseq [sym (keys (ns-refers ns))] 145 | (ns-unmap ns sym)) 146 | (doseq [a (keys (ns-aliases ns))] 147 | (ns-unalias ns a)) 148 | (doseq [a (keys (ns-publics ns))] 149 | (ns-unmap ns a))) 150 | 151 | (defn- compile-file-for-emacs* 152 | "Compiles a file for emacs. Because clojure doesn't compile, this is 153 | simple an alias for load file w/ timing and messages. This function 154 | is to reply with the following: 155 | (:swank-compilation-unit notes results durations)" 156 | ([file-name] 157 | (let [start (System/nanoTime)] 158 | (try 159 | (let [ret (clojure.core/load-file file-name) 160 | delta (- (System/nanoTime) start)] 161 | `(:compilation-result nil ~(pr-str ret) ~(/ delta 1000000000.0))) 162 | (catch Throwable t 163 | (let [delta (- (System/nanoTime) start) 164 | causes (exception-causes t) 165 | num (count causes)] 166 | (.printStackTrace t) ;; prints to *inferior-lisp* 167 | `(:compilation-result 168 | ~(map exception-to-message causes) ;; notes 169 | nil ;; results 170 | ~(/ delta 1000000000.0) ;; durations 171 | ))))))) 172 | 173 | (defslimefn compile-file-for-emacs 174 | ([file-name load? & compile-options] 175 | (when load? 176 | (compile-file-for-emacs* file-name)))) 177 | 178 | (defslimefn load-file [file-name] 179 | (let [libs-ref @(resolve 'clojure.core/*loaded-libs*) 180 | libs @libs-ref 181 | ns-form (ns/read-file-ns-decl (java.io.File. file-name)) 182 | ns (second ns-form)] 183 | (try 184 | (when ns 185 | (destroy-ns ns)) 186 | (dosync (ref-set libs-ref #{})) 187 | (pr-str (clojure.core/load-file file-name)) 188 | (finally 189 | (dosync (alter libs-ref into libs)))))) 190 | 191 | (defn- line-at-position [file position] 192 | (try 193 | (with-open [f (java.io.LineNumberReader. (java.io.FileReader. 194 | #^String file))] 195 | (.skip f position) 196 | (.getLineNumber f)) 197 | (catch Exception e 1))) 198 | 199 | (defmacro compiler-exception [directory line ex] 200 | `(eval (if (>= (:minor *clojure-version*) 5) 201 | '(clojure.lang.Compiler$CompilerException. 202 | ~directory ~line 0 ~ex) 203 | '(clojure.lang.Compiler$CompilerException. 204 | ~directory ~line ~ex)))) 205 | 206 | (defslimefn compile-string-for-emacs [string buffer position directory debug] 207 | (let [start (System/nanoTime) 208 | line (line-at-position directory position) 209 | ret (with-emacs-package 210 | (when-not (= (name (ns-name *ns*)) *current-package*) 211 | (throw (compiler-exception 212 | directory line 213 | (Exception. (str "No such namespace: " 214 | *current-package*))))) 215 | (compile-region string directory line)) 216 | delta (- (System/nanoTime) start)] 217 | `(:compilation-result nil ~(pr-str ret) ~(/ delta 1000000000.0)))) 218 | 219 | ;;;; Describe 220 | 221 | (defn- maybe-resolve-sym 222 | "Returns a Var or nil" 223 | [symbol-name] 224 | (try 225 | (ns-resolve (maybe-ns *current-package*) (symbol symbol-name)) 226 | (catch ClassNotFoundException e nil) 227 | (catch RuntimeException e (if (instance? ClassNotFoundException (.getCause e)) 228 | nil 229 | (throw e))))) 230 | 231 | (defn- maybe-resolve-ns 232 | "Returns a Namespace or nil" 233 | [sym-name] 234 | (let [sym (symbol sym-name)] 235 | (or ((ns-aliases (maybe-ns *current-package*)) sym) 236 | (find-ns sym)))) 237 | 238 | (defn- print-doc* [m] 239 | (println "-------------------------") 240 | (println (str (when-let [ns (:ns m)] (str (ns-name ns) "/")) (:name m))) 241 | (cond 242 | (:forms m) (doseq [f (:forms m)] 243 | (print " ") 244 | (prn f)) 245 | (:arglists m) (prn (:arglists m))) 246 | (if (:special-form m) 247 | (do 248 | (println "Special Form") 249 | (println " " (:doc m)) 250 | (if (contains? m :url) 251 | (when (:url m) 252 | (println (str "\n Please see http://clojure.org/" (:url m)))) 253 | (println (str "\n Please see http://clojure.org/special_forms#" 254 | (:name m))))) 255 | (do 256 | (when (:macro m) 257 | (println "Macro")) 258 | (println " " (:doc m))))) 259 | 260 | (def print-doc (let [print-doc (resolve 'clojure.core/print-doc)] 261 | (if (or (nil? print-doc) (-> print-doc meta :private)) 262 | (comp print-doc* meta) 263 | print-doc))) 264 | 265 | (defn- describe-to-string [var] 266 | (with-out-str 267 | (print-doc var))) 268 | 269 | (defn- describe-symbol* [symbol-name] 270 | (with-emacs-package 271 | (if-let [v (maybe-resolve-sym symbol-name)] 272 | (if-not (class? v) 273 | (describe-to-string v))))) 274 | 275 | (defslimefn describe-symbol [symbol-name] 276 | (describe-symbol* symbol-name)) 277 | 278 | (defslimefn describe-function [symbol-name] 279 | (describe-symbol* symbol-name)) 280 | 281 | ;; Only one namespace... so no kinds 282 | (defslimefn describe-definition-for-emacs [name kind] 283 | (describe-symbol* name)) 284 | 285 | ;; Only one namespace... so only describe symbol 286 | (defslimefn documentation-symbol 287 | ([symbol-name default] (documentation-symbol symbol-name)) 288 | ([symbol-name] (describe-symbol* symbol-name))) 289 | 290 | ;;;; Documentation 291 | 292 | (defn- briefly-describe-symbol-for-emacs [var] 293 | (let [lines (fn [s] (.split #^String s (System/getProperty "line.separator"))) 294 | [_ symbol-name arglists d1 d2 & __] (lines (describe-to-string var)) 295 | macro? (= d1 "Macro")] 296 | (list :designator symbol-name 297 | (cond 298 | macro? :macro 299 | (:arglists (meta var)) :function 300 | :else :variable) 301 | (apply str (concat arglists (if macro? d2 d1)))))) 302 | 303 | (defn- make-apropos-matcher [pattern case-sensitive?] 304 | (let [pattern (java.util.regex.Pattern/quote pattern) 305 | pat (re-pattern (if case-sensitive? 306 | pattern 307 | (format "(?i:%s)" pattern)))] 308 | (fn [var] (re-find pat (pr-str var))))) 309 | 310 | (defn- apropos-symbols [string external-only? case-sensitive? package] 311 | (let [packages (or (when package [package]) (all-ns)) 312 | matcher (make-apropos-matcher string case-sensitive?) 313 | lister (if external-only? ns-publics ns-interns)] 314 | (filter matcher 315 | (apply concat (map (comp (partial map second) lister) 316 | packages))))) 317 | 318 | (defn- present-symbol-before 319 | "Comparator such that x belongs before y in a printed summary of symbols. 320 | Sorted alphabetically by namespace name and then symbol name, except 321 | that symbols accessible in the current namespace go first." 322 | [x y] 323 | (let [accessible? 324 | (fn [var] (= (maybe-resolve-sym (:name (meta var))) 325 | var)) 326 | ax (accessible? x) ay (accessible? y)] 327 | (cond 328 | (and ax ay) (compare (:name (meta x)) (:name (meta y))) 329 | ax -1 330 | ay 1 331 | :else (let [nx (str (:ns (meta x))) ny (str (:ns (meta y)))] 332 | (if (= nx ny) 333 | (compare (:name (meta x)) (:name (meta y))) 334 | (compare nx ny)))))) 335 | 336 | (defslimefn apropos-list-for-emacs 337 | ([name] 338 | (apropos-list-for-emacs name nil)) 339 | ([name external-only?] 340 | (apropos-list-for-emacs name external-only? nil)) 341 | ([name external-only? case-sensitive?] 342 | (apropos-list-for-emacs name external-only? case-sensitive? nil)) 343 | ([name external-only? case-sensitive? package] 344 | (let [package (when package 345 | (maybe-ns package))] 346 | (map briefly-describe-symbol-for-emacs 347 | (sort present-symbol-before 348 | (apropos-symbols name external-only? case-sensitive? 349 | package)))))) 350 | 351 | ;;;; Operator messages 352 | (defslimefn operator-arglist [name package] 353 | (try 354 | (let [f (read-string name)] 355 | (cond 356 | (keyword? f) "([map])" 357 | (symbol? f) (let [var (ns-resolve (maybe-ns package) f)] 358 | (if-let [args (and var (:arglists (meta var)))] 359 | (pr-str args) 360 | nil)) 361 | :else nil)) 362 | (catch Throwable t nil))) 363 | 364 | ;;;; Package Commands 365 | 366 | (defslimefn list-all-package-names 367 | ([] (map (comp str ns-name) (all-ns))) 368 | ([nicknames?] (list-all-package-names))) 369 | 370 | (defslimefn set-package [name] 371 | (let [ns (maybe-ns name)] 372 | (in-ns (ns-name ns)) 373 | (list (str (ns-name ns)) 374 | (str (ns-name ns))))) 375 | 376 | ;;;; Tracing 377 | 378 | (defonce traced-fn-map {}) 379 | 380 | (def #^{:dynamic true} *trace-level* 0) 381 | 382 | (defn- indent [num] 383 | (dotimes [x (+ 1 num)] 384 | (print " "))) 385 | 386 | (defn- trace-fn-call [fn-sym f args] 387 | (indent *trace-level*) 388 | (println (str *trace-level* ":") 389 | (apply str (take 240 (pr-str (when fn-sym (cons fn-sym args)) )))) 390 | (let [result (binding [*trace-level* (+ *trace-level* 1)] (apply f args))] 391 | (indent *trace-level*) 392 | (println (str *trace-level* ": " 393 | fn-sym " returned " 394 | (apply str (take 240 (pr-str result))))) 395 | result)) 396 | 397 | (defslimefn swank-toggle-trace [#^String fname] 398 | (when-let [f-var (maybe-resolve-sym fname) 399 | ] 400 | (if-let [f# (get traced-fn-map f-var)] 401 | (do 402 | (alter-var-root #'traced-fn-map dissoc f-var) 403 | (alter-var-root f-var (constantly f#)) 404 | (str " untraced.")) 405 | (let [f# @f-var] 406 | (alter-var-root #'traced-fn-map assoc f-var f#) 407 | (alter-var-root f-var 408 | (constantly 409 | (fn [& args] 410 | (trace-fn-call (symbol fname) f# args)))) 411 | (str " traced."))))) 412 | 413 | (defslimefn untrace-all [] 414 | (doseq [f-var (keys traced-fn-map)] 415 | (let [fname (str (:ns (meta f-var)) "/" (:name (meta f-var)))] 416 | (swank-toggle-trace fname)))) 417 | 418 | ;;; Profiling 419 | ;; stubs 420 | (defslimefn toggle-profile-fdefinition 421 | [fname] 422 | "`toggle-profile-fdefinition` is *not* implemented") 423 | 424 | (defslimefn unprofile-all 425 | [] "`unprofile-all` is *not* implemented") 426 | 427 | (defslimefn profile-report 428 | [] "`profile-report` is *not* implemented") 429 | 430 | (defslimefn profile-reset 431 | [] "`profile-reset` is *not* implemented") 432 | (defslimefn profiled-functions 433 | [] "`profiled-functions` is *not* implemented") 434 | 435 | (defslimefn profile-package 436 | [package callers? methods?] "`profiled-package` is *not* implemented") 437 | 438 | (defslimefn profile-by-substring 439 | [substring & [package]] "`profiled-by` is *not* implemented") 440 | 441 | ;;;; Source Locations 442 | (comment 443 | "Sets the default directory (java's user.dir). Note, however, that 444 | this will not change the search path of load-file. ") 445 | (defslimefn set-default-directory 446 | ([directory & ignore] 447 | (System/setProperty "user.dir" directory) 448 | directory)) 449 | 450 | (defslimefn default-directory 451 | ([] (System/getProperty "user.dir"))) 452 | 453 | ;;;; meta dot find 454 | 455 | (defn- clean-windows-path [#^String path] 456 | ;; Decode file URI encoding and remove an opening slash from 457 | ;; /c:/program%20files/... in jar file URLs and file resources. 458 | (or (and (.startsWith (System/getProperty "os.name") "Windows") 459 | (second (re-matches #"^/([a-zA-Z]:/.*)$" path))) 460 | path)) 461 | 462 | (defn- slime-zip-resource [#^java.net.URL resource] 463 | (let [jar-connection #^java.net.JarURLConnection (.openConnection resource) 464 | jar-file (.getPath (.toURI (.getJarFileURL jar-connection)))] 465 | (list :zip (clean-windows-path jar-file) (.getEntryName jar-connection)))) 466 | 467 | (defn- slime-file-resource [#^java.net.URL resource] 468 | (list :file (clean-windows-path (.getFile resource)))) 469 | 470 | (defn- slime-find-resource [#^String file] 471 | (if-let [resource (.getResource (clojure.lang.RT/baseLoader) file)] 472 | (if (= (.getProtocol resource) "jar") 473 | (slime-zip-resource resource) 474 | (slime-file-resource resource)))) 475 | 476 | (defn- slime-find-file [#^String file] 477 | (if file 478 | (if (.isAbsolute (File. file)) 479 | (list :file file) 480 | (slime-find-resource file)))) 481 | 482 | (defn- namespace-to-path [ns] 483 | (let [#^String ns-str (name (ns-name ns)) 484 | last-dot-index (.lastIndexOf ns-str ".")] 485 | (if (pos? last-dot-index) 486 | (-> (.substring ns-str 0 last-dot-index) 487 | (.replace \- \_) 488 | (.replace \. \/))))) 489 | 490 | (defn- classname-to-path [class-name] 491 | (namespace-to-path 492 | (symbol (.replace #^String class-name \_ \-)))) 493 | 494 | 495 | (defn- location-in-file [path line] 496 | `(:location ~path (:line ~line) nil)) 497 | 498 | (defn- location-label [name type] 499 | (if type 500 | (str "(" type " " name ")") 501 | (str name))) 502 | 503 | (defn- location [name type path line] 504 | `((~(location-label name type) 505 | ~(if path 506 | (location-in-file path line) 507 | (list :error (format "%s - definition not found." name)))))) 508 | 509 | (defn- location-not-found [name type] 510 | (location name type nil nil)) 511 | 512 | (defn source-location-for-frame [#^StackTraceElement frame] 513 | (let [line (.getLineNumber frame) 514 | filename (if (.. frame getFileName (endsWith ".java")) 515 | (.. frame getClassName (replace \. \/) 516 | (substring 0 (.lastIndexOf (.getClassName frame) ".")) 517 | (concat (str File/separator (.getFileName frame)))) 518 | (let [ns-path (classname-to-path 519 | ((re-find #"(.*?)\$" 520 | (.getClassName frame)) 1))] 521 | (if ns-path 522 | (str ns-path File/separator (.getFileName frame)) 523 | (.getFileName frame)))) 524 | path (slime-find-file filename)] 525 | (if path 526 | (location-in-file path line) 527 | (list :error (format "%s - source not found." filename))))) 528 | 529 | (defn- namespace-to-filename [ns] 530 | (str (-> (str ns) 531 | (.replaceAll "\\." File/separator) 532 | (.replace \- \_ )) 533 | ".clj")) 534 | 535 | (defn- source-location-for-meta [meta xref-type-name] 536 | (location (:name meta) 537 | xref-type-name 538 | (slime-find-file (:file meta)) 539 | (:line meta))) 540 | 541 | (defn- find-ns-definition [sym-name] 542 | (if-let [ns (maybe-resolve-ns sym-name)] 543 | (when-let [path (slime-find-file (namespace-to-filename ns))] 544 | (location ns nil path 1)))) 545 | 546 | (defn- find-var-definition [sym-name] 547 | ;; TODO this doesn't work if sym-name refers to a protocol function 548 | (if-let [meta (meta (maybe-resolve-sym sym-name))] 549 | (source-location-for-meta meta "defn"))) 550 | 551 | (defslimefn find-definitions-for-emacs [name] 552 | (let [sym-name (read-string name)] 553 | (or (find-var-definition sym-name) 554 | (find-ns-definition sym-name) 555 | (location name nil nil nil)))) 556 | 557 | ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 558 | ;;; xref who-calls support (was in xref.clj) 559 | (defn- get-jar-entry-as-stream [^String jarpath ^String entry-name] 560 | (let [jarfile (JarFile. jarpath)] 561 | (.getInputStream jarfile (.getEntry jarfile entry-name)))) 562 | 563 | (defn- get-resource-stream [filepath] 564 | (if-let [location (slime-find-file filepath)] 565 | (case (first location) 566 | :zip (apply get-jar-entry-as-stream (rest location)) 567 | :file (java.io.FileInputStream. ^String (second location))))) 568 | 569 | (defn- get-source-from-var 570 | "Returns a string of the source code for the given symbol, if it can 571 | find it. This requires that the symbol resolve to a Var defined in 572 | a namespace for which the .clj is in the classpath. Returns nil if 573 | it can't find the source. 574 | Example: (get-source-from-var 'filter)" 575 | [v] 576 | (when-let [filepath (:file (meta v))] 577 | (when-let [strm (get-resource-stream filepath)] 578 | (with-open [rdr (LineNumberReader. (InputStreamReader. strm))] 579 | (dotimes [_ (dec (:line (meta v)))] (.readLine rdr)) 580 | (let [text (StringBuilder.) 581 | pbr (proxy [PushbackReader] [rdr] 582 | (read [] (let [#^Reader this this 583 | i (proxy-super read)] 584 | (.append text (char i)) 585 | i)))] 586 | (read (PushbackReader. pbr)) 587 | (str text)))))) 588 | 589 | (defn- recursive-contains? [coll obj] 590 | "True if coll contains obj. Obj can't be a seq" 591 | (not (empty? (filter #(= obj %) (flatten coll))))) 592 | 593 | (defn- does-var-call-fn [var fn] 594 | "Checks if a var calls a function named 'fn" 595 | (if-let [source (get-source-from-var var)] 596 | (let [node (read-string source)] 597 | (if (recursive-contains? node fn) 598 | var 599 | false)))) 600 | 601 | (defn- does-ns-refer-to-var? [ns var] 602 | (ns-resolve ns var)) 603 | 604 | (defn- all-vars-who-call [sym] 605 | (filter 606 | ifn? 607 | (filter identity 608 | (map #(does-var-call-fn % sym) 609 | (flatten 610 | (map vals 611 | (map ns-interns 612 | (filter #(does-ns-refer-to-var? % sym) 613 | (all-ns))))))))) 614 | 615 | (defn who-calls [name] 616 | (letfn [(xref-lisp [sym-var] ; see find-definitions-for-emacs 617 | (when-let [meta (meta sym-var)] 618 | (source-location-for-meta meta nil)))] 619 | (let [callers (all-vars-who-call name) ] 620 | (map first (map xref-lisp callers))))) 621 | 622 | (defn- get-line-no-from-defmethod 623 | ;; TODO this is very simplistic at the moment and relies on a 624 | ;; brittle regex 625 | [multifn-name dispatch-val ns] 626 | (let [filepath (namespace-to-filename ns) 627 | re (re-pattern (str "defmethod *" multifn-name " *" dispatch-val))] 628 | (when-let [strm (get-resource-stream filepath)] 629 | (with-open [rdr (LineNumberReader. (InputStreamReader. strm))] 630 | (loop [] 631 | (if-let [ln (.readLine rdr)] 632 | (if (re-find re ln) 633 | (location (str multifn-name " " dispatch-val) 634 | "defmethod" 635 | (slime-find-file filepath) 636 | (.getLineNumber rdr)) 637 | (recur)))) 638 | #_(loop [results []] 639 | (if-let [ln (.readLine rdr)] 640 | (if (re-find re ln) 641 | (recur (conj results 642 | (location multifn-name "defmulti" 643 | (slime-find-file filepath) 644 | (.getLineNumber rdr)))) 645 | (recur results)) 646 | results)))))) 647 | 648 | (defn- all-ns-who-defmulti [multifn] 649 | (for [[dispatch-val m] (methods multifn)] 650 | (let [ns-nm (-> m str (clojure.string/split #"\$") first) 651 | ns-nm-v2 (clojure.string/replace ns-nm "_" "-")] 652 | [dispatch-val (some (fn [ns] 653 | (let [nm (-> ns ns-name str)] 654 | (if (or (= ns-nm nm) 655 | (= ns-nm-v2 nm)) ns))) 656 | (all-ns))]))) 657 | 658 | (defn who-specializes-multifn [multifn-var] 659 | (let [multifn-name (:name (meta multifn-var))] 660 | (map first (filter seq 661 | (for [[dispatch-val ns] (all-ns-who-defmulti @multifn-var)] 662 | (filter identity (get-line-no-from-defmethod 663 | multifn-name dispatch-val ns))))))) 664 | 665 | (defn who-specializes [class] 666 | ;; this appears to be broken 667 | ;; TODO make it work for multimethod 668 | ;; (map ns-name (all-ns)) 669 | 670 | (letfn [(xref-lisp [sym] ; see find-definitions-for-emacs 671 | (if-let [meta (meta sym)] 672 | (source-location-for-meta meta "method") 673 | (location-not-found (name sym) "method")))] 674 | (let [methods (try (. #^java.lang.Class class getMethods) 675 | (catch java.lang.IllegalArgumentException e nil) 676 | (catch java.lang.NullPointerException e nil))] 677 | (map xref-lisp methods)))) 678 | 679 | (defslimefn xref [type name] 680 | (let [sexp (maybe-resolve-sym name)] 681 | (condp = type 682 | :specializes (who-specializes-multifn sexp) ;; (who-specializes sexp) 683 | :calls (who-calls (symbol name)) 684 | :callers nil 685 | :not-implemented))) 686 | 687 | ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 688 | 689 | (defslimefn throw-to-toplevel [] 690 | (throw debug-quit-exception)) 691 | 692 | (defn invoke-restart [restart] 693 | ((nth restart 2))) 694 | 695 | (defslimefn invoke-nth-restart-for-emacs [level n] 696 | (try 697 | ((invoke-restart (*sldb-restarts* (nth (keys *sldb-restarts*) n)))) 698 | (catch IndexOutOfBoundsException e (throw debug-invalid-restart-exception)))) 699 | 700 | (defslimefn throw-to-toplevel [] 701 | (if-let [restart (*sldb-restarts* :quit)] 702 | (invoke-restart restart))) 703 | 704 | (defslimefn sldb-continue [] 705 | (if-let [restart (*sldb-restarts* :continue)] 706 | (invoke-restart restart))) 707 | 708 | (defslimefn sldb-abort [] 709 | (if-let [restart (*sldb-restarts* :abort)] 710 | (invoke-restart restart))) 711 | 712 | 713 | (defslimefn backtrace [start end] 714 | (dbe/build-backtrace start end)) 715 | 716 | (defslimefn buffer-first-change [file-name] nil) 717 | 718 | (defn locals-for-emacs [m] 719 | (sort-by second 720 | (map #(list :name (name (first %)) :id 0 721 | :value (pr-str (second %))) m))) 722 | 723 | (defslimefn frame-catch-tags-for-emacs [n] nil) 724 | (defslimefn frame-locals-for-emacs [n] 725 | (if (and (zero? n) (seq *current-env*)) 726 | (locals-for-emacs *current-env*))) 727 | 728 | (defslimefn frame-locals-and-catch-tags [n] 729 | (list (frame-locals-for-emacs n) 730 | (frame-catch-tags-for-emacs n))) 731 | 732 | (defslimefn debugger-info-for-emacs [start end] 733 | (build-debugger-info-for-emacs start end)) 734 | 735 | (defslimefn eval-string-in-frame [expr n] 736 | (dbe/eval-string-in-frame expr n)) 737 | 738 | (defslimefn eval-last-frame [expr] 739 | (dbe/eval-last-frame expr)) 740 | 741 | (defslimefn frame-source-location [n] 742 | (source-location-for-frame (dbe/get-stack-trace n))) 743 | 744 | ;; Older versions of slime use this instead of the above. 745 | (defslimefn frame-source-location-for-emacs [n] 746 | (source-location-for-frame (dbe/get-stack-trace n))) 747 | 748 | (defslimefn create-repl [target] '("user" "user")) 749 | 750 | ;;; Threads 751 | 752 | (def #^{:private true} thread-list (atom [])) 753 | 754 | (defn- get-root-group [#^java.lang.ThreadGroup tg] 755 | (if-let [parent (.getParent tg)] 756 | (recur parent) 757 | tg)) 758 | 759 | (defn get-thread-list [] 760 | (let [#^ThreadGroup rg (get-root-group (.getThreadGroup (Thread/currentThread))) 761 | #^"[Ljava.lang.Thread;" arr (make-array Thread (.activeCount rg))] 762 | (.enumerate rg arr true) ;needs type hint 763 | (seq arr))) 764 | 765 | (defn- extract-info [#^Thread t] 766 | (map str [(.getId t) (.getName t) (.getPriority t) (.getState t)])) 767 | 768 | (defslimefn list-threads 769 | "Return a list (LABELS (ID NAME STATUS ATTRS ...) ...). 770 | LABELS is a list of attribute names and the remaining lists are the 771 | corresponding attribute values per thread." 772 | [] 773 | (reset! thread-list (get-thread-list)) 774 | (let [labels '(id name priority state)] 775 | (cons labels (map extract-info @thread-list)))) 776 | 777 | ;;; TODO: Find a better way, as Thread.stop is deprecated 778 | (defslimefn kill-nth-thread [index] 779 | (when index 780 | (when-let [#^Thread thread (nth @thread-list index nil)] 781 | (println "Thread: " thread) 782 | (.stop thread)))) 783 | 784 | (defslimefn quit-thread-browser [] 785 | (reset! thread-list [])) 786 | -------------------------------------------------------------------------------- /src/swank/commands/cljs.clj: -------------------------------------------------------------------------------- 1 | (ns ^{:doc "Support for sending evaluation of forms into a ClojureScript repl."} 2 | swank.commands.cljs 3 | (:use [swank.core :only (with-emacs-package)] 4 | [swank.commands :onlny (defslimefn)]) 5 | (:require [cljs.repl :as repl] 6 | [cljs.compiler :as comp]) 7 | ) 8 | 9 | (def cljs-targets "A mapping of registered repl environments which can be used as targets." (atom {})) 10 | 11 | (defn register-repl 12 | "Register a new REPL environment for interactive-eval-with-target to dispatch to." 13 | [key env] 14 | (swap! cljs-targets assoc key env)) 15 | 16 | (defn eval-in-cljs 17 | "Evaluate the given string in the provided ClojureScript repl environment." 18 | [env form-string] 19 | (binding [comp/*cljs-ns* comp/*cljs-ns*] 20 | (let [form (read-string form-string), 21 | ;; Note: the following is lifted from cljs.repl.browser; FIXME: we 22 | ;; should add support there to do this without a repl thread. 23 | context {:context :statement 24 | :locals {} 25 | :ns (@comp/namespaces comp/*cljs-ns*)}] 26 | 27 | (repl/evaluate-form env context "" form) 28 | ))) 29 | 30 | (defslimefn ^{:doc "Evaluate a Clojure form in a ClojureScript environment."} 31 | interactive-eval-with-target [target form-string] 32 | (let [env (get @cljs-targets target)] 33 | (if env 34 | (eval-in-cljs env form-string) 35 | (throw (Exception. 36 | (format "Emacs eval abort; eval target '%s' not found" target))) 37 | ))) 38 | 39 | 40 | ;; Notes: 41 | ;; 42 | ;; You will need an Emacs customization that overrides 43 | ;; slime-interactive-eval tocall (swank:interactive-eval-with-target) instead of 44 | ;; (swank:interactive-eval), such as is provided in clojure-mode.el. 45 | ;; 46 | ;; Also, before you can eval to a target, you will need your VM to have a repl 47 | ;; instance registered via 'register-repl' (e.g. browser repl). 48 | -------------------------------------------------------------------------------- /src/swank/commands/completion.clj: -------------------------------------------------------------------------------- 1 | (ns swank.commands.completion 2 | (:use (swank util core commands) 3 | (swank.util string clojure java class-browse))) 4 | 5 | (defn potential-ns 6 | "Returns a list of potential namespace completions for a given 7 | namespace" 8 | ([] (potential-ns *ns*)) 9 | ([ns] 10 | (for [ns-sym (concat (keys (ns-aliases (ns-name ns))) 11 | (map ns-name (all-ns)))] 12 | (name ns-sym)))) 13 | 14 | (defn potential-var-public 15 | "Returns a list of potential public var name completions for a 16 | given namespace" 17 | ([] (potential-var-public *ns*)) 18 | ([ns] 19 | (for [var-sym (keys (ns-publics ns))] 20 | (name var-sym)))) 21 | 22 | (defn potential-var 23 | "Returns a list of all potential var name completions for a given 24 | namespace" 25 | ([] (potential-var *ns*)) 26 | ([ns] 27 | (for [[key v] (ns-map ns) 28 | :when (var? v)] 29 | (name key)))) 30 | 31 | (defn potential-classes 32 | "Returns a list of potential class name completions for a given 33 | namespace" 34 | ([] (potential-classes *ns*)) 35 | ([ns] 36 | (for [class-sym (keys (ns-imports ns))] 37 | (name class-sym)))) 38 | 39 | (defn potential-dot 40 | "Returns a list of potential dot method name completions for a given 41 | namespace" 42 | ([] (potential-dot *ns*)) 43 | ([ns] 44 | (map #(str "." %) (set (map member-name (mapcat instance-methods (vals (ns-imports ns)))))))) 45 | 46 | (defn potential-static 47 | "Returns a list of potential static members for a given namespace" 48 | ([#^Class class] 49 | (concat (map member-name (static-methods class)) 50 | (map member-name (static-fields class))))) 51 | 52 | 53 | (defn potential-classes-on-path 54 | "Returns a list of Java class and Clojure package names found on the current 55 | classpath. To minimize noise, list is nil unless a '.' is present in the search 56 | string, and nested classes are only shown if a '$' is present." 57 | ([#^String symbol-string] 58 | (when (.contains symbol-string ".") 59 | (if (.contains symbol-string "$") 60 | @nested-classes 61 | @top-level-classes)))) 62 | 63 | (defn resolve-class 64 | "Attempts to resolve a symbol into a java Class. Returns nil on 65 | failure." 66 | ([sym] 67 | (try 68 | (let [res (resolve sym)] 69 | (when (class? res) 70 | res)) 71 | (catch Throwable t 72 | nil)))) 73 | 74 | 75 | (defn- maybe-alias [sym ns] 76 | (or (resolve-ns sym (maybe-ns ns)) 77 | (maybe-ns ns))) 78 | 79 | (defn potential-completions [symbol-ns ns] 80 | (if symbol-ns 81 | (map #(str symbol-ns "/" %) 82 | (if-let [class (resolve-class symbol-ns)] 83 | (potential-static class) 84 | (potential-var-public (maybe-alias symbol-ns ns)))) 85 | (concat (potential-var ns) 86 | (when-not symbol-ns 87 | (potential-ns)) 88 | (potential-classes ns) 89 | (potential-dot ns)))) 90 | 91 | 92 | (defslimefn simple-completions [symbol-string package] 93 | (try 94 | (let [[sym-ns sym-name] (symbol-name-parts symbol-string) 95 | potential (concat (potential-completions (when sym-ns (symbol sym-ns)) (ns-name (maybe-ns package))) 96 | (potential-classes-on-path symbol-string)) 97 | matches (seq (sort (filter #(.startsWith #^String % symbol-string) potential)))] 98 | (list matches 99 | (if matches 100 | (reduce largest-common-prefix matches) 101 | symbol-string))) 102 | (catch java.lang.Throwable t 103 | (list nil symbol-string)))) 104 | -------------------------------------------------------------------------------- /src/swank/commands/contrib.clj: -------------------------------------------------------------------------------- 1 | (ns swank.commands.contrib 2 | (:use (swank util core commands))) 3 | 4 | (defslimefn swank-require [keys] 5 | (binding [*ns* (find-ns 'swank.commands.contrib)] 6 | (doseq [k (if (seq? keys) keys (list keys))] 7 | (try 8 | (require (symbol (str "swank.commands.contrib." (name k)))) 9 | (catch java.io.FileNotFoundException fne nil))))) -------------------------------------------------------------------------------- /src/swank/commands/contrib/swank_arglists.clj: -------------------------------------------------------------------------------- 1 | (ns swank.commands.contrib.swank-arglists 2 | (:use (swank util core commands))) 3 | 4 | ((slime-fn 'swank-require) :swank-c-p-c) 5 | 6 | ;;; pos starts at 1 bc 0 is function name 7 | (defn position-in-arglist? [arglist pos] 8 | (or (some #(= '& %) arglist) 9 | (<= pos (count arglist)))) 10 | 11 | ;; (position-in-arglist? '[x y] 2) 12 | ;; => true 13 | 14 | (defn highlight-position [arglist pos] 15 | (if (zero? pos) 16 | arglist 17 | ;; i.e. not rest args 18 | (let [num-normal-args (count (take-while #(not= % '&) arglist))] 19 | (if (<= pos num-normal-args) 20 | (into [] (concat (take (dec pos) arglist) 21 | '(===>) 22 | (list (nth arglist (dec pos))) 23 | '(<===) 24 | (drop pos arglist))) 25 | (let [rest-arg? (some #(= % '&) arglist)] 26 | (if rest-arg? 27 | (into [] (concat (take-while #(not= % '&) arglist) 28 | '(===>) 29 | '(&) 30 | (list (last arglist)) 31 | '(<===))))))))) 32 | 33 | ;; (highlight-position '[x y] 0) 34 | ;; => [===> x <=== y] 35 | 36 | (defn highlight-arglists [arglists pos] 37 | (let [arglists (read-string arglists)] 38 | (loop [checked [] 39 | current (first arglists) 40 | remaining (rest arglists)] 41 | (if (position-in-arglist? current pos) 42 | (apply list (concat checked 43 | [(highlight-position current pos)] 44 | remaining)) 45 | (when (seq remaining) 46 | (recur (conj checked current) 47 | (first remaining) 48 | (rest remaining))))))) 49 | 50 | ;; (highlight-arglists "([x] [x & more])" 1) 51 | ;; => ([===> x <===] [x & more]) 52 | 53 | ;;(defmacro dbg[x] `(let [x# ~x] (println '~x "->" x#) x#)) 54 | 55 | (defn defnk-arglists? [arglists] 56 | (and (not (nil? arglists )) 57 | (not (vector? (first (read-string arglists)))))) 58 | 59 | (defn fix-defnk-arglists [arglists] 60 | (str (list (into [] (read-string arglists))))) 61 | 62 | (defn arglists-for-fname-lookup [fname] 63 | ((slime-fn 'operator-arglist) fname *current-package*)) 64 | 65 | (defn arglists-for-fname [fname] 66 | (let [arglists (arglists-for-fname-lookup fname)] 67 | ;; defnk's arglists format is (a b) instead of ([a b]) 68 | (if (defnk-arglists? arglists) 69 | (fix-defnk-arglists arglists) 70 | arglists))) 71 | 72 | (defn message-format [cmd arglists pos] 73 | (str (when cmd (str cmd ": ")) 74 | (when arglists 75 | (if pos 76 | (highlight-arglists arglists pos) 77 | arglists)))) 78 | 79 | (defn handle-apply [raw-specs pos] 80 | (let [fname (second (first raw-specs))] 81 | (message-format fname (arglists-for-fname fname) (dec pos)))) 82 | 83 | (defslimefn arglist-for-echo-area [raw-specs & options] 84 | (let [{:keys [arg-indices 85 | print-right-margin 86 | print-lines]} (apply hash-map options)] 87 | (if-not (and raw-specs 88 | (seq? raw-specs) 89 | (seq? (first raw-specs))) 90 | nil ;; problem? 91 | (let [pos (first (second options)) 92 | top-level? (= 1 (count raw-specs)) 93 | parent-pos (when-not top-level? 94 | (second (second options))) 95 | fname (ffirst raw-specs) 96 | parent-fname (when-not top-level? 97 | (first (second raw-specs))) 98 | arglists (arglists-for-fname fname) 99 | inside-binding? (and (not top-level?) 100 | (#{"let" "binding" "doseq" "for" "loop"} 101 | parent-fname) 102 | (= 1 parent-pos))] 103 | ;; (dbg raw-specs) 104 | ;; (dbg options) 105 | (cond 106 | ;; display arglists for function being applied unless on top of apply 107 | (and (= fname "apply") (not= pos 0)) (handle-apply raw-specs pos) 108 | ;; highlight binding inside binding forms unless >1 level deep 109 | inside-binding? (message-format parent-fname 110 | (arglists-for-fname parent-fname) 111 | 1) 112 | :else (message-format fname arglists pos)))))) 113 | 114 | (defslimefn variable-desc-for-echo-area [variable-name] 115 | (with-emacs-package 116 | (or 117 | (try 118 | (when-let [sym (read-string variable-name)] 119 | (when-let [var (resolve sym)] 120 | (when (.isBound #^clojure.lang.Var var) 121 | (str variable-name " => " (var-get var))))) 122 | (catch Exception e nil)) 123 | ""))) 124 | -------------------------------------------------------------------------------- /src/swank/commands/contrib/swank_c_p_c.clj: -------------------------------------------------------------------------------- 1 | (ns swank.commands.contrib.swank-c-p-c 2 | (:use (swank util core commands) 3 | (swank.commands completion) 4 | (swank.util string clojure) 5 | (swank.commands.contrib.swank-c-p-c internal))) 6 | 7 | (defslimefn completions [symbol-string package] 8 | (try 9 | (let [[sym-ns sym-name] (symbol-name-parts symbol-string) 10 | potential (concat 11 | (potential-completions 12 | (when sym-ns (symbol sym-ns)) 13 | (ns-name (maybe-ns package))) 14 | (potential-classes-on-path symbol-string)) 15 | matches (seq (sort (filter #(split-compound-prefix-match? symbol-string %) potential)))] 16 | (list matches 17 | (if matches 18 | (reduce largest-common-prefix matches) 19 | symbol-string))) 20 | (catch java.lang.Throwable t 21 | (list nil symbol-string)))) 22 | -------------------------------------------------------------------------------- /src/swank/commands/contrib/swank_c_p_c/internal.clj: -------------------------------------------------------------------------------- 1 | (ns swank.commands.contrib.swank-c-p-c.internal 2 | (:use (swank util core commands) 3 | (swank.commands completion) 4 | (swank.util string clojure))) 5 | 6 | (defn compound-prefix-match? 7 | "Takes a `prefix' and a `target' string and returns whether `prefix' 8 | is a compound-prefix of `target'. 9 | 10 | Viewing each of `prefix' and `target' as a series of substrings 11 | split by `split', if each substring of `prefix' is a prefix of the 12 | corresponding substring in `target' then we call `prefix' a 13 | compound-prefix of `target'." 14 | ([split #^String prefix #^String target] 15 | (let [prefixes (split prefix) 16 | targets (split target)] 17 | (when (<= (count prefixes) (count targets)) 18 | (every? true? (map #(.startsWith #^String %1 %2) targets prefixes)))))) 19 | 20 | (defn unacronym 21 | "Interposes delimiter between each character of string." 22 | ([delimiter #^String string] 23 | (apply str (interpose delimiter string))) 24 | {:tag String}) 25 | 26 | (defn delimited-compound-prefix-match? 27 | "Uses a delimiter as the `split' for a compound prefix match check. 28 | See also: `compound-prefix-match?'" 29 | ([delimiter prefix target] 30 | (compound-prefix-match? #(.split #^String % (str "[" (java.util.regex.Pattern/quote delimiter) "]") -1) 31 | prefix 32 | target))) 33 | 34 | 35 | (defn delimited-compound-prefix-match-acronym? 36 | ([delimiter prefix target] 37 | (or (delimited-compound-prefix-match? delimiter prefix target) 38 | (delimited-compound-prefix-match? delimiter (unacronym (first delimiter) prefix) target)))) 39 | 40 | (defn camel-compound-prefix-match? 41 | "Uses camel case as a delimiter for a compound prefix match check. 42 | 43 | See also: `compound-prefix-match?'" 44 | ([#^String prefix #^String target] 45 | (compound-prefix-match? #(re-seq #"(?:^.|[A-Z])[^A-Z]*" %) 46 | prefix 47 | target))) 48 | 49 | (defn split-compound-prefix-match? [#^String symbol-string #^String potential] 50 | (if (.startsWith symbol-string ".") 51 | (and (.startsWith potential ".") 52 | (camel-compound-prefix-match? symbol-string potential)) 53 | (let [[sym-ns sym-name] (symbol-name-parts symbol-string) 54 | [pot-ns pot-name] (symbol-name-parts potential)] 55 | (and (or (= sym-ns pot-ns) 56 | (and sym-ns pot-ns 57 | (delimited-compound-prefix-match-acronym? "." sym-ns pot-ns))) 58 | (or (delimited-compound-prefix-match-acronym? "-." sym-name pot-name) 59 | (camel-compound-prefix-match? sym-name pot-name)))))) 60 | -------------------------------------------------------------------------------- /src/swank/commands/contrib/swank_fuzzy.clj: -------------------------------------------------------------------------------- 1 | ;;; swank_fuzzy.clj --- fuzzy symbol completion, Clojure implementation. 2 | 3 | ;; Original CL implementation authors (from swank-fuzzy.lisp) below, 4 | ;; Authors: Brian Downing 5 | ;; Tobias C. Rittweiler 6 | ;; and others 7 | 8 | ;; This progam is based on the swank-fuzzy.lisp. 9 | ;; Thanks the CL implementation authors for that useful software. 10 | 11 | (ns swank.commands.contrib.swank-fuzzy 12 | (:use (swank util core commands)) 13 | (:use (swank.util clojure))) 14 | 15 | (def #^{:dynamic true} *fuzzy-recursion-soft-limit* 30) 16 | (defn- compute-most-completions [short full] 17 | (let [collect-chunk (fn [[pcur [[pa va] ys]] [pb vb]] 18 | (let [xs (if (= (dec pb) pcur) 19 | [[pa (str va vb)]] 20 | [[pb vb] [pa va]])] 21 | [pb (if ys (conj xs ys) xs)])) 22 | step (fn step [short full pos chunk seed limit?] 23 | (cond 24 | (and (empty? full) (not (empty? short))) 25 | nil 26 | (or (empty? short) limit?) 27 | (if chunk 28 | (conj seed 29 | (second (reduce collect-chunk 30 | [(ffirst chunk) [(first chunk)]] 31 | (rest chunk)))) 32 | seed) 33 | (= (first short) (first full)) 34 | (let [seed2 35 | (step short (rest full) (inc pos) chunk seed 36 | (< *fuzzy-recursion-soft-limit* (count seed)))] 37 | (recur (rest short) (rest full) (inc pos) 38 | (conj chunk [pos (str (first short))]) 39 | (if (and seed2 (not (empty? seed2))) 40 | seed2 41 | seed) 42 | false)) 43 | :else 44 | (recur short (rest full) (inc pos) chunk seed false)))] 45 | (map reverse (step short full 0 [] () false)))) 46 | 47 | (def fuzzy-completion-symbol-prefixes "*+-%&?<") 48 | (def fuzzy-completion-word-separators "-/.") 49 | (def fuzzy-completion-symbol-suffixes "*+->?!") 50 | (defn- score-completion [completion short full] 51 | (let [find1 52 | (fn [c s] 53 | (re-find (re-pattern (java.util.regex.Pattern/quote (str c))) s)) 54 | at-beginning? zero? 55 | after-prefix? 56 | (fn [pos] 57 | (and (= pos 1) 58 | (find1 (nth full 0) fuzzy-completion-symbol-prefixes))) 59 | word-separator? 60 | (fn [pos] 61 | (find1 (nth full pos) fuzzy-completion-word-separators)) 62 | after-word-separator? 63 | (fn [pos] 64 | (find1 (nth full (dec pos)) fuzzy-completion-word-separators)) 65 | at-end? 66 | (fn [pos] 67 | (= pos (dec (count full)))) 68 | before-suffix? 69 | (fn [pos] 70 | (and (= pos (- (count full) 2)) 71 | (find1 (nth full (dec (count full))) 72 | fuzzy-completion-symbol-suffixes)))] 73 | (letfn [(score-or-percentage-of-previous 74 | [base-score pos chunk-pos] 75 | (if (zero? chunk-pos) 76 | base-score 77 | (max base-score 78 | (+ (* (score-char (dec pos) (dec chunk-pos)) 0.85) 79 | (Math/pow 1.2 chunk-pos))))) 80 | (score-char 81 | [pos chunk-pos] 82 | (score-or-percentage-of-previous 83 | (cond (at-beginning? pos) 10 84 | (after-prefix? pos) 10 85 | (word-separator? pos) 1 86 | (after-word-separator? pos) 8 87 | (at-end? pos) 6 88 | (before-suffix? pos) 6 89 | :else 1) 90 | pos chunk-pos)) 91 | (score-chunk 92 | [chunk] 93 | (let [chunk-len (count (second chunk))] 94 | (apply + 95 | (map score-char 96 | (take chunk-len (iterate inc (first chunk))) 97 | (reverse (take chunk-len 98 | (iterate dec (dec chunk-len))))))))] 99 | (let [chunk-scores (map score-chunk completion) 100 | length-score (/ 10.0 (inc (- (count full) (count short))))] 101 | [(+ (apply + chunk-scores) length-score) 102 | (list (map list chunk-scores completion) length-score)])))) 103 | 104 | (defn- compute-highest-scoring-completion [short full] 105 | (let [scored-results 106 | (map (fn [result] 107 | [(first (score-completion result short full)) 108 | result]) 109 | (compute-most-completions short full)) 110 | winner (first (sort (fn [[av _] [bv _]] (> av bv)) 111 | scored-results))] 112 | [(second winner) (first winner)])) 113 | 114 | (defn- call-with-timeout [time-limit-in-msec proc] 115 | "Create a thunk that returns true if given time-limit-in-msec has been 116 | elapsed and calls proc with the thunk as an argument. Returns a 3 elements 117 | vec: A proc result, given time-limit-in-msec has been elapsed or not, 118 | elapsed time in millisecond." 119 | (let [timed-out (atom false) 120 | start! (fn [] 121 | (future (do 122 | (Thread/sleep time-limit-in-msec) 123 | (swap! timed-out (constantly true))))) 124 | timed-out? (fn [] @timed-out) 125 | started-at (System/nanoTime)] 126 | (start!) 127 | [(proc timed-out?) 128 | @timed-out 129 | (/ (double (- (System/nanoTime) started-at)) 1000000.0)])) 130 | 131 | (defmacro with-timeout 132 | "Create a thunk that returns true if given time-limit-in-msec has been 133 | elapsed and bind it to timed-out?. Then execute body." 134 | #^{:private true} 135 | [[timed-out? time-limit-in-msec] & body] 136 | `(call-with-timeout ~time-limit-in-msec (fn [~timed-out?] ~@body))) 137 | 138 | (defstruct fuzzy-matching 139 | :var :ns :symbol :ns-name :score :ns-chunks :var-chunks) 140 | 141 | (defn- fuzzy-extract-matching-info [matching string] 142 | (let [[user-ns-name _] (symbol-name-parts string)] 143 | (cond 144 | (:var matching) 145 | [(str (:symbol matching)) 146 | (cond (nil? user-ns-name) nil 147 | :else (:ns-name matching))] 148 | :else 149 | ["" 150 | (str (:symbol matching))]))) 151 | 152 | (defn- fuzzy-find-matching-vars 153 | [string ns var-filter external-only?] 154 | (let [compute (partial compute-highest-scoring-completion string) 155 | ns-maps (cond 156 | external-only? ns-publics 157 | (= ns *ns*) ns-map 158 | :else ns-interns)] 159 | (map (fn [[match-result score var sym]] 160 | (if (var? var) 161 | (struct fuzzy-matching 162 | var nil (or (:name (meta var)) 163 | (symbol (pr-str var))) 164 | nil 165 | score nil match-result) 166 | (struct fuzzy-matching 167 | nil nil sym 168 | nil 169 | score nil match-result))) 170 | (filter (fn [[match-result & _]] 171 | (or (= string "") 172 | (not-empty match-result))) 173 | (map (fn [[k v]] 174 | (if (= string "") 175 | (conj [nil 0.0] v k) 176 | (conj (compute (.toLowerCase (str k))) v k))) 177 | (filter var-filter (seq (ns-maps ns)))))))) 178 | (defn- fuzzy-find-matching-nss 179 | [string] 180 | (let [compute (partial compute-highest-scoring-completion string)] 181 | (map (fn [[match-result score ns ns-sym]] 182 | (struct fuzzy-matching nil ns ns-sym (str ns-sym) 183 | score match-result nil)) 184 | (filter (fn [[match-result & _]] (not-empty match-result)) 185 | (map (fn [[ns-sym ns]] 186 | (conj (compute (str ns-sym)) ns ns-sym)) 187 | (concat 188 | (map (fn [ns] [(symbol (str ns)) ns]) (all-ns)) 189 | (ns-aliases *ns*))))))) 190 | 191 | (defn- fuzzy-generate-matchings 192 | [string default-ns timed-out?] 193 | (let [take* (partial take-while (fn [_] (not (timed-out?)))) 194 | [parsed-ns-name parsed-symbol-name] (symbol-name-parts string) 195 | find-vars 196 | (fn find-vars 197 | ([designator ns] 198 | (find-vars designator ns identity)) 199 | ([designator ns var-filter] 200 | (find-vars designator ns var-filter nil)) 201 | ([designator ns var-filter external-only?] 202 | (take* (fuzzy-find-matching-vars designator 203 | ns 204 | var-filter 205 | external-only?)))) 206 | find-nss (comp take* fuzzy-find-matching-nss) 207 | make-duplicate-var-filter 208 | (fn [fuzzy-ns-matchings] 209 | (let [nss (set (map :ns-name fuzzy-ns-matchings))] 210 | (comp not nss str :ns meta second))) 211 | matching-greater 212 | (fn [a b] 213 | (cond 214 | (> (:score a) (:score b)) -1 215 | (< (:score a) (:score b)) 1 216 | :else (compare (:symbol a) (:symbol b)))) 217 | fix-up 218 | (fn [matchings parent-package-matching] 219 | (map (fn [m] 220 | (assoc m 221 | :ns-name (:ns-name parent-package-matching) 222 | :ns-chunks (:ns-chunks parent-package-matching) 223 | :score (if (= parsed-ns-name "") 224 | (/ (:score parent-package-matching) 100) 225 | (+ (:score parent-package-matching) 226 | (:score m))))) 227 | matchings))] 228 | (sort matching-greater 229 | (cond 230 | (nil? parsed-ns-name) 231 | (concat 232 | (find-vars parsed-symbol-name (maybe-ns default-ns)) 233 | (find-nss parsed-symbol-name)) 234 | ;; (apply concat 235 | ;; (let [ns *ns*] 236 | ;; (pcalls #(binding [*ns* ns] 237 | ;; (find-vars parsed-symbol-name 238 | ;; (maybe-ns default-ns))) 239 | ;; #(binding [*ns* ns] 240 | ;; (find-nss parsed-symbol-name))))) 241 | (= "" parsed-ns-name) 242 | (find-vars parsed-symbol-name (maybe-ns default-ns)) 243 | :else 244 | (let [found-nss (find-nss parsed-ns-name) 245 | find-vars1 (fn [ns-matching] 246 | (fix-up 247 | (find-vars parsed-symbol-name 248 | (:ns ns-matching) 249 | (make-duplicate-var-filter 250 | (filter (partial = ns-matching) 251 | found-nss)) 252 | true) 253 | ns-matching))] 254 | (concat 255 | (apply concat 256 | (map find-vars1 (sort matching-greater found-nss))) 257 | found-nss)))))) 258 | 259 | (defn- fuzzy-format-matching [string matching] 260 | (let [[symbol package] (fuzzy-extract-matching-info matching string) 261 | result (str package (when package "/") symbol)] 262 | [result (.indexOf #^String result #^String symbol)])) 263 | 264 | (defn- classify-matching [m] 265 | (let [make-var-meta (fn [m] 266 | (fn [key] 267 | (when-let [var (:var m)] 268 | (when-let [var-meta (meta var)] 269 | (get var-meta key))))) 270 | vm (make-var-meta m)] 271 | (set 272 | (filter 273 | identity 274 | [(when-not (or (vm :macro) (vm :arglists)) 275 | :boundp) 276 | (when (vm :arglists) :fboundp) 277 | ;; (:typespec) 278 | ;; (:class) 279 | (when (vm :macro) :macro) 280 | (when (special-symbol? (:symbol m)) :special-operator) 281 | (when (:ns-name m) :package) 282 | (when (= clojure.lang.MultiFn (vm :tag)) 283 | :generic-function)])))) 284 | (defn- classification->string [flags] 285 | (format (apply str (replicate 8 "%s")) 286 | (if (or (:boundp flags) 287 | (:constant flags)) "b" "-") 288 | (if (:fboundp flags) "f" "-") 289 | (if (:generic-function flags) "g" "-") 290 | (if (:class flags) "c" "-") 291 | (if (:typespec flags) "t" "-") 292 | (if (:macro flags) "m" "-") 293 | (if (:special-operator flags) "s" "-") 294 | (if (:package flags) "p" "-"))) 295 | 296 | (defn- fuzzy-convert-matching-for-emacs [string matching] 297 | (let [[name added-length] (fuzzy-format-matching string matching)] 298 | [name 299 | (format "%.2f" (:score matching)) 300 | (concat (:ns-chunks matching) 301 | (map (fn [[offset string]] [(+ added-length offset) string]) 302 | (:var-chunks matching))) 303 | (classification->string (classify-matching matching)) 304 | ])) 305 | 306 | (defn- fuzzy-completion-set 307 | [string default-ns limit time-limit-in-msec] 308 | (let [[matchings interrupted? _] 309 | (with-timeout [timed-out? time-limit-in-msec] 310 | (vec (fuzzy-generate-matchings string default-ns timed-out?))) 311 | subvec1 (if (and limit 312 | (> limit 0) 313 | (< limit (count matchings))) 314 | (fn [v] (subvec v 0 limit)) 315 | identity)] 316 | [(subvec1 (vec (map (partial fuzzy-convert-matching-for-emacs string) 317 | matchings))) 318 | interrupted?])) 319 | 320 | (defslimefn fuzzy-completions 321 | [string default-package-name 322 | _limit limit _time-limit-in-msec time-limit-in-msec] 323 | (let [[xs x] (fuzzy-completion-set string default-package-name 324 | limit time-limit-in-msec)] 325 | (list 326 | (map (fn [[symbol score chunks class]] 327 | (list symbol score (map (partial apply list) chunks) class)) 328 | xs) 329 | (when x 't)))) 330 | 331 | (defslimefn fuzzy-completion-selected [_ _] nil) 332 | 333 | (comment 334 | (do 335 | (use '[clojure.test]) 336 | 337 | (is (= '(([0 "m"] [9 "v"] [15 "b"])) 338 | (compute-most-completions "mvb" "multiple-value-bind"))) 339 | (is (= '(([0 "zz"]) ([0 "z"] [2 "z"]) ([1 "zz"])) 340 | (compute-most-completions "zz" "zzz"))) 341 | (is (= 103 342 | (binding [*fuzzy-recursion-soft-limit* 2] 343 | (count 344 | (compute-most-completions "ZZZZZZ" "ZZZZZZZZZZZZZZZZZZZZZZZ"))))) 345 | 346 | (are [x p s] (= x (score-completion [[p s]] s "*multiple-value+")) 347 | '[10.625 (((10 [0 "*"])) 0.625)] 0 "*" ;; at-beginning 348 | '[10.625 (((10 [1 "m"])) 0.625)] 1 "m" ;; after-prefix 349 | '[1.625 (((1 [9 "-"])) 0.625)] 9 "-" ;; word-sep 350 | '[8.625 (((8 [10 "v"])) 0.625)] 10 "v" ;; after-word-sep 351 | '[6.625 (((6 [15 "+"])) 0.625)] 15 "+" ;; at-end 352 | '[6.625 (((6 [14 "e"])) 0.625)] 14 "e" ;; before-suffix 353 | '[1.625 (((1 [2 "u"])) 0.625)] 2 "u" ;; other 354 | ) 355 | (is (= (+ 10 ;; m's score 356 | (+ (* 10 0.85) (Math/pow 1.2 1))) ;; u's score 357 | (let [[_ x] 358 | (score-completion [[1 "mu"]] "mu" "*multiple-value+")] 359 | ((comp first ffirst) x))) 360 | "`m''s score + `u''s score (percentage of previous which is 'm''s)") 361 | 362 | (is (= '[([0 "zz"]) 24.7] 363 | (compute-highest-scoring-completion "zz" "zzz"))) 364 | 365 | (are [to? ret to proc] (= [ret to?] 366 | (let [[x y _] (call-with-timeout to proc)] 367 | [x y])) 368 | false "r" 10 (fn [_] "r") 369 | true nil 1 (fn [_] (Thread/sleep 10) nil)) 370 | 371 | (are [symbol package input] (= [symbol package] 372 | (fuzzy-extract-matching-info 373 | (struct fuzzy-matching 374 | true nil 375 | "symbol" "ns-name" 376 | nil nil nil) 377 | input)) 378 | "symbol" "ns-name" "p/*" 379 | "symbol" nil "*") 380 | (is (= ["" "ns-name"] 381 | (fuzzy-extract-matching-info 382 | (struct fuzzy-matching 383 | nil nil 384 | "ns-name" "" 385 | nil nil nil) 386 | ""))) 387 | 388 | (defmacro try! #^{:private true} 389 | [& body] 390 | `(do 391 | ~@(map (fn [x] `(try ~x (catch Throwable ~'_ nil))) 392 | body))) 393 | 394 | (try 395 | (def testing-testing0 't) 396 | (def #^{:private true} testing-testing1 't) 397 | (are [x external-only?] (= x 398 | (vec 399 | (sort 400 | (map (comp str :symbol) 401 | (fuzzy-find-matching-vars 402 | "testing" *ns* 403 | (fn [[k v]] 404 | (and (= ((comp :ns meta) v) *ns*) 405 | (re-find #"^testing-" 406 | (str k)))) 407 | external-only?))))) 408 | ["testing-testing0" "testing-testing1"] nil 409 | ["testing-testing0"] true) 410 | (finally 411 | (try! 412 | (ns-unmap *ns* 'testing-testing0) 413 | (ns-unmap *ns* 'testing-testing1)))) 414 | 415 | (try 416 | (create-ns 'testing-testing0) 417 | (create-ns 'testing-testing1) 418 | (is (= '["testing-testing0" "testing-testing1"] 419 | (vec 420 | (sort 421 | (map (comp str :symbol) 422 | (fuzzy-find-matching-nss "testing-")))))) 423 | (finally 424 | (try! 425 | (remove-ns 'testing-testing0) 426 | (remove-ns 'testing-testing1)))) 427 | ) 428 | ) 429 | -------------------------------------------------------------------------------- /src/swank/commands/indent.clj: -------------------------------------------------------------------------------- 1 | (ns swank.commands.indent 2 | (:use (swank util core) 3 | (swank.core hooks connection) 4 | (swank.util hooks))) 5 | 6 | (defn- need-full-indentation-update? 7 | "Return true if the indentation cache should be updated for all 8 | namespaces. 9 | 10 | This is a heuristic so as to avoid scanning all symbols from all 11 | namespaces. Instead, we only check whether the set of namespaces in 12 | the cache match the set of currently defined namespaces." 13 | ([connection] 14 | (not= (hash (all-ns)) 15 | (hash @(connection :indent-cache-pkg))))) 16 | 17 | (defn- find-args-body-position 18 | "Given an arglist, return the number of arguments before 19 | [... & body] 20 | If no & body is found, nil will be returned" 21 | ([args] 22 | (when (coll? args) 23 | (when-let [amp-position (position '#{&} args)] 24 | (when-let [body-position (position '#{body clauses} args)] 25 | (when (= (inc amp-position) body-position) 26 | amp-position)))))) 27 | 28 | (defn- find-arglists-body-position 29 | "Find the smallest body position from an arglist" 30 | ([arglists] 31 | (let [positions (remove nil? (map find-args-body-position arglists))] 32 | (when-not (empty? positions) 33 | (apply min positions))))) 34 | 35 | (defn- find-var-body-position 36 | "Returns a var's :indent override or the smallest body position of a 37 | var's arglists" 38 | ([var] 39 | (let [var-meta (meta var)] 40 | (or (:indent var-meta) 41 | (find-arglists-body-position (:arglists var-meta)))))) 42 | 43 | (defn- var-indent-representation 44 | "Returns the slime indentation representation (name . position) for 45 | a given var. If there is no indentation representation, nil is 46 | returned." 47 | ([var] 48 | (when-let [body-position (find-var-body-position var)] 49 | (when (or (= body-position 'defun) 50 | (not (neg? body-position))) 51 | (list (name (:name (meta var))) 52 | '. 53 | body-position))))) 54 | 55 | (defn- get-cache-update-for-var 56 | "Checks whether a given var needs to be updated in a cache. If it 57 | needs updating, return [var-name var-indentation-representation]. 58 | Otherwise return nil" 59 | ([find-in-cache var] 60 | (when-let [indent (var-indent-representation var)] 61 | (let [name (:name (meta var))] 62 | (when-not (= (find-in-cache name) indent) 63 | [name indent]))))) 64 | 65 | (defn- get-cache-updates-in-namespace 66 | "Finds all cache updates needed within a namespace" 67 | ([find-in-cache ns] 68 | (remove nil? (map (partial get-cache-update-for-var find-in-cache) (vals (ns-interns ns)))))) 69 | 70 | (defn- update-indentation-delta 71 | "Update the cache and return the changes in a (symbol '. indent) list. 72 | If FORCE is true then check all symbols, otherwise only check 73 | symbols belonging to the buffer package" 74 | ([cache-ref load-all-ns?] 75 | (let [find-in-cache @cache-ref] 76 | (let [namespaces (if load-all-ns? (all-ns) [(maybe-ns *current-package*)]) 77 | updates (mapcat (partial get-cache-updates-in-namespace find-in-cache) namespaces)] 78 | (when (seq updates) 79 | (dosync (alter cache-ref into updates)) 80 | (map second updates)))))) 81 | 82 | (defn- perform-indentation-update 83 | "Update the indentation cache in connection and update emacs. 84 | If force is true, then start again without considering the old cache." 85 | ([conn force] 86 | (let [cache (conn :indent-cache)] 87 | (let [delta (update-indentation-delta cache force)] 88 | (dosync 89 | (ref-set (conn :indent-cache-pkg) (hash (all-ns))) 90 | (when (seq delta) 91 | (send-to-emacs `(:indentation-update ~delta)))))))) 92 | 93 | (defn- sync-indentation-to-emacs 94 | "Send any indentation updates to Emacs via emacs-connection" 95 | ([] 96 | (perform-indentation-update 97 | *current-connection* 98 | (need-full-indentation-update? *current-connection*)))) 99 | 100 | (add-hook pre-reply-hook #'sync-indentation-to-emacs) 101 | -------------------------------------------------------------------------------- /src/swank/commands/inspector.clj: -------------------------------------------------------------------------------- 1 | (ns swank.commands.inspector 2 | (:use (swank util core commands) 3 | (swank.core connection)) 4 | (:import (java.lang.reflect Field))) 5 | 6 | ;;;; Inspector for basic clojure data structures 7 | 8 | ;; This a mess, I'll clean up this code after I figure out exactly 9 | ;; what I need for debugging support. 10 | 11 | (def inspectee (ref nil)) 12 | (def inspectee-content (ref nil)) 13 | (def inspectee-parts (ref nil)) 14 | (def inspectee-actions (ref nil)) 15 | (def inspector-stack (ref nil)) 16 | (def inspector-history (ref nil)) 17 | 18 | (defn reset-inspector [] 19 | (dosync 20 | (ref-set inspectee nil) 21 | (ref-set inspectee-content nil) 22 | (ref-set inspectee-parts []) 23 | (ref-set inspectee-actions []) 24 | (ref-set inspector-stack nil) 25 | (ref-set inspector-history []))) 26 | 27 | (defn indexed-values [obj] 28 | (apply concat 29 | (map-indexed (fn [idx val] 30 | `(~(str " " idx ". ") (:value ~val) (:newline))) 31 | obj))) 32 | 33 | (defn named-values [obj] 34 | (apply concat 35 | (for [[key val] obj] 36 | `(" " (:value ~key) " = " (:value ~val) (:newline))))) 37 | 38 | (defn inspectee-title [obj] 39 | (cond 40 | (instance? clojure.lang.LazySeq obj) (str "clojure.lang.LazySeq@...") 41 | :else (str obj))) 42 | 43 | (defn print-part-to-string [value] 44 | (let [s (inspectee-title value) 45 | pos (position #{value} @inspector-history)] 46 | (if pos 47 | (str "#" pos "=" s) 48 | s))) 49 | 50 | (defn assign-index [o dest] 51 | (dosync 52 | (let [index (count @dest)] 53 | (alter dest conj o) 54 | index))) 55 | 56 | (defn value-part [obj s] 57 | (list :value (or s (print-part-to-string obj)) 58 | (assign-index obj inspectee-parts))) 59 | 60 | (defn action-part [label lambda refresh?] 61 | (list :action label 62 | (assign-index (list lambda refresh?) 63 | inspectee-actions))) 64 | 65 | (defn label-value-line 66 | ([label value] (label-value-line label value true)) 67 | ([label value newline?] 68 | (list* (str label) ": " (list :value value) 69 | (if newline? '((:newline)) nil)))) 70 | 71 | (defmacro label-value-line* [& label-values] 72 | `(concat ~@(map (fn [[label value]] 73 | `(label-value-line ~label ~value)) 74 | label-values))) 75 | 76 | ;; Inspection 77 | 78 | ;; This is the simple version that only knows about clojure stuff. 79 | ;; Many of these will probably be redefined by swank-clojure-debug 80 | (defmulti emacs-inspect 81 | (fn known-types [obj] 82 | (cond 83 | (map? obj) :map 84 | (vector? obj) :vector 85 | (var? obj) :var 86 | (string? obj) :string 87 | (seq? obj) :seq 88 | (instance? Class obj) :class 89 | (instance? clojure.lang.Namespace obj) :namespace 90 | (instance? clojure.lang.ARef obj) :aref 91 | (.isArray (class obj)) :array))) 92 | 93 | (defn inspect-meta-information [obj] 94 | (when (seq (meta obj)) 95 | (concat 96 | '("Meta Information: " (:newline)) 97 | (named-values (meta obj))))) 98 | 99 | (defmethod emacs-inspect :map [obj] 100 | (concat 101 | (label-value-line* 102 | ("Class" (class obj)) 103 | ("Count" (count obj))) 104 | (inspect-meta-information obj) 105 | '("Contents: " (:newline)) 106 | (named-values obj))) 107 | 108 | (defmethod emacs-inspect :vector [obj] 109 | (concat 110 | (label-value-line* 111 | ("Class" (class obj)) 112 | ("Count" (count obj))) 113 | (inspect-meta-information obj) 114 | '("Contents: " (:newline)) 115 | (indexed-values obj))) 116 | 117 | (defmethod emacs-inspect :array [#^"[Ljava.lang.Object;" obj] 118 | (concat 119 | (label-value-line* 120 | ("Class" (class obj)) 121 | ("Count" (alength obj)) 122 | ("Component Type" (.getComponentType (class obj)))) 123 | '("Contents: " (:newline)) 124 | (indexed-values obj))) 125 | 126 | (defmethod emacs-inspect :var [#^clojure.lang.Var obj] 127 | (concat 128 | (label-value-line* 129 | ("Class" (class obj))) 130 | (inspect-meta-information obj) 131 | (when (.isBound obj) 132 | `("Value: " (:value ~(var-get obj)))))) 133 | 134 | (defmethod emacs-inspect :string [obj] 135 | (concat 136 | (label-value-line* 137 | ("Class" (class obj))) 138 | (list (str "Value: " (pr-str obj))))) 139 | 140 | (defmethod emacs-inspect :seq [obj] 141 | (concat 142 | (label-value-line* 143 | ("Class" (class obj))) 144 | (inspect-meta-information obj) 145 | '("Contents: " (:newline)) 146 | (indexed-values obj))) 147 | 148 | 149 | (defmethod emacs-inspect :default [obj] 150 | (let [#^"[Ljava.lang.reflect.Field;" fields (. (class obj) getDeclaredFields) 151 | names (map #(.getName #^Field %) fields) 152 | get (fn [#^Field f] 153 | (try (.setAccessible f true) 154 | (catch java.lang.SecurityException e)) 155 | (try (.get f obj) 156 | (catch java.lang.IllegalAccessException e 157 | "Access denied."))) 158 | vals (map get fields)] 159 | (concat 160 | `("Type: " (:value ~(class obj)) (:newline) 161 | "Value: " (:value ~obj) (:newline) 162 | "---" (:newline) 163 | "Fields: " (:newline)) 164 | (mapcat 165 | (fn [name val] 166 | `(~(str " " name ": ") (:value ~val) (:newline))) names vals)))) 167 | 168 | (defn- inspect-class-section [obj section] 169 | (let [method (symbol (str ".get" (name section))) 170 | elements (eval (list method obj))] 171 | (if (seq elements) 172 | `(~(name section) ": " (:newline) 173 | ~@(mapcat (fn [f] `(" " (:value ~f) (:newline))) elements))))) 174 | 175 | (defmethod emacs-inspect :class [#^Class obj] 176 | (apply concat (interpose ['(:newline) "--- "] 177 | (cons `("Type: " (:value ~(class obj)) (:newline)) 178 | (for [section [:Interfaces :Constructors 179 | :Fields :Methods] 180 | :let [elements (inspect-class-section 181 | obj section)] 182 | :when (seq elements)] 183 | elements))))) 184 | 185 | (defmethod emacs-inspect :aref [#^clojure.lang.ARef obj] 186 | `("Type: " (:value ~(class obj)) (:newline) 187 | "Value: " (:value ~(deref obj)) (:newline))) 188 | 189 | (defn ns-refers-by-ns [#^clojure.lang.Namespace ns] 190 | (group-by (fn [#^clojure.lang.Var v] (. v ns)) 191 | (map val (ns-refers ns)))) 192 | 193 | (defmethod emacs-inspect :namespace [#^clojure.lang.Namespace obj] 194 | (concat 195 | (label-value-line* 196 | ("Class" (class obj)) 197 | ("Count" (count (ns-map obj)))) 198 | '("---" (:newline) 199 | "Refer from: " (:newline)) 200 | (mapcat (fn [[ns refers]] 201 | `(" "(:value ~ns) " = " (:value ~refers) (:newline))) 202 | (ns-refers-by-ns obj)) 203 | (label-value-line* 204 | ("Imports" (ns-imports obj)) 205 | ("Interns" (ns-interns obj))))) 206 | 207 | (defn inspector-content [specs] 208 | (letfn [(spec-seq [seq] 209 | (let [[f & args] seq] 210 | (cond 211 | (= f :newline) (str \newline) 212 | 213 | (= f :value) 214 | (let [[obj & [str]] args] 215 | (value-part obj str)) 216 | 217 | (= f :action) 218 | (let [[label lambda & options] args 219 | {:keys [refresh?]} (apply hash-map options)] 220 | (action-part label lambda refresh?))))) 221 | (spec-value [val] 222 | (cond 223 | (string? val) val 224 | (seq? val) (spec-seq val)))] 225 | (map spec-value specs))) 226 | 227 | ;; Works for infinite sequences, but it lies about length. Luckily, emacs doesn't 228 | ;; care. 229 | (defn content-range [lst start end] 230 | (let [amount-wanted (- end start) 231 | shifted (drop start lst) 232 | taken (take amount-wanted shifted) 233 | amount-taken (count taken)] 234 | (if (< amount-taken amount-wanted) 235 | (list taken (+ amount-taken start) start end) 236 | ;; There's always more until we know there isn't 237 | (list taken (+ end 500) start end)))) 238 | 239 | (defn inspect-object [o] 240 | (dosync 241 | (ref-set inspectee o) 242 | (alter inspector-stack conj o) 243 | (when-not (filter #(identical? o %) @inspector-history) 244 | (alter inspector-history conj o)) 245 | (ref-set inspectee-content (inspector-content (emacs-inspect o))) 246 | (list :title (inspectee-title o) 247 | :id (assign-index o inspectee-parts) 248 | :content (content-range @inspectee-content 0 500)))) 249 | 250 | (defslimefn init-inspector [string] 251 | (with-emacs-package 252 | (reset-inspector) 253 | (inspect-object (eval (read-string string))))) 254 | 255 | (defn inspect-in-emacs [what] 256 | (letfn [(send-it [] 257 | (with-emacs-package 258 | (reset-inspector) 259 | (send-to-emacs `(:inspect ~(inspect-object what)))))] 260 | (cond 261 | *current-connection* (send-it) 262 | (comment (first @connections)) 263 | ;; TODO: take a second look at this, will probably need garbage collection on connections 264 | (comment 265 | (binding [*current-connection* (first @connections)] 266 | (send-it)))))) 267 | 268 | (defslimefn inspect-frame-var [frame index] 269 | (if (and (zero? frame) *current-env*) 270 | (let [locals *current-env* 271 | object (locals (nth (keys locals) index))] 272 | (with-emacs-package 273 | (reset-inspector) 274 | (inspect-object object))))) 275 | 276 | (defslimefn inspector-nth-part [index] 277 | (get @inspectee-parts index)) 278 | 279 | (defslimefn inspect-nth-part [index] 280 | (with-emacs-package 281 | (inspect-object ((slime-fn 'inspector-nth-part) index)))) 282 | 283 | (defslimefn inspector-range [from to] 284 | (content-range @inspectee-content from to)) 285 | 286 | (defn ref-pop [ref] 287 | (let [[f & r] @ref] 288 | (ref-set ref r) 289 | f)) 290 | 291 | (defslimefn inspector-call-nth-action [index & args] 292 | (let [[fn refresh?] (get @inspectee-actions index)] 293 | (apply fn args) 294 | (if refresh? 295 | (inspect-object (dosync (ref-pop inspector-stack))) 296 | nil))) 297 | 298 | (defslimefn inspector-pop [] 299 | (with-emacs-package 300 | (cond 301 | (rest @inspector-stack) 302 | (inspect-object 303 | (dosync 304 | (ref-pop inspector-stack) 305 | (ref-pop inspector-stack))) 306 | :else nil))) 307 | 308 | (defslimefn inspector-next [] 309 | (with-emacs-package 310 | (let [pos (position #{@inspectee} @inspector-history)] 311 | (cond 312 | (= (inc pos) (count @inspector-history)) nil 313 | :else (inspect-object (get @inspector-history (inc pos))))))) 314 | 315 | (defslimefn inspector-reinspect [] 316 | (inspect-object @inspectee)) 317 | 318 | (defslimefn quit-inspector [] 319 | (reset-inspector) 320 | nil) 321 | 322 | (defslimefn describe-inspectee [] 323 | (with-emacs-package 324 | (str @inspectee))) 325 | -------------------------------------------------------------------------------- /src/swank/commands/xref.clj: -------------------------------------------------------------------------------- 1 | (ns swank.commands.xref 2 | (:use clojure.walk swank.util) 3 | (:import (clojure.lang RT) 4 | (java.io LineNumberReader InputStreamReader Reader PushbackReader))) 5 | 6 | ;; Yoinked and modified from clojure.contrib.repl-utils. 7 | ;; Now takes a var instead of a sym in the current ns 8 | (defn- get-source-from-var 9 | "Returns a string of the source code for the given symbol, if it can 10 | find it. This requires that the symbol resolve to a Var defined in 11 | a namespace for which the .clj is in the classpath. Returns nil if 12 | it can't find the source. 13 | Example: (get-source-from-var 'filter)" 14 | [v] (when-let [filepath (:file (meta v))] 15 | (when-let [strm (.getResourceAsStream (RT/baseLoader) filepath)] 16 | (with-open [rdr (LineNumberReader. (InputStreamReader. strm))] 17 | (dotimes [_ (dec (:line (meta v)))] (.readLine rdr)) 18 | (let [text (StringBuilder.) 19 | pbr (proxy [PushbackReader] [rdr] 20 | (read [] (let [#^Reader this this 21 | i (proxy-super read)] 22 | (.append text (char i)) 23 | i)))] 24 | (read (PushbackReader. pbr)) 25 | (str text)))))) 26 | 27 | (defn- recursive-contains? [coll obj] 28 | "True if coll contains obj. Obj can't be a seq" 29 | (not (empty? (filter #(= obj %) (flatten coll))))) 30 | 31 | (defn- does-var-call-fn [var fn] 32 | "Checks if a var calls a function named 'fn" 33 | (if-let [source (get-source-from-var var)] 34 | (let [node (read-string source)] 35 | (if (recursive-contains? node fn) 36 | var 37 | false)))) 38 | 39 | (defn- does-ns-refer-to-var? [ns var] 40 | (ns-resolve ns var)) 41 | 42 | (defn all-vars-who-call [sym] 43 | (filter 44 | ifn? 45 | (filter 46 | #(identity %) 47 | (map #(does-var-call-fn % sym) 48 | (flatten 49 | (map vals 50 | (map ns-interns 51 | (filter #(does-ns-refer-to-var? % sym) 52 | (all-ns))))))))) 53 | -------------------------------------------------------------------------------- /src/swank/core.clj: -------------------------------------------------------------------------------- 1 | (ns swank.core 2 | (:refer-clojure :exclude [next]) 3 | (:use (swank util commands) 4 | (swank.util hooks) 5 | (swank.util.concurrent thread) 6 | (swank.core connection hooks threadmap debugger-backends)) 7 | (:require (swank.util.concurrent [mbox :as mb]) 8 | (clj-stacktrace core repl)) 9 | (:use [swank.util.clj-stacktrace-compat 10 | :only [pst-elem-str find-source-width]]) 11 | (:import (java.io BufferedReader))) 12 | 13 | ;; Protocol version 14 | (defonce protocol-version (atom "20100404")) 15 | 16 | ;; Emacs packages 17 | (def #^{:dynamic true} *current-package*) 18 | 19 | ;; current emacs eval id 20 | (def #^{:dynamic true} *pending-continuations* '()) 21 | 22 | (def color-support? (atom false)) 23 | 24 | (def exit-on-quit? (atom true)) 25 | 26 | (def sldb-stepping-p nil) 27 | (def sldb-initial-frames 10) 28 | (def #^{:dynamic true} #^{:doc "The current level of recursive debugging."} 29 | *sldb-level* 0) 30 | (def #^{:dynamic true} #^{:doc "The current restarts."} 31 | *sldb-restarts* 0) 32 | 33 | (def #^{:doc "Include swank-clojure thread in stack trace for debugger."} 34 | debug-swank-clojure false) 35 | 36 | (defonce active-threads (ref ())) 37 | 38 | (defn maybe-ns [package] 39 | (cond 40 | (symbol? package) (or (find-ns package) (maybe-ns 'user)) 41 | (string? package) (maybe-ns (symbol package)) 42 | (keyword? package) (maybe-ns (name package)) 43 | (instance? clojure.lang.Namespace package) package 44 | :else (maybe-ns 'user))) 45 | 46 | (defmacro with-emacs-package [& body] 47 | `(binding [*ns* (maybe-ns *current-package*)] 48 | ~@body)) 49 | 50 | (defmacro with-package-tracking [& body] 51 | `(let [last-ns# *ns*] 52 | (try 53 | ~@body 54 | (finally 55 | (when-not (= last-ns# *ns*) 56 | (send-to-emacs `(:new-package ~(str (ns-name *ns*)) 57 | ~(str (ns-name *ns*))))))))) 58 | 59 | (defmacro dothread-swank [& body] 60 | `(dothread-keeping-clj [*current-connection*] 61 | ~@body)) 62 | 63 | ;; Exceptions for debugging 64 | (defonce debug-quit-exception (Exception. "Debug quit")) 65 | (defonce debug-continue-exception (Exception. "Debug continue")) 66 | (defonce debug-abort-exception (Exception. "Debug abort")) 67 | (defonce debug-invalid-restart-exception (Exception. "Invalid restart")) 68 | 69 | (def #^{:dynamic true} #^Throwable *current-exception* nil) 70 | 71 | ;; Local environment 72 | (def #^{:dynamic true} *current-env* nil) 73 | 74 | (let [&env :unavailable] 75 | (defmacro local-bindings 76 | "Produces a map of the names of local bindings to their values." 77 | [] 78 | (if-not (= &env :unavailable) 79 | (let [symbols (keys &env)] 80 | (zipmap (map (fn [sym] `(quote ~sym)) symbols) symbols))))) 81 | 82 | ;; Handle Evaluation 83 | (defn send-to-emacs 84 | "Sends a message (msg) to emacs." 85 | ([msg] 86 | (mb/send @(*current-connection* :control-thread) msg))) 87 | 88 | (defn send-repl-results-to-emacs [val] 89 | (send-to-emacs `(:write-string ~(str (pr-str val) "\n") :repl-result))) 90 | 91 | (defn with-env-locals 92 | "Evals a form with given locals. The locals should be a map of symbols to 93 | values." 94 | [form] 95 | (if (seq *current-env*) 96 | `(let ~(vec (mapcat #(list % `(*current-env* '~%)) (keys *current-env*))) 97 | ~form) 98 | form)) 99 | 100 | (defn eval-in-emacs-package [form] 101 | (with-emacs-package 102 | (eval form))) 103 | 104 | 105 | (defn eval-from-control 106 | "Blocks for a mbox message from the control thread and executes it 107 | when received. The mbox message is expected to be a slime-fn." 108 | ([] (let [form (mb/receive (current-thread))] 109 | (apply (ns-resolve *ns* (first form)) (rest form))))) 110 | 111 | (defn eval-loop 112 | "A loop which continuosly reads actions from the control thread and 113 | evaluates them (will block if no mbox message is available)." 114 | ([] (continuously (eval-from-control)))) 115 | 116 | (defn exception-causes [#^Throwable t] 117 | (lazy-seq 118 | (cons t (when-let [cause (.getCause t)] 119 | (exception-causes cause))))) 120 | 121 | (defn- debug-quit-exception? [t] 122 | (some #(identical? debug-quit-exception %) (exception-causes t))) 123 | 124 | (defn debug-continue-exception? [t] 125 | (some #(identical? debug-continue-exception %) (exception-causes t))) 126 | 127 | (defn- debug-abort-exception? [t] 128 | (some #(identical? debug-abort-exception %) (exception-causes t))) 129 | 130 | (defn- debug-invalid-restart-exception? [t] 131 | (some #(identical? debug-invalid-restart-exception %) (exception-causes t))) 132 | 133 | (defn exception-str [width elem] 134 | (pst-elem-str 135 | @color-support? (clj-stacktrace.core/parse-trace-elem elem) width)) 136 | 137 | (defmethod exception-stacktrace :default [t] 138 | (let [width (find-source-width 139 | (clj-stacktrace.core/parse-exception t))] 140 | (map #(list %1 %2 '(:restartable nil)) 141 | (iterate inc 0) 142 | (map #(exception-str width %) (.getStackTrace #^Throwable t))))) 143 | 144 | (defmethod debugger-condition-for-emacs :default [] 145 | (list (or (.getMessage #^Throwable *current-exception*) 146 | (.toString #^Throwable *current-exception*) 147 | "No message.") 148 | (str " [Thrown " (class *current-exception*) "]") 149 | nil)) 150 | 151 | (defn make-restart [kw name description f] 152 | [kw [name description f]]) 153 | 154 | (defn add-restart-if [condition restarts kw name description f] 155 | (if condition 156 | (conj restarts (make-restart kw name description f)) 157 | restarts)) 158 | 159 | (declare sldb-debug) 160 | (defn cause-restart-for [#^Throwable thrown depth] 161 | (make-restart 162 | (keyword (str "cause" depth)) 163 | (str "CAUSE" depth) 164 | (str "Invoke debugger on cause " 165 | (apply str (take depth (repeat " "))) 166 | (.getMessage thrown) 167 | " [Thrown " (class thrown) "]") 168 | (partial sldb-debug nil thrown *pending-continuations*))) 169 | 170 | (defn add-cause-restarts [restarts #^Throwable thrown] 171 | (loop [restarts restarts 172 | cause (.getCause thrown) 173 | level 1] 174 | (if cause 175 | (recur 176 | (conj restarts (cause-restart-for cause level)) 177 | (.getCause cause) 178 | (inc level)) 179 | restarts))) 180 | 181 | (defmethod calculate-restarts :default [#^Throwable thrown] 182 | (let [restarts [(make-restart :quit "QUIT" "Quit to the SLIME top level" 183 | (fn [] (throw debug-quit-exception)))] 184 | restarts (add-restart-if 185 | (pos? *sldb-level*) 186 | restarts 187 | :abort "ABORT" (str "ABORT to SLIME level " (dec *sldb-level*)) 188 | (fn [] (throw debug-abort-exception))) 189 | restarts (add-restart-if 190 | (and (.getMessage thrown) 191 | (.contains (.getMessage thrown) "BREAK")) 192 | restarts 193 | :continue "CONTINUE" (str "Continue from breakpoint") 194 | (fn [] (throw debug-continue-exception))) 195 | restarts (add-cause-restarts restarts thrown)] 196 | (into (array-map) restarts))) 197 | 198 | (defn format-restarts-for-emacs [] 199 | (doall (map #(list (first (second %)) (second (second %))) *sldb-restarts*))) 200 | 201 | (defmethod build-backtrace :default [start end] 202 | (doall (take (- end start) (drop start (exception-stacktrace *current-exception*))))) 203 | 204 | (defn build-debugger-info-for-emacs [start end] 205 | (list (debugger-condition-for-emacs) 206 | (format-restarts-for-emacs) 207 | (build-backtrace start end) 208 | *pending-continuations*)) 209 | 210 | (defn sldb-loop 211 | "A loop that is intented to take over an eval thread when a debug is 212 | encountered (an continue to perform the same thing). It will 213 | continue until a *debug-quit* exception is encountered." 214 | [level] 215 | (try 216 | (send-to-emacs 217 | (list* :debug (current-thread) level 218 | (build-debugger-info-for-emacs 0 sldb-initial-frames))) 219 | ([] (continuously 220 | (do 221 | (send-to-emacs `(:debug-activate ~(current-thread) ~level nil)) 222 | (eval-from-control)))) 223 | (catch Throwable t 224 | (send-to-emacs 225 | `(:debug-return ~(current-thread) ~*sldb-level* ~sldb-stepping-p)) 226 | (if-not (handled-exception? t) 227 | (throw t))))) 228 | 229 | (defn invoke-debugger 230 | [locals #^Throwable thrown id] 231 | (binding [*current-env* locals 232 | *current-exception* thrown 233 | *sldb-restarts* (calculate-restarts thrown) 234 | *sldb-level* (inc *sldb-level*)] 235 | (sldb-loop *sldb-level*))) 236 | 237 | (defn sldb-debug [locals thrown id] 238 | (try 239 | (invoke-debugger locals thrown id) 240 | (catch Throwable t 241 | (when (and (pos? *sldb-level*) 242 | (not (debug-abort-exception? t))) 243 | (throw t))))) 244 | 245 | (defmacro break 246 | [] 247 | `(invoke-debugger (local-bindings) (Exception. "BREAK:") *pending-continuations*)) 248 | 249 | (defn doall-seq [coll] 250 | (if (seq? coll) 251 | (doall coll) 252 | coll)) 253 | 254 | (defn eval-for-emacs [form buffer-package id] 255 | (try 256 | (binding [*current-package* buffer-package 257 | *pending-continuations* (cons id *pending-continuations*)] 258 | (if-let [f (slime-fn (first form))] 259 | (let [form (cons f (rest form)) 260 | result (doall-seq (eval-in-emacs-package form))] 261 | (run-hook pre-reply-hook) 262 | (send-to-emacs `(:return ~(thread-name (current-thread)) 263 | (:ok ~result) ~id))) 264 | ;; swank function not defined, abort 265 | (send-to-emacs `(:return ~(thread-name (current-thread)) (:abort) ~id)))) 266 | (catch Throwable t 267 | ;; Thread/interrupted clears this thread's interrupted status; if 268 | ;; Thread.stop was called on us it may be set and will cause an 269 | ;; InterruptedException in one of the send-to-emacs calls below 270 | (Thread/interrupted) 271 | 272 | ;; (.printStackTrace t #^java.io.PrintWriter *err*) 273 | 274 | (cond 275 | (debug-quit-exception? t) 276 | (do 277 | (send-to-emacs `(:return ~(thread-name (current-thread)) (:abort) ~id)) 278 | (if-not (zero? *sldb-level*) 279 | (throw t))) 280 | 281 | (debug-abort-exception? t) 282 | (do 283 | (send-to-emacs `(:return ~(thread-name (current-thread)) (:abort) ~id)) 284 | (if-not (zero? *sldb-level*) 285 | (throw debug-abort-exception))) 286 | 287 | (debug-continue-exception? t) 288 | (do 289 | (send-to-emacs `(:return ~(thread-name (current-thread)) (:abort) ~id)) 290 | (throw t)) 291 | ;; 292 | (debug-invalid-restart-exception? t) 293 | (send-to-emacs `(:return ~(thread-name (current-thread)) 294 | (:ok "Restart index out of bounds") ~id)) 295 | ;; 296 | (debugger-exception? t) 297 | (throw t) 298 | 299 | :else 300 | (do 301 | (set! *e t) 302 | (try 303 | (sldb-debug 304 | nil 305 | (if debug-swank-clojure t (or (.getCause t) t)) 306 | id) 307 | ;; reply with abort 308 | (finally (send-to-emacs 309 | `(:return ~(thread-name (current-thread)) (:abort) ~id))))))))) 310 | 311 | (defn- add-active-thread [thread] 312 | (dosync 313 | (commute active-threads conj thread))) 314 | 315 | (defn- remove-active-thread [thread] 316 | (dosync 317 | (commute active-threads (fn [threads] (remove #(= % thread) threads))))) 318 | 319 | (def swank-worker-thread-name "Swank Worker Thread") 320 | (defonce swank-worker-thread-group 321 | (ThreadGroup. swank-worker-thread-name)) 322 | 323 | (defn spawn-worker-thread 324 | "Spawn an thread that blocks for a single command from the control 325 | thread, executes it, then terminates." 326 | ([conn] 327 | ;; binding is a signal to dbe's not to allow bp's on this thread 328 | ;; because it will hang swank 329 | (binding [*new-thread-group* swank-worker-thread-group] 330 | (dothread-swank 331 | (try 332 | (add-active-thread (current-thread)) 333 | (thread-set-name swank-worker-thread-name) 334 | (eval-from-control) 335 | (finally 336 | (remove-active-thread (current-thread)))))))) 337 | 338 | (defn spawn-repl-thread 339 | "Spawn an thread that sets itself as the current 340 | connection's :repl-thread and then enters an eval-loop" 341 | ([conn] 342 | (dothread-swank 343 | (thread-set-name "Swank REPL Thread") 344 | (with-connection conn 345 | (eval-loop))))) 346 | 347 | (defn find-or-spawn-repl-thread 348 | "Returns the current connection's repl-thread or create a new one if 349 | the existing one does not exist." 350 | ([conn] 351 | ;; TODO - check if an existing repl-agent is still active & doesn't have errors 352 | (dosync 353 | (or (when-let [conn-repl-thread @(conn :repl-thread)] 354 | (when (.isAlive #^Thread conn-repl-thread) 355 | conn-repl-thread)) 356 | (ref-set (conn :repl-thread) 357 | (spawn-repl-thread conn)))))) 358 | 359 | (defn thread-for-evaluation 360 | "Given an id and connection, find or create the appropiate agent." 361 | ([id conn] 362 | (cond 363 | (= id true) (spawn-worker-thread conn) 364 | (= id :repl-thread) (find-or-spawn-repl-thread conn) 365 | :else (find-thread id)))) 366 | 367 | 368 | ;;; slime proto :emacs-return support and the swank commands 369 | ;;; that depend on it: :eval :read-from-minibuffer :y-or-n-p :read-string 370 | 371 | (defonce emacs-return-promises (atom {})) 372 | 373 | (defn- create-emacs-return-promise [thread tag] 374 | (let [p (promise)] 375 | (swap! emacs-return-promises 376 | (fn [promise-map] 377 | (assoc promise-map [thread tag] p))) 378 | p)) 379 | 380 | (defn- clear-emacs-return-promise [thread tag] 381 | (swap! emacs-return-promises 382 | (fn [promise-map] (dissoc promise-map [thread tag])))) 383 | 384 | (defn- deliver-emacs-return-promise [thread tag val] 385 | (let [p (@emacs-return-promises [thread tag])] 386 | (if p 387 | (deliver p val)))) 388 | 389 | (defn- send-slime-command-to-emacs-and-wait [slime-command & args] 390 | (assert (#{:eval :read-from-minibuffer 391 | :y-or-n-p :read-string} 392 | slime-command)) 393 | (let [thread (thread-name (current-thread)) 394 | tag (str (java.util.UUID/randomUUID)) 395 | p (create-emacs-return-promise thread tag)] 396 | (send-to-emacs `(~slime-command ~thread ~tag ~@args)) 397 | (let [retval @p] 398 | (clear-emacs-return-promise thread tag) 399 | retval))) 400 | 401 | (defn eval-in-emacs 402 | "Sends an elisp `formstring` to slime for evaluation and blocks 403 | until that the result of the eval is available. 404 | 405 | Unlike `eval-in-emacs-async`, this function unwraps the slime-proto 406 | return value and cleans up the promise used . 407 | 408 | NOTE: you must (setq slime-enable-evaluate-in-emacs t) on the Emacs 409 | side before calling this function." 410 | 411 | [formstring] 412 | 413 | (let [retval (send-slime-command-to-emacs-and-wait :eval formstring)] 414 | (case (first retval) 415 | :ok (second retval) 416 | :abort (throw (Exception. "Emacs eval abort"))))) 417 | 418 | (defn eval-in-emacs-async 419 | "Sends an elisp `formstring` to slime for evaluation and immediately 420 | returns a promise that the result of the eval will be delivered to 421 | eventually. 422 | 423 | The value delivered to the promise is either (:ok retval) 424 | or (:abort) if there was any error. 425 | 426 | The `thread` argument should be the thread name or id. The `tag` 427 | argument is an arbitrary string identifier used to address the 428 | return value from emacs to the correct promise. UUID's are a good 429 | option. 430 | 431 | Callers of this function are responsible for calling 432 | (clear-emacs-return-promise thread tag) after they have retrieved 433 | the return value from the promise. 434 | 435 | NOTE: you must (setq slime-enable-evaluate-in-emacs t) on the Emacs 436 | side before calling this function." 437 | 438 | [formstring thread tag] 439 | (let [p (create-emacs-return-promise thread tag)] 440 | (send-to-emacs `(:eval ~thread ~tag ~formstring)) 441 | p)) 442 | 443 | (defn read-line-from-emacs [] 444 | (send-slime-command-to-emacs-and-wait :read-string)) 445 | 446 | (defn read-from-emacs-minibuffer [prompt & [initial-value]] 447 | (send-slime-command-to-emacs-and-wait :read-from-minibuffer prompt initial-value)) 448 | 449 | (defmacro with-read-line-support 450 | "Rebind *in* to a proxy that dispatches .readLine to Emacs, 451 | so `(read-line)` will work within slime sessions. 452 | 453 | Note, .read / (read), etc will not work." 454 | [& body] 455 | `(binding [*in* (proxy [BufferedReader] [*in*] 456 | (readLine [] 457 | (swank.core/read-line-from-emacs)))] 458 | ~@body)) 459 | 460 | ;; Handle control 461 | 462 | (defn read-loop 463 | "A loop that reads from the socket (will block when no message 464 | available) and dispatches the message to the control thread." 465 | ([conn control] 466 | (with-connection conn 467 | (continuously (mb/send control (read-from-connection conn)))))) 468 | 469 | (defn dispatch-event 470 | "Dispatches/executes an event in the control thread's mailbox queue." 471 | ([ev conn] 472 | (let [[action & args] ev] 473 | (cond 474 | (= action :emacs-rex) 475 | (let [[form-string package thread id] args 476 | thread (thread-for-evaluation thread conn)] 477 | (mb/send thread `(eval-for-emacs ~form-string ~package ~id))) 478 | 479 | ;; handle events from the debugger backend 480 | (= action :dbe-rex) 481 | (let [[form-string thread] args 482 | thread (thread-for-evaluation thread conn)] 483 | (mb/send thread (read-string form-string))) 484 | 485 | (= action :return) 486 | (let [[thread & ret] args] 487 | (binding [*print-level* nil, *print-length* nil] 488 | (write-to-connection conn `(:return ~@ret)))) 489 | 490 | (one-of? action 491 | :presentation-start :presentation-end 492 | :new-package :new-features :ed :percent-apply 493 | :indentation-update 494 | :eval :eval-no-wait :background-message :inspect 495 | :read-from-minibuffer :y-or-n-p) 496 | (binding [*print-level* nil, *print-length* nil] 497 | (write-to-connection conn ev)) 498 | 499 | (= action :write-string) 500 | (write-to-connection conn ev) 501 | 502 | (= action :read-string) 503 | (write-to-connection conn ev) 504 | 505 | (one-of? action :emacs-return :emacs-return-string) 506 | (apply deliver-emacs-return-promise args) ; args = [thread tag val] 507 | 508 | (one-of? action 509 | :debug :debug-condition :debug-activate :debug-return) 510 | (let [[thread & args] args] 511 | (write-to-connection conn `(~action ~(thread-map-id thread) ~@args))) 512 | 513 | (= action :emacs-interrupt) 514 | (let [[thread & args] args] 515 | (handle-interrupt thread conn args)) 516 | :else 517 | nil)))) 518 | 519 | ;; Main loop definitions 520 | (defn control-loop 521 | "A loop that reads from the mbox queue and runs dispatch-event on 522 | it (will block if no mbox control message is available). This is 523 | intended to only be run on the control thread." 524 | ([conn] 525 | (binding [*1 nil, *2 nil, *3 nil, *e nil] 526 | (with-connection conn 527 | (continuously (dispatch-event (mb/receive (current-thread)) conn)))))) 528 | 529 | ;;; default implementations of some core multimethods 530 | (defmethod eval-string-in-frame :default [expr n] 531 | (if (and (zero? n) *current-env*) 532 | (with-bindings *current-env* 533 | (eval expr)))) 534 | 535 | (defmethod swank-eval :default [form] 536 | (eval (with-env-locals form))) 537 | 538 | (defmethod get-stack-trace :default [n] 539 | (nth (.getStackTrace #^Throwable *current-exception*) n)) 540 | 541 | (defmethod handled-exception? :default [t] 542 | (debug-continue-exception? t)) 543 | 544 | (defmethod debugger-exception? :default [t] 545 | false) 546 | 547 | (defmethod handle-interrupt :default [thread conn args] 548 | (dosync 549 | (cond 550 | (and (true? thread) (seq @active-threads)) 551 | (.stop #^Thread (first @active-threads)) 552 | 553 | (= thread :repl-thread) (.stop #^Thread @(conn :repl-thread))))) 554 | -------------------------------------------------------------------------------- /src/swank/core/cdt_backends.clj: -------------------------------------------------------------------------------- 1 | (ns swank.core.cdt-backends 2 | (:refer-clojure :exclude [next]) 3 | (:require [cdt.ui :as cdt] 4 | [cdt.reval] 5 | [swank.core.cdt-utils :as cutils] 6 | [swank.core :as core] 7 | [swank.util.concurrent.thread :as st] 8 | [clj-stacktrace repl core]) 9 | (:use swank.core.debugger-backends 10 | [swank.commands :only [defslimefn]]) 11 | (:import java.util.concurrent.TimeUnit)) 12 | 13 | (defmethod swank-eval :cdt [form] 14 | (cdt/safe-reval (:thread @*debugger-env*) 15 | (:frame @*debugger-env*) form true identity)) 16 | 17 | (defn- get-full-stack-trace [] 18 | (.getStackTrace (cutils/get-thread #_(.getName @control-thread) 19 | (.name (:thread @*debugger-env*))))) 20 | 21 | (defmethod get-stack-trace :cdt [n] 22 | (swap! *debugger-env* assoc :frame n) 23 | (reset! last-viewed-source 24 | (select-keys @*debugger-env* [:thread :frame])) 25 | (nth (get-full-stack-trace) n)) 26 | 27 | ;; (defmethod exception-stacktrace :cdt [_] 28 | ;; (map #(list %1 %2 '(:restartable nil)) 29 | ;; (iterate inc 0) 30 | ;; (map str (get-full-stack-trace)))) 31 | 32 | (defmethod exception-stacktrace :cdt [_] 33 | (let [width 25 ;; @@ TODO: hard-coded for now as below does not work: 34 | #_(clj-stacktrace.repl/find-source-width 35 | (clj-stacktrace.core/parse-exception t))] 36 | (map #(list %1 %2 '(:restartable nil)) 37 | (iterate inc 0) 38 | (map #(core/exception-str width %) (get-full-stack-trace))))) 39 | 40 | (defmethod debugger-condition-for-emacs :cdt [] 41 | (:env @*debugger-env*)) 42 | 43 | (defmethod calculate-restarts :cdt [_] 44 | (let [quit-exception (cutils/get-quit-exception) 45 | restarts 46 | [(core/make-restart :quit "QUIT" 47 | "Quit to the SLIME top level" 48 | #(throw cutils/debug-cdt-continue-exception))] 49 | restarts (core/add-restart-if 50 | (pos? core/*sldb-level*) 51 | restarts 52 | :abort "ABORT" (str "ABORT to SLIME level " 53 | (dec core/*sldb-level*)) 54 | (fn [] (throw core/debug-abort-exception)))] 55 | (into (array-map) restarts))) 56 | 57 | (defmethod build-backtrace :cdt [start end] 58 | (doall (take (- end start) 59 | (drop start (exception-stacktrace nil))))) 60 | 61 | (defmethod eval-string-in-frame :cdt [string n] 62 | (swap! *debugger-env* assoc :frame n) 63 | (cdt/safe-reval (:thread @*debugger-env*) 64 | (:frame @*debugger-env*) 65 | (read-string string) true identity)) 66 | 67 | (defmethod eval-last-frame :cdt [form-string] 68 | (cdt/safe-reval 69 | (:thread @last-viewed-source) 70 | (:frame @last-viewed-source) 71 | (read-string form-string) true identity)) 72 | 73 | (defmacro reval [form] 74 | `(cdt/safe-reval 75 | (:thread @last-viewed-source) 76 | (:frame @last-viewed-source) 77 | '~form true read-string)) 78 | 79 | (defn- reset-last-viewed-source [] 80 | (reset! last-viewed-source (atom nil))) 81 | 82 | (defmacro make-cdt-method [name func] 83 | `(defmethod ~name :cdt [] 84 | (reset-last-viewed-source) 85 | (~(ns-resolve (the-ns 'cdt.ui) func) 86 | (:thread @*debugger-env*)) 87 | true)) 88 | 89 | (make-cdt-method step step) 90 | (make-cdt-method next step-over) 91 | (make-cdt-method finish finish) 92 | (make-cdt-method continue continue-thread) 93 | 94 | (defonce cdt-started-promise (promise)) 95 | 96 | (defn wait-till-cdt-started [] 97 | (try 98 | (.get (future (and @cdt-started-promise (cdt/event-handler-started?))) 99 | 5000 TimeUnit/MILLISECONDS) 100 | (catch Exception e 101 | (throw (IllegalStateException. 102 | (str "CDT failed to start. Check for errors on stdout")))))) 103 | 104 | (defmethod line-bp :cdt [file line] 105 | (wait-till-cdt-started) 106 | (cdt/line-bp file line 107 | (cutils/get-non-system-threads) 108 | (cutils/get-system-thread-groups) true)) 109 | 110 | (defmacro set-bp [sym] 111 | `(do 112 | (wait-till-cdt-started) 113 | (cdt/set-bp-sym '~sym [(cutils/get-non-system-threads) 114 | (cutils/get-system-thread-groups) true]))) 115 | 116 | (defmethod debugger-exception? :cdt [t] 117 | (or (cutils/debug-cdt-continue-exception? t) 118 | (cutils/debug-finish-exception? t) 119 | (cutils/debug-next-exception? t) 120 | (cutils/debug-step-exception? t))) 121 | 122 | (defmethod handled-exception? :cdt [t] 123 | (cond 124 | (core/debug-continue-exception? t) 125 | true 126 | (cutils/debug-step-exception? t) 127 | (step) 128 | (cutils/debug-next-exception? t) 129 | (next) 130 | (cutils/debug-cdt-continue-exception? t) 131 | (continue) 132 | (cutils/debug-finish-exception? t) 133 | (finish))) 134 | 135 | (defn- gen-debugger-env [env] 136 | (atom {:env (:env env) 137 | :thread (cdt/get-thread-from-id (:thread env)) 138 | :frame 0})) 139 | 140 | (defn get-frame-locals [env] 141 | (try 142 | (let [thread (cdt/get-thread-from-id (:thread env)) 143 | frame-num 0 144 | ;foo (doall (cdt.reval/gen-locals-and-closures thread frame-num)) 145 | local-names (cdt.reval/local-names thread frame-num) 146 | locals (into {} 147 | (doall 148 | (map 149 | (fn [nm] 150 | [nm 151 | (cdt.reval/fixup-string-reference-impl 152 | (cdt.reval/reval-ret-str thread frame-num 153 | nm true)) 154 | ]) 155 | local-names)))] 156 | 157 | ;; (println "**: " foo "\n") 158 | locals) 159 | (catch Throwable t 160 | (.printStackTrace t #^java.io.PrintWriter *err*) 161 | (println "CDT failed to get frame locals:" t)))) 162 | 163 | (defslimefn sldb-cdt-debug [env] 164 | (binding [*debugger-env* (gen-debugger-env env)] 165 | (core/sldb-debug (get-frame-locals env) nil core/*pending-continuations*))) 166 | 167 | (defslimefn sldb-line-bp [file line] 168 | (line-bp file line)) 169 | 170 | (defslimefn sldb-step [_] 171 | (throw cutils/debug-step-exception)) 172 | 173 | (defslimefn sldb-next [_] 174 | (throw cutils/debug-next-exception)) 175 | 176 | (defslimefn sldb-out [_] 177 | (throw cutils/debug-finish-exception)) 178 | 179 | (defn set-catch [class] 180 | (wait-till-cdt-started) 181 | (cdt/set-catch class :all 182 | (cutils/get-non-system-threads) 183 | (cutils/get-system-thread-groups) true)) 184 | 185 | (defn display-msg [msg] 186 | (doseq [f [cutils/display-background-msg println]] 187 | (f msg))) 188 | 189 | (defmethod handle-interrupt :cdt [_ _ _] 190 | (.deleteEventRequests 191 | (.eventRequestManager (cdt/vm)) 192 | (.breakpointRequests (.eventRequestManager (cdt/vm)))) 193 | (.deleteEventRequests 194 | (.eventRequestManager (cdt/vm)) 195 | (.exceptionRequests (.eventRequestManager (cdt/vm)))) 196 | (cdt/continue-vm) 197 | (reset! cdt/catch-list {}) 198 | (reset! cdt/bp-list {}) 199 | (reset-last-viewed-source) 200 | (display-msg "Clearing CDT event requests and continuing.")) 201 | 202 | (defn cdt-backend-init [release] 203 | (try 204 | (cdt/cdt-attach-pid) 205 | (cdt/create-thread-start-request) 206 | (reset! dispatch-val :cdt) 207 | 208 | ;; classloader exceptions often cause deadlocks and are almost 209 | ;; never interesting so filter them out 210 | (cdt/set-catch-exclusion-filter-strings 211 | "java.net.URLClassLoader*" "java.lang.ClassLoader*" "*ClassLoader.java") 212 | (cdt/set-handler cdt/exception-handler cutils/default-handler) 213 | (cdt/set-handler cdt/breakpoint-handler cutils/default-handler) 214 | (cdt/set-handler cdt/step-handler cutils/default-handler) 215 | (cdt/set-display-msg cutils/display-background-msg) 216 | (cutils/set-control-thread) 217 | (cutils/set-system-thread-groups) 218 | (cutils/init-emacs-helper-functions) 219 | ;; this invocation of handle-interrupt is only needed to force the loading 220 | ;; of the classes required by force-continue because inadvertently 221 | ;; catching an exception which happens to be in the classloader can cause a 222 | ;; deadlock 223 | 224 | (handle-interrupt :cdt nil nil) 225 | (deliver cdt-started-promise true) 226 | (display-msg (str "Swank CDT release " release " started" )) 227 | (catch Exception e 228 | (println "CDT " release "startup failed: " e)))) 229 | -------------------------------------------------------------------------------- /src/swank/core/cdt_utils.clj: -------------------------------------------------------------------------------- 1 | (ns swank.core.cdt-utils 2 | (:refer-clojure :exclude [next]) 3 | (:require [cdt.ui :as cdt] 4 | [swank.util.concurrent.mbox :as mb] 5 | [swank.core :as core]) 6 | (:use swank.core.debugger-backends)) 7 | 8 | 9 | ;; you can't use backquotes in these elisp funcs because they go through 10 | ;; the Clojure reader 11 | 12 | (def elisp-helper-functions 13 | '((progn 14 | ; unused "&optional _" because "()" gets converted to "(nil)" 15 | (defun sldb-line-bp (&optional _) 16 | "Set breakpoint on current buffer line." 17 | (interactive) 18 | (slime-eval-async (list 'swank:sldb-line-bp 19 | ,(buffer-file-name) ,(line-number-at-pos)))) 20 | 21 | (defun slime-force-continue (&optional _) 22 | "force swank server to continue" 23 | (interactive) 24 | (slime-dispatch-event '(:emacs-interrupt :cdt))) 25 | 26 | (defun slime-get-thing-at-point (&optional _) 27 | (interactive) 28 | (let ((thing (thing-at-point 'sexp))) 29 | (set-text-properties 0 (length thing) nil thing) 30 | thing)) 31 | 32 | (defun slime-eval-last-frame (&optional _) 33 | "Eval thing at point in the context of the last frame viewed" 34 | (interactive) 35 | (slime-eval-with-transcript (list 'swank:eval-last-frame 36 | ,(slime-get-thing-at-point)))) 37 | 38 | (define-prefix-command 'cdt-map) 39 | (define-key cdt-map (kbd "C-b") 'sldb-line-bp) 40 | (define-key cdt-map (kbd "C-g") 'slime-force-continue) 41 | (define-key cdt-map (kbd "C-p") 'slime-eval-last-frame) 42 | 43 | (eval-after-load 'slime 44 | '(progn 45 | (define-key slime-mode-map (kbd "C-c C-x") 'cdt-map) 46 | (define-key sldb-mode-map (kbd "C-c C-x") 'cdt-map))) 47 | 48 | (eval-after-load 'slime-repl 49 | '(define-key slime-repl-mode-map 50 | (kbd "C-c C-x") 'cdt-map)) 51 | 52 | (eval-after-load 'cc-mode 53 | '(define-key java-mode-map 54 | (kbd "C-c C-x") 'cdt-map))))) 55 | 56 | (defn- match-name [thread-name] 57 | #(re-find (re-pattern (str "^" thread-name "$")) (.getName %))) 58 | 59 | (defn- get-all-threads [] 60 | (map key (Thread/getAllStackTraces))) 61 | 62 | (defn get-thread [thread-name] 63 | (first (filter 64 | (match-name thread-name) 65 | (get-all-threads)))) 66 | 67 | (def control-thread (atom nil)) 68 | 69 | (defn set-control-thread [] 70 | (reset! control-thread 71 | (get-thread "Swank Control Thread"))) 72 | 73 | (defn get-control-thread [] 74 | (when-not @control-thread 75 | (Thread/sleep 100) 76 | (set-control-thread)) 77 | @control-thread) 78 | 79 | (def system-thread-group-names #{#"JDI main" #"JDI \[\d*\]" #"system" 80 | (re-pattern core/swank-worker-thread-name)}) 81 | (def system-thread-groups (atom [])) 82 | (defn- system-thread-group? [g] 83 | (some #(re-find % (.name g)) system-thread-group-names)) 84 | 85 | (defn set-system-thread-groups [] 86 | (reset! system-thread-groups 87 | (filter system-thread-group? 88 | (cdt/all-thread-groups)))) 89 | 90 | (defn get-system-thread-groups [] @system-thread-groups) 91 | 92 | (def system-thread-names 93 | #{#"^CDT Event Handler$" #"^Swank Control Thread$" #"^Swank Read Loop Thread$" 94 | #"^Swank Socket Server \[\d*\]$"}) 95 | 96 | (defn system-thread? [t] 97 | (some #(re-find % (.name t)) system-thread-names)) 98 | 99 | (defn get-system-threads [] 100 | (filter system-thread? (cdt/list-threads))) 101 | 102 | (defn get-non-system-threads [] 103 | (remove system-thread? (cdt/list-threads))) 104 | 105 | (def bp-text (str "From here you can: " 106 | "e/eval, v/show source, s/step, x/next, o/exit func")) 107 | 108 | (def exception-text "From here you can: e/eval, v/show source") 109 | 110 | (defn- gen-env-list [e text] 111 | (let [[_ s1 _ s2] 112 | (re-find #"(.*)(@.* )(in thread.*)" (str e))] 113 | (list (str "CDT " s1 " " s2) text 114 | '((:show-frame-source 0))))) 115 | 116 | (defn- get-env [e] 117 | (condp = (second (re-find #"^(.*)Event@" (str e))) 118 | "Breakpoint" 119 | (gen-env-list e bp-text) 120 | "Step" 121 | (gen-env-list e bp-text) 122 | "Exception" 123 | (gen-env-list e exception-text))) 124 | 125 | (defn- event-data [e] 126 | {:thread (.uniqueID (cdt/get-thread-from-event e)) 127 | :env (get-env e)}) 128 | 129 | (defonce exception-events (atom #{})) 130 | 131 | (defn- send-to-control-thread [e] 132 | (mb/send (get-control-thread) 133 | ;; pr-str would be better here instead of str, but can 134 | ;; lead to blocking the event handler thread 135 | `(:dbe-rex ~(str `(swank.core.cdt-backends/sldb-cdt-debug 136 | ~(event-data e))) true))) 137 | 138 | (defn default-handler [e] 139 | (if-not (cdt/exception-event? e) 140 | (send-to-control-thread e) 141 | (if (@exception-events (.exception e)) 142 | (cdt/continue-thread (cdt/get-thread-from-event e)) 143 | (do 144 | (swap! exception-events conj (.exception e)) 145 | (send-to-control-thread e))))) 146 | 147 | (defn display-background-msg [s] 148 | (mb/send (get-control-thread) 149 | `(:eval-no-wait "slime-message" ("%s" ~s)))) 150 | 151 | (defn init-emacs-helper-functions [] 152 | (mb/send (get-control-thread) 153 | `(:eval-no-wait "eval" ~elisp-helper-functions))) 154 | 155 | (defmacro make-debugger-exception [exception-name] 156 | (let [full-str-name (str "debug-" exception-name "-exception") 157 | name-sym (symbol full-str-name) 158 | func-sym (symbol (str full-str-name "?"))] 159 | `(do 160 | (defonce ~name-sym (Exception. (str "Debug " ~(str exception-name)))) 161 | (defn ~func-sym [t#] 162 | (some #(identical? ~name-sym %) 163 | (core/exception-causes t#)))))) 164 | 165 | (make-debugger-exception step) 166 | (make-debugger-exception finish) 167 | (make-debugger-exception next) 168 | (make-debugger-exception cdt-continue) 169 | 170 | (defn- exception? [] 171 | (.startsWith (first (:env @*debugger-env*)) "CDT Exception")) 172 | 173 | (defn get-quit-exception [] 174 | (if (exception?) 175 | core/debug-abort-exception 176 | debug-cdt-continue-exception)) 177 | -------------------------------------------------------------------------------- /src/swank/core/connection.clj: -------------------------------------------------------------------------------- 1 | (ns swank.core.connection 2 | (:use (swank util) 3 | (swank.util sys) 4 | (swank.core protocol)) 5 | (:import (java.net ServerSocket Socket InetAddress) 6 | (java.io InputStreamReader OutputStreamWriter))) 7 | 8 | (def #^{:dynamic true} *current-connection*) 9 | (def default-encoding "iso-8859-1") 10 | 11 | (defmacro with-connection [conn & body] 12 | `(binding [*current-connection* ~conn] ~@body)) 13 | 14 | (def encoding-map 15 | {"latin-1" "iso-8859-1" 16 | "latin-1-unix" "iso-8859-1" 17 | "iso-latin-1-unix" "iso-8859-1" 18 | "iso-8859-1" "iso-8859-1" 19 | "iso-8859-1-unix" "iso-8859-1" 20 | 21 | "utf-8" "utf-8" 22 | "utf-8-unix" "utf-8" 23 | 24 | "euc-jp" "euc-jp" 25 | "euc-jp-unix" "euc-jp" 26 | 27 | "us-ascii" "us-ascii" 28 | "us-ascii-unix" "us-ascii"}) 29 | 30 | (defn make-connection ;; rename to make-swank-connection 31 | "Given a `socket', creates a swank connection. Accepts an optional 32 | argument `encoding' to define the encoding of the connection. If 33 | encoding is nil, then the default encoding will be used. 34 | 35 | See also: `default-encoding', `start-server-socket!'" 36 | ([#^Socket socket] (make-connection socket default-encoding)) 37 | ([#^Socket socket encoding] 38 | (let [#^String 39 | encoding (or (encoding-map encoding encoding) default-encoding)] 40 | {:socket socket 41 | :reader (InputStreamReader. (.getInputStream socket) encoding) 42 | :writer (OutputStreamWriter. (.getOutputStream socket) encoding) 43 | :writer-redir (ref nil) 44 | 45 | :indent-cache (ref {}) 46 | :indent-cache-pkg (ref nil) 47 | 48 | :control-thread (ref nil) 49 | :read-thread (ref nil) 50 | :repl-thread (ref nil)}))) 51 | 52 | (defn read-from-connection 53 | "Reads a single message from a swank-connection. 54 | 55 | See also: `write-to-connection', `read-swank-message', 56 | `make-swank-connection'" 57 | ([] (read-from-connection *current-connection*)) 58 | ([conn] 59 | (read-swank-message (conn :reader)))) 60 | 61 | (defn write-to-connection 62 | "Writes a single message to a swank-connection. 63 | 64 | See also: `read-from-connection', `write-swank-message', 65 | `make-swank-connection'" 66 | ([msg] (write-to-connection *current-connection* msg)) 67 | ([conn msg] 68 | (write-swank-message (conn :writer) msg))) 69 | -------------------------------------------------------------------------------- /src/swank/core/debugger_backends.clj: -------------------------------------------------------------------------------- 1 | (ns swank.core.debugger-backends 2 | (:refer-clojure :exclude [next])) 3 | 4 | (def #^{:dynamic true} *debugger-env* (atom nil)) 5 | (def last-viewed-source (atom nil)) 6 | 7 | (defn get-debugger-backend [& args] 8 | (when @*debugger-env* :cdt)) 9 | 10 | (def dispatch-val (atom :default)) 11 | 12 | (defn dbe-dispatch [& args] 13 | @dispatch-val) 14 | 15 | (defmacro def-default-backend-multimethods [methods] 16 | `(do 17 | ~@(for [m methods] 18 | `(defmulti ~m get-debugger-backend)))) 19 | 20 | (def-default-backend-multimethods 21 | [exception-stacktrace debugger-condition-for-emacs calculate-restarts 22 | build-backtrace eval-string-in-frame step get-stack-trace 23 | next finish continue swank-eval handled-exception? debugger-exception?]) 24 | 25 | (defmulti line-bp dbe-dispatch) 26 | (defmulti eval-last-frame dbe-dispatch) 27 | 28 | (defmulti handle-interrupt 29 | (fn [thread _ _] thread)) 30 | -------------------------------------------------------------------------------- /src/swank/core/hooks.clj: -------------------------------------------------------------------------------- 1 | (ns swank.core.hooks 2 | (:use (swank.util hooks))) 3 | 4 | (defhook pre-reply-hook) -------------------------------------------------------------------------------- /src/swank/core/protocol.clj: -------------------------------------------------------------------------------- 1 | (ns swank.core.protocol 2 | (:use (swank util) 3 | (swank.util io)) 4 | (:require swank.rpc)) 5 | 6 | ;; Read forms 7 | (def #^{:private true} 8 | namespace-re #"(^\(:emacs-rex \([a-zA-Z][a-zA-Z0-9]+):") 9 | 10 | (defn- fix-namespace 11 | "Changes the namespace of a function call from pkg:fn to ns/fn. If 12 | no pkg exists, then nothing is done." 13 | ([text] (.replaceAll (re-matcher namespace-re text) "$1/"))) 14 | 15 | (defn write-swank-message 16 | "Given a `writer' (java.io.Writer) and a `message' (typically an 17 | sexp), encode the message according to the swank protocol and 18 | write the message into the writer." 19 | ([#^java.io.Writer writer message] 20 | (swank.rpc/encode-message writer message)) 21 | {:tag String}) 22 | 23 | (def read-fail-exception (Exception. "Error reading swank message")) 24 | 25 | (defn read-swank-message 26 | "Given a `reader' (java.io.Reader), read the message as a clojure 27 | form (typically a sexp). This method will block until a message is 28 | completely transfered. 29 | 30 | Note: This function will do some amount of Common Lisp -> clojure 31 | conversions. This is due to the fact that several slime functions 32 | like to treat everything it's talking to as a common lisp 33 | implementation. 34 | - If an :emacs-rex form is received and the first form contains a 35 | common lisp package designation, this will convert it to use a 36 | clojure designation. 37 | - t will be converted to true 38 | 39 | See also `write-swank-message'." 40 | ([#^java.io.Reader reader] 41 | (let [;; replaceAll needed for apparent bug with Emacs 24 42 | len-str (.replaceAll #^String (read-chars reader 6 read-fail-exception) " " "0") 43 | len (Integer/parseInt len-str 16) 44 | msg (read-chars reader len read-fail-exception) 45 | form (try 46 | (read-string (fix-namespace msg)) 47 | (catch Exception ex 48 | (.println System/err (format "unreadable message: %s" msg)) 49 | (throw ex)))] 50 | (if (seq? form) 51 | (deep-replace {'t true} form) 52 | form)))) 53 | -------------------------------------------------------------------------------- /src/swank/core/server.clj: -------------------------------------------------------------------------------- 1 | (ns swank.core.server 2 | (:use (swank util core) 3 | (swank.util sys io) 4 | (swank.util.concurrent thread) 5 | (swank.util.net sockets) 6 | (swank.core connection protocol)) 7 | (:import (java.io File FileReader BufferedReader PrintWriter 8 | InputStreamReader OutputStreamWriter) 9 | (java.net Socket))) 10 | 11 | ;; The swank.core.server is the layer above swank.util.net.sockets 12 | ;; - Manages the socket server 13 | ;; - Accepts and authenticates incoming connections 14 | ;; - Creates swank.core.connections 15 | ;; - Spins up new threads 16 | 17 | (defonce connections (ref [])) 18 | 19 | (def slime-secret-path (str (user-home-path) File/separator ".slime-secret")) 20 | 21 | (defn- slime-secret 22 | "Returns the first line from the slime-secret file, path found in 23 | slime-secret-path (default: .slime-secret in the user's home 24 | directory). 25 | 26 | See also: `accept-authenticated-connection'" 27 | ([] (failing-gracefully 28 | (let [slime-secret-file (File. 29 | (str (user-home-path) File/separator ".slime-secret"))] 30 | (when (and (.isFile slime-secret-file) (.canRead slime-secret-file)) 31 | (with-open [secret (BufferedReader. (FileReader. slime-secret-file))] 32 | (.readLine secret))))))) 33 | 34 | (defn make-output-redirection 35 | ([conn & slime-output-target] 36 | (let [slime-output-target (if slime-output-target 37 | (first slime-output-target))] 38 | (call-on-flush-stream 39 | #(with-connection conn 40 | (send-to-emacs `(:write-string ~% ~slime-output-target))))) 41 | ) 42 | {:tag java.io.StringWriter}) 43 | 44 | ;; rename to authenticate-socket, takes in a connection 45 | (defn- accept-authenticated-connection 46 | "Accepts and returns new connection if it is from an authenticated 47 | machine. Otherwise, return nil. 48 | 49 | Authentication depends on the contents of a slime-secret file on 50 | both the server (swank) and the client (emacs slime). If no 51 | slime-secret file is provided on the server side, all connections 52 | are accepted. 53 | 54 | See also: `slime-secret'" 55 | ([#^Socket socket opts] 56 | (returning [conn (make-connection socket (or (:encoding opts) 57 | (System/getProperty 58 | "swank.encoding" 59 | "utf-8-unix")))] 60 | (when (:repl-out-root opts) 61 | (alter-var-root #'*out* (constantly 62 | (PrintWriter. 63 | (make-output-redirection conn)))) 64 | (alter-var-root #'*err* (constantly 65 | (PrintWriter. 66 | (make-output-redirection conn))))) 67 | (if-let [secret (slime-secret)] 68 | (when-not (= (read-from-connection conn) secret) 69 | (close-socket! socket)) 70 | conn)))) 71 | 72 | (defn- socket-serve [connection-serve socket opts] 73 | (with-connection (accept-authenticated-connection socket opts) 74 | (let [out-redir (java.io.PrintWriter. (make-output-redirection 75 | *current-connection*))] 76 | (binding [*out* out-redir 77 | *err* out-redir] 78 | (dosync (ref-set (*current-connection* :writer-redir) *out*)) 79 | (dosync (alter connections conj *current-connection*)) 80 | (connection-serve *current-connection*))))) 81 | 82 | ;; Setup frontent 83 | (defn start-swank-socket-server! 84 | "Starts and returns the socket server as a swank host. Takes an 85 | optional set of options as a map: 86 | 87 | :announce - an fn that will be called and provided with the 88 | listening port of the newly established server. Default: none." 89 | ([server connection-serve] (start-swank-socket-server! connection-serve {})) 90 | ([server connection-serve options] 91 | (start-server-socket! server connection-serve) 92 | (when-let [announce (options :announce)] 93 | (announce options)) 94 | server)) 95 | 96 | (defn setup-server 97 | "The port it started on will be called as an argument to (announce-fn 98 | port). A connection will then be created and (connection-serve conn) 99 | will then be called." 100 | [port announce-fn connection-serve opts] 101 | (start-swank-socket-server! 102 | (make-server-socket {:port port 103 | :host (opts :host "localhost") 104 | :backlog (opts :backlog 0)}) 105 | #(socket-serve connection-serve % opts) 106 | (merge {:announce announce-fn} opts))) 107 | 108 | ;; Announcement functions 109 | (defn simple-announce [{:keys [message host port] :as opts}] 110 | (println (or message (format "Connection opened on %s port %s." host port)))) 111 | -------------------------------------------------------------------------------- /src/swank/core/threadmap.clj: -------------------------------------------------------------------------------- 1 | (ns swank.core.threadmap 2 | (:use (swank util) 3 | (swank.util.concurrent thread))) 4 | 5 | (defonce thread-map-next-id (ref 1)) 6 | (defonce thread-map (ref {})) 7 | 8 | (defn- thread-map-clean [] 9 | (doseq [[id t] @thread-map] 10 | (when (or (nil? t) 11 | (not (thread-alive? t))) 12 | (dosync 13 | (alter thread-map dissoc id))))) 14 | 15 | (defn- get-thread-id [thread] 16 | (if-let [entry (find-first #(= (val %) thread) @thread-map)] 17 | (key entry) 18 | (let [next-id @thread-map-next-id] 19 | (alter thread-map assoc next-id thread) 20 | (alter thread-map-next-id inc) 21 | next-id))) 22 | 23 | (defn thread-map-id [thread] 24 | (returning [id (dosync (get-thread-id thread))] 25 | (thread-map-clean))) 26 | 27 | (defn find-thread [id] 28 | (@thread-map id)) 29 | 30 | -------------------------------------------------------------------------------- /src/swank/dev.clj: -------------------------------------------------------------------------------- 1 | (ns swank.dev 2 | (:use (swank util))) 3 | 4 | ;;; TODO determine if this is used anywhere in 3rd party code. 5 | ;;; Swank-clojure does NOT use it. 6 | (defmacro with-swank-io [& body] 7 | `(binding [*out* @(:writer-redir (first @swank.core.server/connections))] 8 | ~@body)) 9 | -------------------------------------------------------------------------------- /src/swank/loader.clj: -------------------------------------------------------------------------------- 1 | (ns swank.loader 2 | (:require [swank.util.sys :as sys] 3 | [swank.util.clojure :as clj]) 4 | (:import [java.io File])) 5 | 6 | (defonce #^File *swank-source-path* 7 | (if-let [resource (.getResource (clojure.lang.RT/baseLoader) 8 | #^String *file*)] 9 | (.getParentFile (File. (.getFile resource))))) 10 | 11 | (defonce #^File *swank-compile-path* 12 | (File. (str (sys/user-home-path) 13 | File/separator 14 | ".slime" 15 | File/separator 16 | "cljclass"))) 17 | 18 | (defn file-directory? [#^File f] 19 | (.isDirectory f)) 20 | 21 | (defn file-last-modified [#^File f] 22 | (.lastModified f)) 23 | 24 | (defn all-files-in-directory [#^File f] 25 | (let [list-files (.listFiles f) 26 | files (remove file-directory? list-files) 27 | directories (filter file-directory? list-files)] 28 | (concat files (mapcat all-files-in-directory directories)))) 29 | 30 | (defn clj-file? [#^File f] 31 | (.endsWith (str f) ".clj")) 32 | 33 | (defn swank-source-files [#^File path] 34 | (filter clj-file? (all-files-in-directory path))) 35 | 36 | (defn relative-path-name [#^File parent #^File file] 37 | (let [file-name (str file) 38 | parent-name (str parent)] 39 | (when (.startsWith file-name parent-name) 40 | (.substring file-name (inc (.length parent-name)))))) 41 | 42 | (defn file-name-to-swank-package-sym [#^String file-name] 43 | (assert (clj-file? file-name)) 44 | (symbol 45 | (str "swank." 46 | (clj/unmunge 47 | (.replaceAll (.substring file-name 0 (- (.length file-name) 4)) 48 | File/separator 49 | "."))))) 50 | 51 | (defn swank-packages [] 52 | (map #(file-name-to-swank-package-sym (relative-path-name *swank-source-path* %)) 53 | (swank-source-files *swank-source-path*))) 54 | 55 | (defn swank-version 56 | "A likely bad way of calculating a version number for swank clojure" 57 | ([] 58 | (str (reduce + (map file-last-modified (swank-source-files *swank-source-path*))) 59 | "+" (clojure-version)))) 60 | 61 | (defn delete-file-recursive [& paths] 62 | (when-not (empty? paths) 63 | (let [f #^File (first paths)] 64 | (if (and f (.exists f)) 65 | (if (.isDirectory f) 66 | (if-let [files (seq (.listFiles f))] 67 | (recur (concat files paths)) 68 | (do 69 | (.delete f) 70 | (recur (rest paths)))) 71 | (do 72 | (.delete f) 73 | (recur (rest paths)))) 74 | (recur (rest paths)))))) 75 | 76 | (defn clean-up [] 77 | (let [current-path (File. *swank-compile-path* (str (swank-version)))] 78 | (doseq [compiled-path (.listFiles *swank-compile-path*) 79 | :when (not= current-path compiled-path)] 80 | (delete-file-recursive compiled-path)))) 81 | 82 | (defn swank-ns? [ns] 83 | (.startsWith (name (ns-name ns)) "swank.")) 84 | 85 | (defn all-swank-ns [] 86 | (filter swank-ns? (all-ns))) 87 | 88 | (defn compile-swank [#^String path] 89 | (binding [*compile-path* path] 90 | (doseq [sym (swank-packages)] 91 | (println "Compiling" (name sym)) 92 | (compile sym)))) 93 | 94 | (defn init [] 95 | (let [path (File. *swank-compile-path* (str (swank-version))) 96 | path-already-exists? (.exists path)] 97 | (when-not path-already-exists? 98 | (.mkdirs path)) 99 | (add-classpath (-> path .toURI .toURL)) 100 | (when-not path-already-exists? 101 | (compile-swank (str path))))) 102 | -------------------------------------------------------------------------------- /src/swank/payload/slime-compile-presave.el: -------------------------------------------------------------------------------- 1 | ;;; slime-compile-presave.el --- Refuse to save non-compiling Slime buffers 2 | 3 | ;; Copyright © 2011 Phil Hagelberg 4 | ;; 5 | ;; Authors: Phil Hagelberg 6 | ;; URL: http://github.com/technomancy/swank-clojure 7 | ;; Version: 1.0.0 8 | ;; Keywords: languages, lisp 9 | 10 | ;; This file is not part of GNU Emacs. 11 | 12 | ;;; Code: 13 | 14 | (defvar slime-compile-presave? nil 15 | "Refuse to save slime-enabled buffers if they don't compile.") 16 | 17 | ;;;###autoload 18 | (defun slime-compile-presave-toggle () 19 | (interactive) 20 | (message "slime-compile-presave %s." 21 | (if (setq slime-compile-presave? (not slime-compile-presave?)) 22 | "enabled" "disabled"))) 23 | 24 | ;;;###autoload 25 | (defun slime-compile-presave-enable () 26 | (make-local-variable 'before-save-hook) 27 | (add-hook 'before-save-hook (defun slime-compile-presave () 28 | (when slime-compile-presave? 29 | (slime-eval `(swank:eval-and-grab-output 30 | ,(buffer-substring-no-properties 31 | (point-min) (point-max)))))))) 32 | 33 | ;;;###autoload 34 | (add-hook 'slime-mode-hook 'slime-compile-presave-enable) 35 | 36 | (provide 'slime-compile-presave) 37 | ;;; slime-compile-presave.el ends here 38 | -------------------------------------------------------------------------------- /src/swank/payload/slime-eldoc.el: -------------------------------------------------------------------------------- 1 | (require 'eldoc) 2 | (defun clojure-slime-eldoc-message () 3 | (when (and (featurep 'slime) 4 | (slime-background-activities-enabled-p)) 5 | (slime-echo-arglist) ; async, return nil for now 6 | nil)) 7 | 8 | (defun clojure-localize-documentation-function () 9 | (set (make-local-variable 'eldoc-documentation-function) 10 | 'clojure-slime-eldoc-message)) 11 | 12 | (add-hook 'slime-mode-hook 'clojure-localize-documentation-function) 13 | -------------------------------------------------------------------------------- /src/swank/payload/slime-frame-colors.el: -------------------------------------------------------------------------------- 1 | (require 'ansi-color) 2 | 3 | (defadvice sldb-insert-frame (around colorize-clj-trace (frame &optional face)) 4 | (progn 5 | (ad-set-arg 0 (list (sldb-frame.number frame) 6 | (ansi-color-apply (sldb-frame.string frame)) 7 | (sldb-frame.plist frame))) 8 | ad-do-it 9 | (save-excursion 10 | (forward-line -1) 11 | (skip-chars-forward "0-9 :") 12 | (let ((beg-line (point))) 13 | (end-of-line) 14 | (remove-text-properties beg-line (point) '(face nil)))))) 15 | 16 | (ad-activate #'sldb-insert-frame) 17 | 18 | (provide 'slime-frame-colors) 19 | -------------------------------------------------------------------------------- /src/swank/payload/slime.el: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/technomancy/swank-clojure/1000bbd0a035c923e1bf98fecdc9162a282ecea3/src/swank/payload/slime.el -------------------------------------------------------------------------------- /src/swank/rpc.clj: -------------------------------------------------------------------------------- 1 | ;;; This code has been placed in the Public Domain. All warranties are disclaimed. 2 | (ns #^{:doc "Pass remote calls and responses between lisp systems using the swank-rpc protocol." 3 | :author "Terje Norderhaug "} 4 | swank.rpc 5 | (:use (swank util) 6 | (swank.util io)) 7 | (:import (java.io Writer Reader PushbackReader StringReader))) 8 | 9 | ;; ERROR HANDLING 10 | 11 | (def swank-protocol-error (Exception. "Swank protocol error.")) 12 | 13 | ;; LOGGING 14 | 15 | (def log-events false) 16 | 17 | (def log-output nil) 18 | 19 | (defn log-event [format-string & args] 20 | (when log-events 21 | (let [#^Writer out (or log-output *out*)] 22 | (.write out #^String (apply format format-string args)) 23 | (.flush out)) 24 | nil)) 25 | 26 | ;; INPUT 27 | 28 | (defn- read-form 29 | "Read a form that conforms to the swank rpc protocol" 30 | ([#^Reader rdr] 31 | (let [c (.read rdr)] 32 | (condp = (char c) 33 | \" (let [sb (StringBuilder.)] 34 | (loop [] 35 | (let [c (.read rdr)] 36 | (if (= c -1) 37 | (throw (java.io.EOFException. "Incomplete reading of quoted string.")) 38 | (condp = (char c) 39 | \" (str sb) 40 | \\ (do (.append sb (char (.read rdr))) 41 | (recur)) 42 | (do (.append sb (char c)) 43 | (recur))))))) 44 | \( (loop [result []] 45 | (let [form (read-form rdr)] 46 | (let [c (.read rdr)] 47 | (if (= c -1) 48 | (throw (java.io.EOFException. "Incomplete reading of list.")) 49 | (condp = (char c) 50 | \) (sequence (conj result form)) 51 | \space (recur (conj result form))))))) 52 | \' (list 'quote (read-form rdr)) 53 | (let [sb (StringBuilder.)] 54 | (loop [c c] 55 | (if (not= c -1) 56 | (condp = (char c) 57 | \\ (do (.append sb (char (.read rdr))) 58 | (recur (.read rdr))) 59 | \space (.unread #^PushbackReader rdr c) 60 | \) (.unread #^PushbackReader rdr c) 61 | (do (.append sb (char c)) 62 | (recur (.read rdr)))))) 63 | (let [str (str sb)] 64 | (cond 65 | (. Character isDigit c) (Integer/parseInt str) 66 | (= "nil" str) nil 67 | (= "t" str) true 68 | :else (symbol str)))))))) 69 | 70 | (defn- read-packet 71 | ([#^Reader reader] 72 | (let [len (Integer/parseInt (read-chars reader 6 swank-protocol-error) 16)] 73 | (read-chars reader len swank-protocol-error)))) 74 | 75 | (defn decode-message 76 | "Read an rpc message encoded using the swank rpc protocol." 77 | ([#^Reader rdr] 78 | (let [packet (read-packet rdr)] 79 | (log-event "READ: %s\n" packet) 80 | (try 81 | (with-open [rdr (PushbackReader. (StringReader. packet))] 82 | (read-form rdr)) 83 | (catch Exception e 84 | (list :reader-error packet e)))))) 85 | 86 | ; (with-open [rdr (StringReader. "00001f(swank:a 123 (%b% (t nil) \"c\"))")] (decode-message rdr)) 87 | 88 | 89 | ;; OUTPUT 90 | 91 | (defmulti print-object (fn [x writer] (type x))) 92 | 93 | (defmethod print-object :default [o, #^Writer w] 94 | (print-method o w)) 95 | 96 | (defmethod print-object Boolean [o, #^Writer w] 97 | (.write w (if o "t" "nil"))) 98 | 99 | (defmethod print-object String [#^String s, #^Writer w] 100 | (let [char-escape-string {\" "\\\"" 101 | \\ "\\\\"}] 102 | (do (.append w \") 103 | (dotimes [n (count s)] 104 | (let [c (.charAt s n) 105 | e (char-escape-string c)] 106 | (if e (.write w #^String e) (.append w c)))) 107 | (.append w \")) 108 | nil)) 109 | 110 | (defmethod print-object clojure.lang.ISeq [o, #^Writer w] 111 | (.write w "(") 112 | (print-object (first o) w) 113 | (doseq [item (rest o)] 114 | (.write w " ") 115 | (print-object item w)) 116 | (.write w ")")) 117 | 118 | (defn- write-form 119 | ([#^Writer writer message] 120 | (print-object message writer))) 121 | 122 | (defn- write-packet 123 | ([#^Writer writer #^String str] 124 | (let [len (.length str)] 125 | (doto writer 126 | (.write (format "%06x" len)) 127 | (.write str) 128 | (.flush))))) 129 | 130 | (defn encode-message 131 | "Write an rpc message encoded using the swank rpc protocol." 132 | ([#^Writer writer message] 133 | (let [str (with-out-str 134 | (write-form *out* message)) ] 135 | (log-event "WRITE: %s\n" str) 136 | (write-packet writer str)))) 137 | 138 | ; (with-out-str (encode-message *out* "hello")) 139 | ; (with-out-str (encode-message *out* '(a 123 (swank:b (true false) "c")))) 140 | 141 | 142 | ;; DISPATCH 143 | 144 | (defonce rpc-fn-map {}) 145 | 146 | (defn register-dispatch 147 | ([name fn] 148 | (register-dispatch name fn #'rpc-fn-map)) 149 | ([name fn fn-map] 150 | (alter-var-root fn-map assoc name fn))) 151 | 152 | (defn dispatch-message 153 | ([message fn-map] 154 | (let [operation (first message) 155 | operands (rest message) 156 | fn (fn-map operation)] 157 | (assert fn) 158 | (apply fn operands))) 159 | ([message] 160 | (dispatch-message message rpc-fn-map))) 161 | -------------------------------------------------------------------------------- /src/swank/swank.clj: -------------------------------------------------------------------------------- 1 | (ns swank.swank 2 | (:use [swank core util] 3 | [swank.core connection server] 4 | [swank.util.concurrent thread] 5 | [swank.util.net sockets] 6 | [swank.commands.basic :only [get-thread-list]] 7 | [clojure.main :only [repl]]) 8 | (:require [swank.commands] 9 | [swank.commands basic indent completion 10 | contrib inspector]) 11 | (:import [java.lang System Thread] 12 | [java.io File]) 13 | (:gen-class)) 14 | 15 | (def current-server (atom nil)) 16 | 17 | (defn ignore-protocol-version [version] 18 | (reset! protocol-version version)) 19 | 20 | (defn- connection-serve [conn] 21 | (let [#^Thread control 22 | (dothread-swank 23 | (thread-set-name "Swank Control Thread") 24 | (try 25 | (control-loop conn) 26 | (catch Exception e 27 | (when-not @shutting-down? 28 | (.println System/err "exception in control loop") 29 | (.printStackTrace e)) 30 | nil)) 31 | (close-socket! (conn :socket))) 32 | read 33 | (dothread-swank 34 | (thread-set-name "Swank Read Loop Thread") 35 | (try 36 | (read-loop conn control) 37 | (catch Exception e 38 | ;; This could be put somewhere better 39 | (when-not @shutting-down? 40 | (.println System/err "exception in read loop") 41 | (.printStackTrace e) 42 | (.interrupt control) 43 | (dosync (alter connections (partial remove #{conn})))))))] 44 | (dosync 45 | (ref-set (conn :control-thread) control) 46 | (ref-set (conn :read-thread) read)))) 47 | 48 | (defn load-cdt-with-dynamic-classloader [] 49 | ;; cdt requires a dynamic classloader for tools.jar add-classpath 50 | ;; lein swank doesn't seem to provide one. Loading the backend 51 | ;; like this works around that problem. 52 | (.start (Thread. #(do (use 'swank.core.cdt-backends) 53 | (eval '(cdt-backend-init)))))) 54 | 55 | (defn start-server 56 | "Start the server and write the listen port number to 57 | PORT-FILE. This is the entry point for Emacs." 58 | [& opts] 59 | (if @current-server 60 | (println System/err "Swank server already running") 61 | (do 62 | (reset! shutting-down? false) 63 | (let [opts (apply hash-map opts)] 64 | (reset! color-support? (:colors? opts false)) 65 | (reset! exit-on-quit? (:exit-on-quit opts true)) 66 | (when (:load-cdt-on-startup opts) 67 | (load-cdt-with-dynamic-classloader)) 68 | (reset! current-server 69 | (setup-server (get opts :port 0) 70 | simple-announce 71 | connection-serve 72 | opts)) 73 | (when (:block opts) 74 | (doseq [#^Thread t (get-thread-list)] 75 | (.join t))))))) 76 | 77 | (defn stop-server 78 | "Stop the currently running server, shutdown its threads, and release the port." 79 | [] 80 | (if @current-server 81 | (do 82 | (reset! shutting-down? true) 83 | (doseq [c @connections] 84 | (doseq [t [:control-thread :read-thread :repl-thread]] 85 | (when-let [^Thread thread @(c t)] 86 | (.interrupt thread)))) 87 | (close-server-socket! @current-server) 88 | (dosync (ref-set connections [])) 89 | (reset! current-server nil)) 90 | (println System/err "Swank server not running"))) 91 | 92 | (defn start-repl 93 | "Start the server wrapped in a repl. Use this to embed swank in your code." 94 | ([port & opts] 95 | (let [stop (atom false) 96 | port (if (string? port) (Integer/parseInt port) (int port)) 97 | opts (assoc (apply hash-map opts) :port port)] 98 | (repl :read (fn [rprompt rexit] 99 | (if @stop rexit 100 | (do (reset! stop true) 101 | `(start-server ~@(apply concat opts))))) 102 | :need-prompt (constantly false)))) 103 | ([] (start-repl (or (System/getenv "PORT") 4005)))) 104 | 105 | (defn -main [port & opts] 106 | (apply start-server 107 | (for [a (concat [":port" port] opts)] 108 | (cond (re-find #"^\d+$" a) (Integer/parseInt a) 109 | (re-find #"^:\w+$" a) (keyword (subs a 1)) 110 | :else a)))) 111 | -------------------------------------------------------------------------------- /src/swank/util.clj: -------------------------------------------------------------------------------- 1 | (ns swank.util 2 | (:import (java.io StringReader) 3 | (clojure.lang LineNumberingPushbackReader))) 4 | 5 | (def shutting-down? (atom false)) 6 | 7 | (defmacro one-of? 8 | "Short circuiting value comparison." 9 | ([val & possible] 10 | (let [v (gensym)] 11 | `(let [~v ~val] 12 | (or ~@(map (fn [p] `(= ~v ~p)) possible)))))) 13 | 14 | (defn find-first 15 | "Returns the first entry in a coll matches a given predicate." 16 | ([coll] (find-first identity coll)) 17 | ([pred coll] 18 | (first (filter pred coll)))) 19 | 20 | (defn position 21 | "Finds the first position of an item that matches a given predicate 22 | within col. Returns nil if not found. Optionally provide a start 23 | offset to search from." 24 | ([pred coll] (position pred coll 0)) 25 | ([pred coll start] 26 | (loop [coll (drop start coll), i start] 27 | (when (seq coll) 28 | (if (pred (first coll)) 29 | i 30 | (recur (rest coll) (inc i)))))) 31 | {:tag Integer}) 32 | 33 | (when-not (ns-resolve 'clojure.core 'group-by) 34 | ;; TODO: not sure why eval is necessary here; breaks without it. 35 | (eval '(defn group-by 36 | "Categorizes elements within a coll into a map based on a function." 37 | ([f coll] 38 | (reduce 39 | (fn [ret x] 40 | (let [k (f x)] 41 | (assoc ret k (conj (get ret k []) x)))) 42 | {}))))) 43 | 44 | (when-not (ns-resolve 'clojure.core 'flatten) 45 | (eval '(defn flatten [x] 46 | (filter (complement sequential?) 47 | (rest (tree-seq sequential? seq x)))))) 48 | 49 | (defmacro returning [[var ret] & body] 50 | `(let [~var ~ret] 51 | ~@body 52 | ~var)) 53 | 54 | 55 | (defn deep-replace [smap coll] 56 | (map #(if (or (seq? %) (vector? %)) 57 | (deep-replace smap %) 58 | %) 59 | (replace smap coll))) 60 | 61 | (defmacro keep-bindings [bindings f] 62 | (let [bind-vars (take (count bindings) (repeatedly gensym))] 63 | `(let [~@(interleave bind-vars bindings)] 64 | (fn [& args#] 65 | (binding [~@(interleave bindings bind-vars)] 66 | (apply ~f args#)))))) 67 | 68 | (defmacro continuously [& body] 69 | `(loop [] ~@body (when-not @shutting-down? (recur)))) 70 | 71 | (defmacro failing-gracefully [& body] 72 | `(try 73 | ~@body 74 | (catch Throwable _# nil))) 75 | -------------------------------------------------------------------------------- /src/swank/util/class_browse.clj: -------------------------------------------------------------------------------- 1 | ;;; class-browse.clj -- Java classpath and Clojure namespace browsing 2 | 3 | ;; by Jeff Valk 4 | ;; created 2009-10-14 5 | 6 | ;; Scans the classpath for all class files, and provides functions for 7 | ;; categorizing them. 8 | 9 | ;; See the following for JVM classpath and wildcard expansion rules: 10 | ;; http://java.sun.com/javase/6/docs/technotes/tools/findingclasses.html 11 | ;; http://java.sun.com/javase/6/docs/technotes/tools/solaris/classpath.html 12 | 13 | (ns swank.util.class-browse 14 | "Provides Java classpath and (compiled) Clojure namespace browsing. 15 | Scans the classpath for all class files, and provides functions for 16 | categorizing them. Classes are resolved on the start-up classpath only. 17 | Calls to 'add-classpath', etc are not considered. 18 | 19 | Class information is built as a list of maps of the following keys: 20 | :name Java class or Clojure namespace name 21 | :loc Classpath entry (directory or jar) on which the class is located 22 | :file Path of the class file, relative to :loc" 23 | (:import [java.io File FilenameFilter] 24 | [java.util StringTokenizer] 25 | [java.util.jar JarFile JarEntry] 26 | [java.util.regex Pattern])) 27 | 28 | ;;; Class file naming, categorization 29 | 30 | (defn jar-file? [#^String n] (.endsWith n ".jar")) 31 | (defn class-file? [#^String n] (.endsWith n ".class")) 32 | (defn clojure-ns-file? [#^String n] (.endsWith n "__init.class")) 33 | (defn clojure-fn-file? [#^String n] (re-find #"\$.*__\d+\.class" n)) 34 | (defn top-level-class-file? [#^String n] (re-find #"^[^\$]+\.class" n)) 35 | (defn nested-class-file? [#^String n] 36 | ;; ^ excludes anonymous classes 37 | (re-find #"^[^\$]+(\$[^\d]\w*)+\.class" n)) 38 | 39 | (def clojure-ns? (comp clojure-ns-file? :file)) 40 | (def clojure-fn? (comp clojure-fn-file? :file)) 41 | (def top-level-class? (comp top-level-class-file? :file)) 42 | (def nested-class? (comp nested-class-file? :file)) 43 | 44 | (defn class-or-ns-name 45 | "Returns the Java class or Clojure namespace name for a class relative path." 46 | [#^String n] 47 | (.replace 48 | (if (clojure-ns-file? n) 49 | (-> n (.replace "__init.class" "") (.replace "_" "-")) 50 | (.replace n ".class" "")) 51 | File/separator ".")) 52 | 53 | (defn jar-entry-name [#^JarEntry entry] 54 | (-> (File. (.getName entry)) (.getPath))) 55 | 56 | ;;; Path scanning 57 | 58 | (defmulti path-class-files 59 | "Returns a list of classes found on the specified path location 60 | (jar or directory), each comprised of a map with the following keys: 61 | :name Java class or Clojure namespace name 62 | :loc Classpath entry (directory or jar) on which the class is located 63 | :file Path of the class file, relative to :loc" 64 | (fn [#^ File f _] 65 | (cond (.isDirectory f) :dir 66 | (jar-file? (.getName f)) :jar 67 | (class-file? (.getName f)) :class))) 68 | 69 | (defmethod path-class-files :default 70 | [& _] []) 71 | 72 | (defmethod path-class-files :jar 73 | ;; Build class info for all jar entry class files. 74 | [#^File f #^File loc] 75 | (let [lp (.getPath loc)] 76 | (try 77 | (map (fn [fp] {:loc lp :file fp :name (class-or-ns-name fp)}) 78 | (filter class-file? 79 | (map jar-entry-name 80 | (enumeration-seq (.entries (JarFile. f)))))) 81 | (catch Exception e [])))) ; fail gracefully if jar is unreadable 82 | 83 | (defmethod path-class-files :dir 84 | ;; Dispatch directories and files (excluding jars) recursively. 85 | [#^File d #^File loc] 86 | (let [fs (.listFiles d (proxy [FilenameFilter] [] 87 | (accept [d n] (not (jar-file? n)))))] 88 | (reduce concat (for [f fs] (path-class-files f loc))))) 89 | 90 | (defmethod path-class-files :class 91 | ;; Build class info using file path relative to parent classpath entry 92 | ;; location. Make sure it decends; a class can't be on classpath directly. 93 | [#^File f #^File loc] 94 | (let [fp (.getPath f), lp (.getPath loc) 95 | m (re-matcher (re-pattern (Pattern/quote 96 | (str "^" lp File/separator))) fp)] 97 | (if (not (.find m)) ; must be descendent of loc 98 | [] 99 | (let [fpr (.substring fp (.end m))] 100 | [{:loc lp :file fpr :name (class-or-ns-name fpr)}])))) 101 | 102 | ;;; Classpath expansion 103 | 104 | (def java-version 105 | (Float/parseFloat (.substring (System/getProperty "java.version") 0 3))) 106 | 107 | (defn expand-wildcard 108 | "Expands a wildcard path entry to its matching .jar files (JDK 1.6+). 109 | If not expanding, returns the path entry as a single-element vector." 110 | [#^String path] 111 | (let [f (File. path)] 112 | (if (and (= (.getName f) "*") (>= java-version 1.6)) 113 | (-> f .getParentFile 114 | (.list (proxy [FilenameFilter] [] 115 | (accept [d n] (jar-file? n))))) 116 | [f]))) 117 | 118 | (defn scan-paths 119 | "Takes one or more classpath strings, scans each classpath entry location, and 120 | returns a list of all class file paths found, each relative to its parent 121 | directory or jar on the classpath." 122 | ([cp] 123 | (if cp 124 | (let [entries (enumeration-seq 125 | (StringTokenizer. cp File/pathSeparator)) 126 | locs (mapcat expand-wildcard entries)] 127 | (reduce concat (for [loc locs] (path-class-files loc loc)))) 128 | ())) 129 | ([cp & more] 130 | (reduce #(concat %1 (scan-paths %2)) (scan-paths cp) more))) 131 | 132 | ;;; Class browsing 133 | 134 | (def available-classes 135 | (filter (complement clojure-fn?) ; omit compiled clojure fns 136 | (scan-paths (System/getProperty "sun.boot.class.path") 137 | (System/getProperty "java.ext.dirs") 138 | (System/getProperty "java.class.path")))) 139 | 140 | ;; Force lazy seqs before any user calls, and in background threads; there's 141 | ;; no sense holding up SLIME init. (It's usually quick, but a monstrous 142 | ;; classpath could concievably take a while.) 143 | 144 | (def top-level-classes 145 | (future (doall (map (comp class-or-ns-name :name) 146 | (filter top-level-class? 147 | available-classes))))) 148 | 149 | (def nested-classes 150 | (future (doall (map (comp class-or-ns-name :name) 151 | (filter nested-class? 152 | available-classes))))) 153 | -------------------------------------------------------------------------------- /src/swank/util/clj_stacktrace_compat.clj: -------------------------------------------------------------------------------- 1 | (ns swank.util.clj-stacktrace-compat 2 | "This is an ugly hack to support older version of clj-stacktrace 3 | that are often pulled in by other libs as a dep." 4 | (:require [clj-stacktrace.repl :as repl]) 5 | (:require [clj-stacktrace.utils :as utils])) 6 | 7 | (if (ns-resolve 'clj-stacktrace.repl 'pst-elem-str) 8 | (def pst-elem-str (ns-resolve 'clj-stacktrace.repl 'pst-elem-str)) 9 | (let [colored (ns-resolve 'clj-stacktrace.repl 'colored)] 10 | (defn pst-elem-str 11 | [color? parsed-elem print-width] 12 | (colored color? (clj-stacktrace.repl/elem-color parsed-elem) 13 | (str (utils/rjust print-width 14 | (clj-stacktrace.repl/source-str parsed-elem)) 15 | " " (clj-stacktrace.repl/method-str parsed-elem)))))) 16 | 17 | (def find-source-width (ns-resolve 'clj-stacktrace.repl 'find-source-width)) 18 | -------------------------------------------------------------------------------- /src/swank/util/clojure.clj: -------------------------------------------------------------------------------- 1 | (ns swank.util.clojure) 2 | 3 | (defn unmunge 4 | "Converts a javafied name to a clojure symbol name" 5 | ([#^String name] 6 | (reduce (fn [#^String s [to from]] 7 | (.replaceAll s from (str to))) 8 | name 9 | clojure.lang.Compiler/CHAR_MAP))) 10 | 11 | (defn ns-path 12 | "Returns the path form of a given namespace" 13 | ([#^clojure.lang.Namespace ns] 14 | (let [#^String ns-str (name (ns-name ns))] 15 | (-> ns-str 16 | (.substring 0 (.lastIndexOf ns-str ".")) 17 | (.replace \- \_) 18 | (.replace \. \/))))) 19 | 20 | (defn symbol-name-parts 21 | "Parses a symbol name into a namespace and a name. If name doesn't 22 | contain a namespace, the default-ns is used (nil if none provided)." 23 | ([symbol] 24 | (symbol-name-parts symbol nil)) 25 | ([#^String symbol default-ns] 26 | (let [ns-pos (.indexOf symbol (int \/))] 27 | (if (= ns-pos -1) ;; namespace found? 28 | [default-ns symbol] 29 | [(.substring symbol 0 ns-pos) (.substring symbol (inc ns-pos))])))) 30 | 31 | (defn resolve-ns [sym ns] 32 | (or (find-ns sym) 33 | (get (ns-aliases ns) sym))) -------------------------------------------------------------------------------- /src/swank/util/concurrent/mbox.clj: -------------------------------------------------------------------------------- 1 | (ns swank.util.concurrent.mbox 2 | (:refer-clojure :exclude [send get])) 3 | 4 | ;; Holds references to the mailboxes (message queues) 5 | (defonce mailboxes (ref {})) 6 | 7 | (defn get 8 | "Returns the mailbox for a given id. Creates one if one does not 9 | already exist." 10 | ([id] 11 | (dosync 12 | (when-not (@mailboxes id) 13 | (alter mailboxes assoc 14 | id (java.util.concurrent.LinkedBlockingQueue.)))) 15 | (@mailboxes id)) 16 | {:tag java.util.concurrent.LinkedBlockingQueue}) 17 | 18 | (defn send 19 | "Sends a message to a given id." 20 | ([id message] 21 | (let [mbox (get id)] 22 | (.put mbox message)))) 23 | 24 | (defn receive 25 | "Blocking recieve for messages for the given id." 26 | ([id] 27 | (let [mb (get id)] 28 | (.take mb)))) 29 | 30 | (defn clean [] 31 | ) 32 | -------------------------------------------------------------------------------- /src/swank/util/concurrent/thread.clj: -------------------------------------------------------------------------------- 1 | (ns swank.util.concurrent.thread 2 | (:use (swank util)) 3 | (:import (java.lang.Thread))) 4 | 5 | (def #^{:dynamic true} *new-thread-group* nil) 6 | 7 | (defn- gen-name [] 8 | (name (gensym "Thread-"))) 9 | 10 | (defn start-thread 11 | "Starts a thread that run the given function f" 12 | ([#^Runnable f] 13 | (let [t (if *new-thread-group* 14 | (Thread. #^ThreadGroup *new-thread-group* f) 15 | (Thread. f))] 16 | (.start t) 17 | t))) 18 | 19 | (defmacro dothread [& body] 20 | `(start-thread (fn [] ~@body))) 21 | 22 | (defmacro dothread-keeping [bindings & body] 23 | `(start-thread (keep-bindings ~bindings (fn [] ~@body)))) 24 | 25 | (defmacro dothread-keeping-clj [more-bindings & body] 26 | (let [clj-star-syms (filter #(or (= (name %) "*e") 27 | (= (name %) "*1") 28 | (= (name %) "*2") 29 | (= (name %) "*3") 30 | (and (.startsWith #^String (name %) "*") 31 | (.endsWith #^String (name %) "*") 32 | (> (count (name %)) 1))) 33 | (keys (ns-publics (find-ns 'clojure.core))))] 34 | `(dothread-keeping [~@clj-star-syms ~@more-bindings] 35 | ~@body))) 36 | 37 | (defn current-thread [] 38 | (Thread/currentThread)) 39 | 40 | (defn thread-set-name 41 | ([name] (thread-set-name (current-thread) name)) 42 | ([#^Thread thread name] 43 | (.setName thread name))) 44 | 45 | (defn thread-name 46 | ([] (thread-name (current-thread))) 47 | ([#^Thread thread] 48 | (.getName thread))) 49 | 50 | (defn thread-id 51 | ([] (thread-id (current-thread))) 52 | ([#^Thread thread] 53 | (.getId thread))) 54 | 55 | (defn thread-alive? [#^Thread t] 56 | (.isAlive t)) 57 | -------------------------------------------------------------------------------- /src/swank/util/hooks.clj: -------------------------------------------------------------------------------- 1 | (ns swank.util.hooks) 2 | 3 | (defmacro defhook [name & hooks] 4 | `(defonce ~name (ref (list ~@hooks)))) 5 | 6 | ;;;; Hooks 7 | (defn add-hook [place function] 8 | (dosync (alter place conj function))) 9 | 10 | (defn run-hook [functions & arguments] 11 | (doseq [f @functions] 12 | (apply f arguments))) 13 | -------------------------------------------------------------------------------- /src/swank/util/io.clj: -------------------------------------------------------------------------------- 1 | (ns swank.util.io 2 | (:use [swank util] 3 | [swank.util.concurrent thread]) 4 | (:import [java.lang.String] 5 | [java.io StringWriter Reader PrintWriter])) 6 | 7 | (defn read-chars 8 | ([rdr n] (read-chars rdr n false)) 9 | ([#^Reader rdr n throw-exception] 10 | (let [#^"[C" cbuf (make-array Character/TYPE n)] 11 | (loop [i 0] 12 | (let [size (.read rdr cbuf i (- n i))] 13 | (cond 14 | (neg? size) (if throw-exception 15 | (throw throw-exception) 16 | (String. cbuf 0 i)) 17 | (= (+ i size) n) (String. cbuf) 18 | :else (recur (+ i size)))))))) 19 | 20 | (defn call-on-flush-stream 21 | "Creates a stream that will call a given function when flushed." 22 | ([flushf] 23 | (let [closed? (atom false) 24 | #^PrintWriter stream 25 | (PrintWriter. 26 | (proxy [StringWriter] [] 27 | (close [] (reset! closed? true)) 28 | (flush [] 29 | (let [#^StringWriter me this 30 | len (.. me getBuffer length)] 31 | (when (> len 0) 32 | (flushf (.. me getBuffer (substring 0 len))) 33 | (.. me getBuffer (delete 0 len)))))))] 34 | (dothread 35 | (thread-set-name "Call-on-write Stream") 36 | (continuously 37 | (Thread/sleep 200) 38 | (when-not @closed? 39 | (.flush stream)))) 40 | stream)) 41 | {:tag PrintWriter}) 42 | -------------------------------------------------------------------------------- /src/swank/util/java.clj: -------------------------------------------------------------------------------- 1 | (ns swank.util.java) 2 | 3 | (defn member-name [#^java.lang.reflect.Member member] 4 | (.getName member)) 5 | 6 | (defn member-static? [#^java.lang.reflect.Member member] 7 | (java.lang.reflect.Modifier/isStatic (.getModifiers member))) 8 | 9 | (defn static-methods [#^Class class] 10 | (filter member-static? (.getMethods class))) 11 | 12 | (defn static-fields [#^Class class] 13 | (filter member-static? (.getDeclaredFields class))) 14 | 15 | (defn instance-methods [#^Class class] 16 | (remove member-static? (.getMethods class))) 17 | -------------------------------------------------------------------------------- /src/swank/util/net/sockets.clj: -------------------------------------------------------------------------------- 1 | (ns swank.util.net.sockets 2 | (:use (swank util) 3 | (swank.util.concurrent thread)) 4 | (:import (java.net ServerSocket Socket SocketException InetAddress))) 5 | 6 | (defn make-server-socket 7 | "Create a java.net.ServerSocket. A map of `options': 8 | 9 | :port - The port which this ServerSocket will listen on. It must 10 | be a number between 0-65535. If 0 or not provided, the server 11 | will be created on any free port. 12 | 13 | :host - The address the server will bind to, can be used on multi 14 | homed hosts. This can be an InetAddress or a hostname string. If 15 | not provided or nil, it will listen on all addresses. 16 | 17 | :backlog - The maximum queue length of incoming connection 18 | indications (ie. connection requests). If the queue is full, new 19 | indications will be refused. If set to less than or equal to 0, 20 | the default value will be used." 21 | ([] (ServerSocket.)) 22 | ([options] (ServerSocket. (options :port 0) 23 | (options :backlog 0) 24 | (when-let [host (options :host)] 25 | (if (instance? InetAddress host) 26 | host 27 | (InetAddress/getByName host)))))) 28 | 29 | (defn start-server-socket! 30 | "Given a `server-socket' (java.net.ServerSocket), call 31 | `handle-socket' for each new connection and provide current 32 | socket. 33 | 34 | This will return immediately with the Thread that is blocking for 35 | new connections. Use Thread.join() if you need to wait for the 36 | server to close." 37 | ([server-socket handle-socket] 38 | (dothread-keeping-clj nil 39 | (thread-set-name (str "Swank Socket Server [" (thread-id) "]")) 40 | (with-open [#^ServerSocket server server-socket] 41 | (while (not (.isClosed server)) 42 | (try 43 | (handle-socket (.accept server)) 44 | (catch SocketException e 45 | (when-not @shutting-down? 46 | (throw e))))))))) 47 | 48 | (defn close-socket! 49 | "Cleanly shutdown and close a java.net.Socket. This will not affect 50 | an already running instance of SocketServer." 51 | ([#^Socket socket] 52 | (doto socket 53 | (.shutdownInput) 54 | (.shutdownOutput) 55 | (.close)))) 56 | 57 | (defn close-server-socket! 58 | "Shutdown a java.net.SocketServer. Existing connections will 59 | persist." 60 | ([#^ServerSocket server] 61 | (.close server))) 62 | -------------------------------------------------------------------------------- /src/swank/util/string.clj: -------------------------------------------------------------------------------- 1 | (ns swank.util.string) 2 | 3 | (defn largest-common-prefix 4 | "Returns the largest common prefix of two strings." 5 | ([#^String a, #^String b] 6 | (apply str (take-while (comp not nil?) (map #(when (= %1 %2) %1) a b)))) 7 | {:tag String}) 8 | 9 | (defn char-position 10 | "Finds the position of a character within a string, optionally 11 | provide a starting index. Returns nil if none is found." 12 | ([c str] (char-position c str 0)) 13 | ([#^Character c #^String str #^Integer start] 14 | (let [idx (.indexOf str (int c) start)] 15 | (when (not= -1 idx) 16 | idx)))) -------------------------------------------------------------------------------- /src/swank/util/sys.clj: -------------------------------------------------------------------------------- 1 | (ns swank.util.sys 2 | (:import (java.io BufferedReader InputStreamReader))) 3 | 4 | (defn get-pid 5 | "Returns the PID of the JVM. This is largely a hack and may or may 6 | not be accurate depending on the JVM in which clojure is running 7 | off of." 8 | ([] 9 | (or (first (.. java.lang.management.ManagementFactory 10 | (getRuntimeMXBean) (getName) (split "@"))) 11 | (System/getProperty "pid"))) 12 | {:tag String}) 13 | 14 | (defn #^java.lang.Process cmd [p] 15 | (.. Runtime getRuntime (exec (str p)))) 16 | 17 | (defn cmdout [^Process o] 18 | (let [r (BufferedReader. 19 | (InputStreamReader. (.getInputStream o)))] 20 | (line-seq r))) 21 | 22 | ;; would prefer (= (System/getenv "OSTYPE") "cygwin") 23 | ;; but clojure's java not in cygwin env 24 | (defn is-cygwin? [] 25 | (not= nil (try (cmdout (cmd "cygpath c:\\")) (catch Exception e)))) 26 | 27 | (defn universal-path [path] 28 | (if (is-cygwin?) 29 | (first (cmdout (cmd (str "cygpath " path)))) 30 | path)) 31 | 32 | (defn preferred-user-home-path [] 33 | (or (System/getenv "HOME") 34 | (System/getProperty "user.home"))) 35 | 36 | (defn user-home-path [] 37 | (universal-path (preferred-user-home-path))) 38 | -------------------------------------------------------------------------------- /test/data/test.jar: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/technomancy/swank-clojure/1000bbd0a035c923e1bf98fecdc9162a282ecea3/test/data/test.jar -------------------------------------------------------------------------------- /test/swank/test_swank.clj: -------------------------------------------------------------------------------- 1 | (ns swank.test-swank 2 | (:use clojure.test)) 3 | 4 | (def tests '(util 5 | util.net.sockets 6 | core.protocol 7 | commands.contrib.swank-c-p-c)) 8 | 9 | (def tests-ns 10 | (for [test tests] 11 | (symbol (str "swank.test-swank." test)))) 12 | 13 | (defn run-all [] 14 | (println "Loading") 15 | (apply require :reload-all tests-ns) 16 | (apply run-tests tests-ns)) -------------------------------------------------------------------------------- /test/swank/test_swank/commands/basic.clj: -------------------------------------------------------------------------------- 1 | (ns swank.test-swank.commands.basic 2 | (:refer-clojure :exclude [load-file print-doc]) 3 | (:use swank.commands.basic :reload-all) 4 | (:use clojure.test)) 5 | 6 | (defn emacs-package-fixture [f] 7 | (binding [swank.core/*current-package* "user"] 8 | (f))) 9 | 10 | (use-fixtures :each emacs-package-fixture) 11 | 12 | (defmacro with-private-vars [[ns fns] & tests] 13 | "Refers private fns from ns and runs tests in context. From users mailing 14 | list, Alan Dipert and MeikelBrandmeyer." 15 | `(let ~(reduce #(conj %1 %2 `@(ns-resolve '~ns '~%2)) [] fns) 16 | ~@tests)) 17 | 18 | (with-private-vars [swank.commands.basic 19 | [guess-compiler-exception-location 20 | exception-location]] 21 | 22 | (deftest guess-compiler-exception-location-test 23 | (is (= '(:location (:file "a.clj") (:line 1) nil) 24 | (guess-compiler-exception-location 25 | (compiler-exception "a.clj" 1 (Exception. "err")))))) 26 | 27 | (deftest exception-location-test 28 | (is (= '(:location (:file "a.clj") (:line 1) nil) 29 | (exception-location 30 | (compiler-exception "a.clj" 1 (Exception. "err"))))))) 31 | -------------------------------------------------------------------------------- /test/swank/test_swank/commands/contrib/swank_c_p_c.clj: -------------------------------------------------------------------------------- 1 | (ns swank.test-swank.commands.contrib.swank-c-p-c 2 | (:use swank.commands.contrib.swank-c-p-c 3 | swank.commands.contrib.swank-c-p-c.internal 4 | clojure.test)) 5 | 6 | (deftest delimited-compound-prefix-matches 7 | (testing "matches" 8 | (are [delimiter prefix target] 9 | (delimited-compound-prefix-match? delimiter prefix target) 10 | "." "o.t.t" "one.two.three" 11 | "-" "on-tw" "one-two-three" 12 | ".-" "on-t.thr" "one.two.three")) 13 | (testing "mismatches" 14 | (are [delimiter prefix target] 15 | (not (delimited-compound-prefix-match? delimiter prefix target)) 16 | "." "o-t.t" "one-two.three" 17 | "_" "o_t_t" "one_two_four" 18 | "." "o..t" "one.two"))) 19 | 20 | (deftest delimited-compound-prefix-matches-acronyms 21 | (testing "matches with acronyms" 22 | (are [delimiter prefix target] 23 | (delimited-compound-prefix-match-acronym? delimiter prefix target) 24 | "." "ott" "one.two.three" 25 | ".-" "ott" "one-two.three")) 26 | 27 | (testing "mismatches with acronyms" 28 | (are [delimiter prefix target] 29 | (not (delimited-compound-prefix-match-acronym? delimiter prefix target)) 30 | "." "ott" "one.two-three" 31 | ".-" "ott" "one-two.four"))) 32 | 33 | (deftest camel-compound-prefix-matches 34 | (testing "matches" 35 | (are [prefix target] (camel-compound-prefix-match? prefix target) 36 | "tSS" "toSimpleString" 37 | ".S" ".toString" 38 | ".tStr" ".toString")) 39 | 40 | (testing "mismatches" 41 | (are [prefix target] (not (camel-compound-prefix-match? prefix target)) 42 | "tSS" ".toSimpleString" 43 | ".S" "toString"))) 44 | 45 | (deftest split-compound-prefix-matches 46 | (testing "matches" 47 | (are [prefix target] (split-compound-prefix-match? prefix target) 48 | "one/two" "one/two-three" 49 | "three.f/five" "three.fix/five" 50 | "nst/jat" "name.space.test/just-another-test")) 51 | 52 | (testing "mismatches" 53 | (are [prefix target] (not (split-compound-prefix-match? prefix target)) 54 | "o.t" "one/two-three" 55 | "imatch" "i.do.not.match"))) 56 | -------------------------------------------------------------------------------- /test/swank/test_swank/core/protocol.clj: -------------------------------------------------------------------------------- 1 | (ns swank.test-swank.core.protocol 2 | (:import (java.io StringReader 3 | StringWriter)) 4 | (:use clojure.test 5 | swank.core.protocol)) 6 | 7 | ;; currently here until test-is 8 | (deftest reading-messages 9 | (are [msg form] (with-open [reader (StringReader. msg)] 10 | (= (read-swank-message reader) form)) 11 | "0000017" 7 12 | "000013(:keyword \"string\")" '(:keyword "string") 13 | "000018(nested (list [vector]))" '(nested (list [vector])))) 14 | 15 | (deftest writing-messages 16 | (are [form msg] (with-open [writer (StringWriter.)] 17 | (write-swank-message writer form) 18 | (= (.toString writer) msg)) 19 | 20 | 9 "0000019" 21 | '(:keyword "string") "000013(:keyword \"string\")" 22 | '(nested (list [vector])) "000018(nested (list [vector]))")) -------------------------------------------------------------------------------- /test/swank/test_swank/util.clj: -------------------------------------------------------------------------------- 1 | (ns swank.test-swank.util 2 | (:use swank.util 3 | clojure.test)) 4 | 5 | (deftest test-one-of? 6 | (testing "matches" 7 | (is (one-of? :a :a :b (throw (Exception. "Failed to short circuit")))) 8 | (is (one-of? 1 1)) 9 | (is (one-of? "one" "one" "two" "three"))) 10 | (testing "mismatches" 11 | (is (not (one-of? :a :b :c :d))) 12 | (is (not (one-of? 1 2))) 13 | (is (not (one-of? "one" "two" "three"))) 14 | (is (thrown-with-msg? Exception #"None found" 15 | (one-of? :a :b :c (throw (Exception. "None found"))))))) 16 | 17 | (deftest test-find-first 18 | (testing "first true" 19 | (are [coll first-true] (= (find-first coll) first-true) 20 | [1 2 3] 1 21 | [nil false :first] :first)) 22 | (testing "with predicate" 23 | (are [coll pred first-true] (= (find-first pred coll) first-true) 24 | [1 2 3 4 5] even? 2 25 | [1 2 3 4 5] #{3 4} 3)) 26 | (testing "non existent" 27 | (are [coll pred] (nil? (find-first pred coll)) 28 | [1 3 5 7 9] even? 29 | [1 2 3 4 5] #{6 7}))) 30 | 31 | (deftest test-position 32 | (testing "with matches" 33 | (are [coll pred pos] (= (position pred coll) pos) 34 | [:a :b :c :d] #{:c} 2)) 35 | (testing "with matches and starting position" 36 | (are [coll pred start pos] (= (position pred coll start) pos) 37 | [:a :b :a :b :a :b] #{:a} 1 2)) 38 | (testing "without matches" 39 | (are [coll pred] (not (position pred coll)) 40 | [1 3 5 7] even? 41 | [:a :b :c :d] #{:e}))) 42 | -------------------------------------------------------------------------------- /test/swank/test_swank/util/class_browse.clj: -------------------------------------------------------------------------------- 1 | (ns swank.test-swank.util.class-browse 2 | (:use swank.util.class-browse 3 | clojure.test) 4 | (:import [java.io File])) 5 | 6 | (def test-jar (File. "test/data/test.jar")) 7 | 8 | (deftest test-path-class-files-jar 9 | (testing "class from jar file" 10 | (is (= (:name (first (path-class-files test-jar test-jar))) "a.b.c.d.Test")))) 11 | -------------------------------------------------------------------------------- /test/swank/test_swank/util/net/sockets.clj: -------------------------------------------------------------------------------- 1 | ;; Requires clojure 1.1 (currently in alpha) 2 | (ns swank.test-swank.util.net.sockets 3 | (:import (java.net ServerSocket Socket InetSocketAddress)) 4 | (:use clojure.test 5 | swank.util.net.sockets)) 6 | 7 | (deftest making-server 8 | (are [x] (with-open [#^ServerSocket socket x] 9 | (instance? ServerSocket x)) 10 | (make-server-socket) 11 | (make-server-socket {:backlog 10}) 12 | (make-server-socket {:host "localhost"}))) 13 | 14 | ;; Testing of connection (ought to do object mocks) 15 | --------------------------------------------------------------------------------