├── .gitignore ├── COPYING ├── NEWS ├── README.md ├── TODO.org ├── project.clj ├── src ├── leiningen │ └── swank.clj └── swank │ ├── clj_contrib │ ├── macroexpand.clj │ └── pprint.clj │ ├── commands.clj │ ├── commands │ ├── basic.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 │ ├── connection.clj │ ├── hooks.clj │ ├── protocol.clj │ ├── server.clj │ └── threadmap.clj │ ├── dev.clj │ ├── loader.clj │ ├── rpc.clj │ ├── swank.clj │ ├── util.clj │ └── util │ ├── class_browse.clj │ ├── clojure.clj │ ├── concurrent │ ├── mbox.clj │ └── thread.clj │ ├── hooks.clj │ ├── io.clj │ ├── java.clj │ ├── net │ └── sockets.clj │ ├── string.clj │ └── sys.clj ├── swank-clojure.el └── test └── swank ├── test_swank.clj └── test_swank ├── commands ├── basic.clj └── contrib │ └── swank_c_p_c.clj ├── core └── protocol.clj ├── util.clj └── util └── net └── sockets.clj /.gitignore: -------------------------------------------------------------------------------- 1 | classes/ 2 | lib/ 3 | multi-lib/ 4 | swank-clojure*jar 5 | pom.xml 6 | -------------------------------------------------------------------------------- /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: -------------------------------------------------------------------------------- 1 | Swank Clojure NEWS -- history of user-visible changes 2 | 3 | = 1.2.0 / 2010-05-15 4 | 5 | * Move lein-swank plugin to be bundled with swank-clojure. 6 | 7 | * Support M-x slime-who-calls. List all the callers of a given function. 8 | 9 | * Add swank.core/break. 10 | 11 | * Support slime-pprint-eval-last-expression. 12 | 13 | * Improve support for trunk slime. 14 | 15 | * Completion for static Java members. 16 | 17 | * Show causes of exceptions in debugger. 18 | 19 | * Preserve line numbers when compiling a region/defn. 20 | 21 | * Relicense to the EPL (same as Clojure). 22 | 23 | * Better compatibility with Clojure 1.2. 24 | 25 | = 1.1.0 / 2010-01-01 26 | 27 | * A whole mess of stuff! 28 | 29 | = 1.0.0 / 2009-11-10 30 | 31 | * First versioned release. 32 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Swank Clojure 2 | 3 | **Important**: [Swank Clojure has moved!](http://github.com/technomancy/swank-clojure) 4 | 5 | [Swank Clojure](http://github.com/technomancy/swank-clojure) is a 6 | server that allows [SLIME](http://common-lisp.net/project/slime/) (the 7 | Superior Lisp Interaction Mode for Emacs) to connect to Clojure 8 | projects. To use it you must launch a swank server, then connect to it 9 | from within Emacs. 10 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /project.clj: -------------------------------------------------------------------------------- 1 | (defproject swank-clojure "1.3.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.0"]] 5 | :dev-dependencies [[lein-multi "1.0.0"]] 6 | :multi-deps {"1.1" [[org.clojure/clojure "1.1.0"] 7 | [org.clojure/clojure-contrib "1.1.0"]] 8 | "1.3" [[org.clojure/clojure "1.3.0-master-SNAPSHOT"]]} 9 | :shell-wrapper {:main swank.swank}) 10 | -------------------------------------------------------------------------------- /src/leiningen/swank.clj: -------------------------------------------------------------------------------- 1 | (ns leiningen.swank 2 | "Launch swank server for Emacs to connect." 3 | (:use [leiningen.compile :only [eval-in-project]]) 4 | (:import [java.io File])) 5 | 6 | (defn swank-form [project port host opts] 7 | ;; bootclasspath workaround: http://dev.clojure.org/jira/browse/CLJ-673 8 | (when (:eval-in-leiningen project) 9 | (require '[clojure walk template stacktrace])) 10 | `(do 11 | (let [is# ~(:repl-init-script project)] 12 | (when (.exists (File. (str is#))) 13 | (load-file is#))) 14 | (require '~'swank.swank) 15 | (require '~'swank.commands.basic) 16 | (@(ns-resolve '~'swank.swank '~'start-repl) 17 | (Integer. ~port) ~@(concat (map read-string opts) 18 | [:host host])) 19 | ;; This exits immediately when using :eval-in-leiningen; must block 20 | (when ~(:eval-in-leiningen project) 21 | (doseq [t# ((ns-resolve '~'swank.commands.basic 22 | '~'get-thread-list))] 23 | (.join t#))))) 24 | 25 | (defn swank 26 | "Launch swank server for Emacs to connect. Optionally takes PORT and HOST." 27 | ([project port host & opts] 28 | (eval-in-project project (swank-form project port host opts))) 29 | ([project port] (swank project port "localhost")) 30 | ([project] (swank project 4005))) 31 | -------------------------------------------------------------------------------- /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.commands [xref :as xref])) 9 | (:import (java.io StringReader File) 10 | (java.util.zip ZipFile) 11 | (clojure.lang LineNumberingPushbackReader))) 12 | 13 | ;;;; Connection 14 | 15 | (defslimefn connection-info [] 16 | `(:pid ~(sys/get-pid) 17 | :style :spawn 18 | :lisp-implementation (:type "Clojure" 19 | :name "clojure" 20 | :version ~(clojure-version)) 21 | :package (:name ~(name (ns-name *ns*)) 22 | :prompt ~(name (ns-name *ns*))) 23 | :version ~(deref protocol-version))) 24 | 25 | (defslimefn quit-lisp [] 26 | (System/exit 0)) 27 | 28 | (defslimefn toggle-debug-on-swank-error [] 29 | (alter-var-root #'swank.core/debug-swank-clojure not)) 30 | 31 | ;;;; Evaluation 32 | 33 | (defn- eval-region 34 | "Evaluate string, return the results of the last form as a list and 35 | a secondary value the last form." 36 | ([string] 37 | (eval-region string "NO_SOURCE_FILE" 1)) 38 | ([string file line] 39 | (with-open [rdr (proxy [LineNumberingPushbackReader] 40 | ((StringReader. string)) 41 | (getLineNumber [] line))] 42 | (binding [*file* file] 43 | (loop [form (read rdr false rdr), value nil, last-form nil] 44 | (if (= form rdr) 45 | [value last-form] 46 | (recur (read rdr false rdr) 47 | (eval (with-env-locals form)) 48 | form))))))) 49 | 50 | (defn- compile-region 51 | "Compile region." 52 | ([string file line] 53 | (with-open [rdr1 (proxy [LineNumberingPushbackReader] 54 | ((StringReader. string))) 55 | rdr (proxy [LineNumberingPushbackReader] (rdr1) 56 | (getLineNumber [] (+ line (.getLineNumber rdr1) -1)))] 57 | (clojure.lang.Compiler/load rdr file (.getName (File. file)))))) 58 | 59 | 60 | (defslimefn interactive-eval-region [string] 61 | (with-emacs-package 62 | (pr-str (first (eval-region string))))) 63 | 64 | (defslimefn interactive-eval [string] 65 | (with-emacs-package 66 | (pr-str (first (eval-region string))))) 67 | 68 | (defslimefn listener-eval [form] 69 | (with-emacs-package 70 | (with-package-tracking 71 | (let [[value last-form] (eval-region form)] 72 | (when (and last-form (not (one-of? last-form '*1 '*2 '*3 '*e))) 73 | (set! *3 *2) 74 | (set! *2 *1) 75 | (set! *1 value)) 76 | (send-repl-results-to-emacs value))))) 77 | 78 | (defslimefn eval-and-grab-output [string] 79 | (with-emacs-package 80 | (let [retval (promise)] 81 | (list (with-out-str 82 | (deliver retval (pr-str (first (eval-region string))))) 83 | @retval)))) 84 | 85 | (defslimefn pprint-eval [string] 86 | (with-emacs-package 87 | (pretty-pr-code (first (eval-region string))))) 88 | 89 | ;;;; Macro expansion 90 | 91 | (defn- apply-macro-expander [expander string] 92 | (pretty-pr-code (expander (read-string string)))) 93 | 94 | (defslimefn swank-macroexpand-1 [string] 95 | (apply-macro-expander macroexpand-1 string)) 96 | 97 | (defslimefn swank-macroexpand [string] 98 | (apply-macro-expander macroexpand string)) 99 | 100 | ;; not implemented yet, needs walker 101 | (defslimefn swank-macroexpand-all [string] 102 | (apply-macro-expander macroexpand-all string)) 103 | 104 | ;;;; Compiler / Execution 105 | 106 | (def compiler-exception-location-re #"Exception:.*\(([^:]+):([0-9]+)\)") 107 | (defn- guess-compiler-exception-location [#^Throwable t] 108 | (when (instance? clojure.lang.Compiler$CompilerException t) 109 | (let [[match file line] (re-find compiler-exception-location-re (str t))] 110 | (when (and file line) 111 | `(:location (:file ~file) (:line ~(Integer/parseInt line)) nil))))) 112 | 113 | ;; TODO: Make more and better guesses 114 | (defn- exception-location [#^Throwable t] 115 | (or (guess-compiler-exception-location t) 116 | '(:error "No error location available"))) 117 | 118 | ;; plist of message, severity, location, references, short-message 119 | (defn- exception-to-message [#^Throwable t] 120 | `(:message ~(.toString t) 121 | :severity :error 122 | :location ~(exception-location t) 123 | :references nil 124 | :short-message ~(.toString t))) 125 | 126 | (defn- compile-file-for-emacs* 127 | "Compiles a file for emacs. Because clojure doesn't compile, this is 128 | simple an alias for load file w/ timing and messages. This function 129 | is to reply with the following: 130 | (:swank-compilation-unit notes results durations)" 131 | ([file-name] 132 | (let [start (System/nanoTime)] 133 | (try 134 | (let [ret (clojure.core/load-file file-name) 135 | delta (- (System/nanoTime) start)] 136 | `(:compilation-result nil ~(pr-str ret) ~(/ delta 1000000000.0))) 137 | (catch Throwable t 138 | (let [delta (- (System/nanoTime) start) 139 | causes (exception-causes t) 140 | num (count causes)] 141 | (.printStackTrace t) ;; prints to *inferior-lisp* 142 | `(:compilation-result 143 | ~(map exception-to-message causes) ;; notes 144 | nil ;; results 145 | ~(/ delta 1000000000.0) ;; durations 146 | ))))))) 147 | 148 | (defslimefn compile-file-for-emacs 149 | ([file-name load? & compile-options] 150 | (when load? 151 | (compile-file-for-emacs* file-name)))) 152 | 153 | (defslimefn load-file [file-name] 154 | (pr-str (clojure.core/load-file file-name))) 155 | 156 | (defn- line-at-position [file position] 157 | (try 158 | (with-open [f (java.io.LineNumberReader. (java.io.FileReader. file))] 159 | (.skip f position) 160 | (.getLineNumber f)) 161 | (catch Exception e 1))) 162 | 163 | (defslimefn compile-string-for-emacs [string buffer position directory debug] 164 | (let [start (System/nanoTime) 165 | line (line-at-position directory position) 166 | ret (with-emacs-package 167 | (when-not (= (name (ns-name *ns*)) *current-package*) 168 | (throw (clojure.lang.Compiler$CompilerException. 169 | directory line 170 | (Exception. (str "No such namespace: " 171 | *current-package*))))) 172 | (compile-region string directory line)) 173 | delta (- (System/nanoTime) start)] 174 | `(:compilation-result nil ~(pr-str ret) ~(/ delta 1000000000.0)))) 175 | 176 | ;;;; Describe 177 | 178 | (defn- maybe-resolve-sym [symbol-name] 179 | (try 180 | (ns-resolve (maybe-ns *current-package*) (symbol symbol-name)) 181 | (catch ClassNotFoundException e nil))) 182 | 183 | (defn- maybe-resolve-ns [sym-name] 184 | (let [sym (symbol sym-name)] 185 | (or ((ns-aliases (maybe-ns *current-package*)) sym) 186 | (find-ns sym)))) 187 | 188 | (defn- print-doc* [m] 189 | (println "-------------------------") 190 | (println (str (when-let [ns (:ns m)] (str (ns-name ns) "/")) (:name m))) 191 | (cond 192 | (:forms m) (doseq [f (:forms m)] 193 | (print " ") 194 | (prn f)) 195 | (:arglists m) (prn (:arglists m))) 196 | (if (:special-form m) 197 | (do 198 | (println "Special Form") 199 | (println " " (:doc m)) 200 | (if (contains? m :url) 201 | (when (:url m) 202 | (println (str "\n Please see http://clojure.org/" (:url m)))) 203 | (println (str "\n Please see http://clojure.org/special_forms#" 204 | (:name m))))) 205 | (do 206 | (when (:macro m) 207 | (println "Macro")) 208 | (println " " (:doc m))))) 209 | 210 | (def print-doc (if (-> (resolve 'clojure.core/print-doc) meta :private) 211 | print-doc* 212 | (resolve 'clojure.core/print-doc))) 213 | 214 | (defn- describe-to-string [var] 215 | (with-out-str 216 | (print-doc var))) 217 | 218 | (defn- describe-symbol* [symbol-name] 219 | (with-emacs-package 220 | (if-let [v (maybe-resolve-sym symbol-name)] 221 | (if-not (class? v) 222 | (describe-to-string v))))) 223 | 224 | (defslimefn describe-symbol [symbol-name] 225 | (describe-symbol* symbol-name)) 226 | 227 | (defslimefn describe-function [symbol-name] 228 | (describe-symbol* symbol-name)) 229 | 230 | ;; Only one namespace... so no kinds 231 | (defslimefn describe-definition-for-emacs [name kind] 232 | (describe-symbol* name)) 233 | 234 | ;; Only one namespace... so only describe symbol 235 | (defslimefn documentation-symbol 236 | ([symbol-name default] (documentation-symbol symbol-name)) 237 | ([symbol-name] (describe-symbol* symbol-name))) 238 | 239 | ;;;; Documentation 240 | 241 | (defn- briefly-describe-symbol-for-emacs [var] 242 | (let [lines (fn [s] (.split #^String s (System/getProperty "line.separator"))) 243 | [_ symbol-name arglists d1 d2 & __] (lines (describe-to-string var)) 244 | macro? (= d1 "Macro")] 245 | (list :designator symbol-name 246 | (cond 247 | macro? :macro 248 | (:arglists (meta var)) :function 249 | :else :variable) 250 | (apply str (concat arglists (if macro? d2 d1)))))) 251 | 252 | (defn- make-apropos-matcher [pattern case-sensitive?] 253 | (let [pattern (java.util.regex.Pattern/quote pattern) 254 | pat (re-pattern (if case-sensitive? 255 | pattern 256 | (format "(?i:%s)" pattern)))] 257 | (fn [var] (re-find pat (pr-str var))))) 258 | 259 | (defn- apropos-symbols [string external-only? case-sensitive? package] 260 | (let [packages (or (when package [package]) (all-ns)) 261 | matcher (make-apropos-matcher string case-sensitive?) 262 | lister (if external-only? ns-publics ns-interns)] 263 | (filter matcher 264 | (apply concat (map (comp (partial map second) lister) 265 | packages))))) 266 | 267 | (defn- present-symbol-before 268 | "Comparator such that x belongs before y in a printed summary of symbols. 269 | Sorted alphabetically by namespace name and then symbol name, except 270 | that symbols accessible in the current namespace go first." 271 | [x y] 272 | (let [accessible? 273 | (fn [var] (= (maybe-resolve-sym (:name (meta var))) 274 | var)) 275 | ax (accessible? x) ay (accessible? y)] 276 | (cond 277 | (and ax ay) (compare (:name (meta x)) (:name (meta y))) 278 | ax -1 279 | ay 1 280 | :else (let [nx (str (:ns (meta x))) ny (str (:ns (meta y)))] 281 | (if (= nx ny) 282 | (compare (:name (meta x)) (:name (meta y))) 283 | (compare nx ny)))))) 284 | 285 | (defslimefn apropos-list-for-emacs 286 | ([name] 287 | (apropos-list-for-emacs name nil)) 288 | ([name external-only?] 289 | (apropos-list-for-emacs name external-only? nil)) 290 | ([name external-only? case-sensitive?] 291 | (apropos-list-for-emacs name external-only? case-sensitive? nil)) 292 | ([name external-only? case-sensitive? package] 293 | (let [package (when package 294 | (maybe-ns package))] 295 | (map briefly-describe-symbol-for-emacs 296 | (sort present-symbol-before 297 | (apropos-symbols name external-only? case-sensitive? 298 | package)))))) 299 | 300 | ;;;; Operator messages 301 | (defslimefn operator-arglist [name package] 302 | (try 303 | (let [f (read-string name)] 304 | (cond 305 | (keyword? f) "([map])" 306 | (symbol? f) (let [var (ns-resolve (maybe-ns package) f)] 307 | (if-let [args (and var (:arglists (meta var)))] 308 | (pr-str args) 309 | nil)) 310 | :else nil)) 311 | (catch Throwable t nil))) 312 | 313 | ;;;; Package Commands 314 | 315 | (defslimefn list-all-package-names 316 | ([] (map (comp str ns-name) (all-ns))) 317 | ([nicknames?] (list-all-package-names))) 318 | 319 | (defslimefn set-package [name] 320 | (let [ns (maybe-ns name)] 321 | (in-ns (ns-name ns)) 322 | (list (str (ns-name ns)) 323 | (str (ns-name ns))))) 324 | 325 | ;;;; Tracing 326 | 327 | (defonce traced-fn-map {}) 328 | 329 | (def #^{:dynamic true} *trace-level* 0) 330 | 331 | (defn- indent [num] 332 | (dotimes [x (+ 1 num)] 333 | (print " "))) 334 | 335 | (defn- trace-fn-call [sym f args] 336 | (let [fname (symbol (str (.name (.ns sym)) "/" (.sym sym)))] 337 | (indent *trace-level*) 338 | (println (str *trace-level* ":") 339 | (apply str (take 240 (pr-str (when fname (cons fname args)) )))) 340 | (let [result (binding [*trace-level* (+ *trace-level* 1)] (apply f args))] 341 | (indent *trace-level*) 342 | (println (str *trace-level* ": " fname " returned " (apply str (take 240 (pr-str result))))) 343 | result))) 344 | 345 | (defslimefn swank-toggle-trace [fname] 346 | (when-let [sym (maybe-resolve-sym fname)] 347 | (if-let [f# (get traced-fn-map sym)] 348 | (do 349 | (alter-var-root #'traced-fn-map dissoc sym) 350 | (alter-var-root sym (constantly f#)) 351 | (str " untraced.")) 352 | (let [f# @sym] 353 | (alter-var-root #'traced-fn-map assoc sym f#) 354 | (alter-var-root sym 355 | (constantly 356 | (fn [& args] 357 | (trace-fn-call sym f# args)))) 358 | (str " traced."))))) 359 | 360 | (defslimefn untrace-all [] 361 | (doseq [sym (keys traced-fn-map)] 362 | (swank-toggle-trace (.sym sym)))) 363 | 364 | ;;;; Source Locations 365 | (comment 366 | "Sets the default directory (java's user.dir). Note, however, that 367 | this will not change the search path of load-file. ") 368 | (defslimefn set-default-directory 369 | ([directory & ignore] 370 | (System/setProperty "user.dir" directory) 371 | directory)) 372 | 373 | 374 | ;;;; meta dot find 375 | 376 | (defn- clean-windows-path [#^String path] 377 | ;; Decode file URI encoding and remove an opening slash from 378 | ;; /c:/program%20files/... in jar file URLs and file resources. 379 | (or (and (.startsWith (System/getProperty "os.name") "Windows") 380 | (second (re-matches #"^/([a-zA-Z]:/.*)$" path))) 381 | path)) 382 | 383 | (defn- slime-zip-resource [#^java.net.URL resource] 384 | (let [jar-connection #^java.net.JarURLConnection (.openConnection resource) 385 | jar-file (.getPath (.toURI (.getJarFileURL jar-connection)))] 386 | (list :zip (clean-windows-path jar-file) (.getEntryName jar-connection)))) 387 | 388 | (defn- slime-file-resource [#^java.net.URL resource] 389 | (list :file (clean-windows-path (.getFile resource)))) 390 | 391 | (defn- slime-find-resource [#^String file] 392 | (if-let [resource (.getResource (clojure.lang.RT/baseLoader) file)] 393 | (if (= (.getProtocol resource) "jar") 394 | (slime-zip-resource resource) 395 | (slime-file-resource resource)))) 396 | 397 | (defn- slime-find-file [#^String file] 398 | (if (.isAbsolute (File. file)) 399 | (list :file file) 400 | (slime-find-resource file))) 401 | 402 | (defn- namespace-to-path [ns] 403 | (let [#^String ns-str (name (ns-name ns)) 404 | last-dot-index (.lastIndexOf ns-str ".")] 405 | (if (pos? last-dot-index) 406 | (-> (.substring ns-str 0 last-dot-index) 407 | (.replace \- \_) 408 | (.replace \. \/))))) 409 | 410 | (defn- classname-to-path [class-name] 411 | (namespace-to-path 412 | (symbol (.replace class-name \_ \-)))) 413 | 414 | 415 | (defn- location-in-file [path line] 416 | `(:location ~path (:line ~line) nil)) 417 | 418 | (defn- location-label [name type] 419 | (if type 420 | (str "(" type " " name ")") 421 | (str name))) 422 | 423 | (defn- location [name type path line] 424 | `((~(location-label name type) 425 | ~(if path 426 | (location-in-file path line) 427 | (list :error (format "%s - definition not found." name)))))) 428 | 429 | (defn- location-not-found [name type] 430 | (location name type nil nil)) 431 | 432 | (defn source-location-for-frame [#^StackTraceElement frame] 433 | (let [line (.getLineNumber frame) 434 | filename (if (.. frame getFileName (endsWith ".java")) 435 | (.. frame getClassName (replace \. \/) 436 | (substring 0 (.lastIndexOf (.getClassName frame) ".")) 437 | (concat (str File/separator (.getFileName frame)))) 438 | (let [ns-path (classname-to-path 439 | ((re-find #"(.*?)\$" 440 | (.getClassName frame)) 1))] 441 | (if ns-path 442 | (str ns-path File/separator (.getFileName frame)) 443 | (.getFileName frame)))) 444 | path (slime-find-file filename)] 445 | (location-in-file path line))) 446 | 447 | (defn- namespace-to-filename [ns] 448 | (str (-> (str ns) 449 | (.replaceAll "\\." File/separator) 450 | (.replace \- \_ )) 451 | ".clj")) 452 | 453 | (defn- source-location-for-meta [meta xref-type-name] 454 | (location (:name meta) 455 | xref-type-name 456 | (slime-find-file (:file meta)) 457 | (:line meta))) 458 | 459 | (defn- find-ns-definition [sym-name] 460 | (if-let [ns (maybe-resolve-ns sym-name)] 461 | (when-let [path (slime-find-file (namespace-to-filename ns))] 462 | (location ns nil path 1)))) 463 | 464 | (defn- find-var-definition [sym-name] 465 | (if-let [meta (meta (maybe-resolve-sym sym-name))] 466 | (source-location-for-meta meta "defn"))) 467 | 468 | (defslimefn find-definitions-for-emacs [name] 469 | (let [sym-name (read-string name)] 470 | (or (find-var-definition sym-name) 471 | (find-ns-definition sym-name) 472 | (location name nil nil nil)))) 473 | 474 | (defn who-specializes [class] 475 | (letfn [(xref-lisp [sym] ; see find-definitions-for-emacs 476 | (if-let [meta (meta sym)] 477 | (source-location-for-meta meta "method") 478 | (location-not-found (.getName sym) "method")))] 479 | (let [methods (try (. class getMethods) 480 | (catch java.lang.IllegalArgumentException e nil) 481 | (catch java.lang.NullPointerException e nil))] 482 | (map xref-lisp methods)))) 483 | 484 | (defn who-calls [name] 485 | (letfn [(xref-lisp [sym-var] ; see find-definitions-for-emacs 486 | (when-let [meta (meta sym-var)] 487 | (source-location-for-meta meta nil)))] 488 | (let [callers (xref/all-vars-who-call name) ] 489 | (map first (map xref-lisp callers))))) 490 | 491 | (defslimefn xref [type name] 492 | (let [sexp (maybe-resolve-sym name)] 493 | (condp = type 494 | :specializes (who-specializes sexp) 495 | :calls (who-calls (symbol name)) 496 | :callers nil 497 | :not-implemented))) 498 | 499 | (defslimefn throw-to-toplevel [] 500 | (throw debug-quit-exception)) 501 | 502 | (defn invoke-restart [restart] 503 | ((nth restart 2))) 504 | 505 | (defslimefn invoke-nth-restart-for-emacs [level n] 506 | ((invoke-restart (*sldb-restarts* (nth (keys *sldb-restarts*) n))))) 507 | 508 | (defslimefn throw-to-toplevel [] 509 | (if-let [restart (*sldb-restarts* :quit)] 510 | (invoke-restart restart))) 511 | 512 | (defslimefn sldb-continue [] 513 | (if-let [restart (*sldb-restarts* :continue)] 514 | (invoke-restart restart))) 515 | 516 | (defslimefn sldb-abort [] 517 | (if-let [restart (*sldb-restarts* :abort)] 518 | (invoke-restart restart))) 519 | 520 | 521 | (defslimefn backtrace [start end] 522 | (build-backtrace start end)) 523 | 524 | (defslimefn buffer-first-change [file-name] nil) 525 | 526 | (defn locals-for-emacs [m] 527 | (sort-by second 528 | (map #(list :name (name (first %)) :id 0 529 | :value (pr-str (second %))) m))) 530 | 531 | (defslimefn frame-catch-tags-for-emacs [n] nil) 532 | (defslimefn frame-locals-for-emacs [n] 533 | (if (and (zero? n) (seq *current-env*)) 534 | (locals-for-emacs *current-env*))) 535 | 536 | (defslimefn frame-locals-and-catch-tags [n] 537 | (list (frame-locals-for-emacs n) 538 | (frame-catch-tags-for-emacs n))) 539 | 540 | (defslimefn debugger-info-for-emacs [start end] 541 | (build-debugger-info-for-emacs start end)) 542 | 543 | (defslimefn eval-string-in-frame [expr n] 544 | (if (and (zero? n) *current-env*) 545 | (with-bindings *current-env* 546 | (eval expr)))) 547 | 548 | (defslimefn frame-source-location [n] 549 | (source-location-for-frame 550 | (nth (.getStackTrace *current-exception*) n))) 551 | 552 | ;; Older versions of slime use this instead of the above. 553 | (defslimefn frame-source-location-for-emacs [n] 554 | (source-location-for-frame 555 | (nth (.getStackTrace *current-exception*) n))) 556 | 557 | (defslimefn create-repl [target] '("user" "user")) 558 | 559 | ;;; Threads 560 | 561 | (def #^{:private true} thread-list (atom [])) 562 | 563 | (defn- get-root-group [#^java.lang.ThreadGroup tg] 564 | (if-let [parent (.getParent tg)] 565 | (recur parent) 566 | tg)) 567 | 568 | (defn- get-thread-list [] 569 | (let [rg (get-root-group (.getThreadGroup (Thread/currentThread))) 570 | arr (make-array Thread (.activeCount rg))] 571 | (.enumerate rg arr true) 572 | (seq arr))) 573 | 574 | (defn- extract-info [#^Thread t] 575 | (map str [(.getId t) (.getName t) (.getPriority t) (.getState t)])) 576 | 577 | (defslimefn list-threads 578 | "Return a list (LABELS (ID NAME STATUS ATTRS ...) ...). 579 | LABELS is a list of attribute names and the remaining lists are the 580 | corresponding attribute values per thread." 581 | [] 582 | (reset! thread-list (get-thread-list)) 583 | (let [labels '(id name priority state)] 584 | (cons labels (map extract-info @thread-list)))) 585 | 586 | ;;; TODO: Find a better way, as Thread.stop is deprecated 587 | (defslimefn kill-nth-thread [index] 588 | (when index 589 | (when-let [thread (nth @thread-list index nil)] 590 | (println "Thread: " thread) 591 | (.stop thread)))) 592 | 593 | (defslimefn quit-thread-browser [] 594 | (reset! thread-list [])) 595 | -------------------------------------------------------------------------------- /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 | ([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 | 5 | ;;;; Inspector for basic clojure data structures 6 | 7 | ;; This a mess, I'll clean up this code after I figure out exactly 8 | ;; what I need for debugging support. 9 | 10 | (def inspectee (ref nil)) 11 | (def inspectee-content (ref nil)) 12 | (def inspectee-parts (ref nil)) 13 | (def inspectee-actions (ref nil)) 14 | (def inspector-stack (ref nil)) 15 | (def inspector-history (ref nil)) 16 | 17 | (defn reset-inspector [] 18 | (dosync 19 | (ref-set inspectee nil) 20 | (ref-set inspectee-content nil) 21 | (ref-set inspectee-parts []) 22 | (ref-set inspectee-actions []) 23 | (ref-set inspector-stack nil) 24 | (ref-set inspector-history []))) 25 | 26 | (defn inspectee-title [obj] 27 | (cond 28 | (instance? clojure.lang.LazySeq obj) (str "clojure.lang.LazySeq@...") 29 | :else (str obj))) 30 | 31 | (defn print-part-to-string [value] 32 | (let [s (inspectee-title value) 33 | pos (position #{value} @inspector-history)] 34 | (if pos 35 | (str "#" pos "=" s) 36 | s))) 37 | 38 | (defn assign-index [o dest] 39 | (dosync 40 | (let [index (count @dest)] 41 | (alter dest conj o) 42 | index))) 43 | 44 | (defn value-part [obj s] 45 | (list :value (or s (print-part-to-string obj)) 46 | (assign-index obj inspectee-parts))) 47 | 48 | (defn action-part [label lambda refresh?] 49 | (list :action label 50 | (assign-index (list lambda refresh?) 51 | inspectee-actions))) 52 | 53 | (defn label-value-line 54 | ([label value] (label-value-line label value true)) 55 | ([label value newline?] 56 | (list* (str label) ": " (list :value value) 57 | (if newline? '((:newline)) nil)))) 58 | 59 | (defmacro label-value-line* [& label-values] 60 | `(concat ~@(map (fn [[label value]] 61 | `(label-value-line ~label ~value)) 62 | label-values))) 63 | 64 | ;; Inspection 65 | 66 | ;; This is the simple version that only knows about clojure stuff. 67 | ;; Many of these will probably be redefined by swank-clojure-debug 68 | (defmulti emacs-inspect 69 | (fn known-types [obj] 70 | (cond 71 | (map? obj) :map 72 | (vector? obj) :vector 73 | (var? obj) :var 74 | (string? obj) :string 75 | (seq? obj) :seq 76 | (instance? Class obj) :class 77 | (instance? clojure.lang.Namespace obj) :namespace 78 | (instance? clojure.lang.ARef obj) :aref 79 | (.isArray (class obj)) :array))) 80 | 81 | (defn inspect-meta-information [obj] 82 | (when (> (count (meta obj)) 0) 83 | (concat 84 | '("Meta Information: " (:newline)) 85 | (mapcat (fn [[key val]] 86 | `(" " (:value ~key) " = " (:value ~val) (:newline))) 87 | (meta obj))))) 88 | 89 | (defmethod emacs-inspect :map [obj] 90 | (concat 91 | (label-value-line* 92 | ("Class" (class obj)) 93 | ("Count" (count obj))) 94 | '("Contents: " (:newline)) 95 | (inspect-meta-information obj) 96 | (mapcat (fn [[key val]] 97 | `(" " (:value ~key) " = " (:value ~val) 98 | (:newline))) 99 | obj))) 100 | 101 | (defmethod emacs-inspect :vector [obj] 102 | (concat 103 | (label-value-line* 104 | ("Class" (class obj)) 105 | ("Count" (count obj))) 106 | '("Contents: " (:newline)) 107 | (inspect-meta-information obj) 108 | (mapcat (fn [i val] 109 | `(~(str " " i ". ") (:value ~val) (:newline))) 110 | (iterate inc 0) 111 | obj))) 112 | 113 | (defmethod emacs-inspect :array [obj] 114 | (concat 115 | (label-value-line* 116 | ("Class" (class obj)) 117 | ("Count" (alength obj)) 118 | ("Component Type" (.getComponentType (class obj)))) 119 | '("Contents: " (:newline)) 120 | (mapcat (fn [i val] 121 | `(~(str " " i ". ") (:value ~val) (:newline))) 122 | (iterate inc 0) 123 | obj))) 124 | 125 | (defmethod emacs-inspect :var [#^clojure.lang.Var obj] 126 | (concat 127 | (label-value-line* 128 | ("Class" (class obj))) 129 | (inspect-meta-information obj) 130 | (when (.isBound obj) 131 | `("Value: " (:value ~(var-get obj)))))) 132 | 133 | (defmethod emacs-inspect :string [obj] 134 | (concat 135 | (label-value-line* 136 | ("Class" (class obj))) 137 | (inspect-meta-information 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 | '("Contents: " (:newline)) 145 | (inspect-meta-information obj) 146 | (mapcat (fn [i val] 147 | `(~(str " " i ". ") (:value ~val) (:newline))) 148 | (iterate inc 0) 149 | obj))) 150 | 151 | (defmethod emacs-inspect :default [obj] 152 | (let [fields (. (class obj) getDeclaredFields) 153 | names (map (memfn getName) fields) 154 | get (fn [f] 155 | (try (.setAccessible f true) 156 | (catch java.lang.SecurityException e)) 157 | (try (.get f obj) 158 | (catch java.lang.IllegalAccessException e 159 | "Access denied."))) 160 | vals (map get fields)] 161 | (concat 162 | `("Type: " (:value ~(class obj)) (:newline) 163 | "Value: " (:value ~obj) (:newline) 164 | "---" (:newline) 165 | "Fields: " (:newline)) 166 | (mapcat 167 | (fn [name val] 168 | `(~(str " " name ": ") (:value ~val) (:newline))) names vals)))) 169 | 170 | (defmethod emacs-inspect :class [#^Class obj] 171 | (let [meths (. obj getMethods) 172 | fields (. obj getFields)] 173 | (concat 174 | `("Type: " (:value ~(class obj)) (:newline) 175 | "---" (:newline) 176 | "Fields: " (:newline)) 177 | (mapcat (fn [f] 178 | `(" " (:value ~f) (:newline))) fields) 179 | '("---" (:newline) 180 | "Methods: " (:newline)) 181 | (mapcat (fn [m] 182 | `(" " (:value ~m) (:newline))) meths)))) 183 | 184 | (defmethod emacs-inspect :aref [#^clojure.lang.ARef obj] 185 | `("Type: " (:value ~(class obj)) (:newline) 186 | "Value: " (:value ~(deref obj)) (:newline))) 187 | 188 | (defn ns-refers-by-ns [#^clojure.lang.Namespace ns] 189 | (group-by (fn [#^clojure.lang.Var v] (. v ns)) 190 | (map val (ns-refers ns)))) 191 | 192 | (defmethod emacs-inspect :namespace [#^clojure.lang.Namespace obj] 193 | (concat 194 | (label-value-line* 195 | ("Class" (class obj)) 196 | ("Count" (count (ns-map obj)))) 197 | '("---" (:newline) 198 | "Refer from: " (:newline)) 199 | (mapcat (fn [[ns refers]] 200 | `(" "(:value ~ns) " = " (:value ~refers) (:newline))) 201 | (ns-refers-by-ns obj)) 202 | (label-value-line* 203 | ("Imports" (ns-imports obj)) 204 | ("Interns" (ns-interns obj))))) 205 | 206 | (defn inspector-content [specs] 207 | (letfn [(spec-seq [seq] 208 | (let [[f & args] seq] 209 | (cond 210 | (= f :newline) (str \newline) 211 | 212 | (= f :value) 213 | (let [[obj & [str]] args] 214 | (value-part obj str)) 215 | 216 | (= f :action) 217 | (let [[label lambda & options] args 218 | {:keys [refresh?]} (apply hash-map options)] 219 | (action-part label lambda refresh?))))) 220 | (spec-value [val] 221 | (cond 222 | (string? val) val 223 | (seq? val) (spec-seq val)))] 224 | (map spec-value specs))) 225 | 226 | ;; Works for infinite sequences, but it lies about length. Luckily, emacs doesn't 227 | ;; care. 228 | (defn content-range [lst start end] 229 | (let [amount-wanted (- end start) 230 | shifted (drop start lst) 231 | taken (take amount-wanted shifted) 232 | amount-taken (count taken)] 233 | (if (< amount-taken amount-wanted) 234 | (list taken (+ amount-taken start) start end) 235 | ;; There's always more until we know there isn't 236 | (list taken (+ end 500) start end)))) 237 | 238 | (defn inspect-object [o] 239 | (dosync 240 | (ref-set inspectee o) 241 | (alter inspector-stack conj o) 242 | (when-not (filter #(identical? o %) @inspector-history) 243 | (alter inspector-history conj o)) 244 | (ref-set inspectee-content (inspector-content (emacs-inspect o))) 245 | (list :title (inspectee-title o) 246 | :id (assign-index o inspectee-parts) 247 | :content (content-range @inspectee-content 0 500)))) 248 | 249 | (defslimefn init-inspector [string] 250 | (with-emacs-package 251 | (reset-inspector) 252 | (inspect-object (eval (read-string string))))) 253 | 254 | (defn inspect-in-emacs [what] 255 | (letfn [(send-it [] 256 | (with-emacs-package 257 | (reset-inspector) 258 | (send-to-emacs `(:inspect ~(inspect-object what)))))] 259 | (cond 260 | *current-connection* (send-it) 261 | (comment (first @connections)) 262 | ;; TODO: take a second look at this, will probably need garbage collection on connections 263 | (comment 264 | (binding [*current-connection* (first @connections)] 265 | (send-it)))))) 266 | 267 | (defslimefn inspect-frame-var [frame index] 268 | (if (and (zero? frame) *current-env*) 269 | (let [locals *current-env* 270 | object (locals (nth (keys locals) index))] 271 | (with-emacs-package 272 | (reset-inspector) 273 | (inspect-object object))))) 274 | 275 | (defslimefn inspector-nth-part [index] 276 | (get @inspectee-parts index)) 277 | 278 | (defslimefn inspect-nth-part [index] 279 | (with-emacs-package 280 | (inspect-object ((slime-fn 'inspector-nth-part) index)))) 281 | 282 | (defslimefn inspector-range [from to] 283 | (content-range @inspectee-content from to)) 284 | 285 | (defn ref-pop [ref] 286 | (let [[f & r] @ref] 287 | (ref-set ref r) 288 | f)) 289 | 290 | (defslimefn inspector-call-nth-action [index & args] 291 | (let [[fn refresh?] (get @inspectee-actions index)] 292 | (apply fn args) 293 | (if refresh? 294 | (inspect-object (dosync (ref-pop inspector-stack))) 295 | nil))) 296 | 297 | (defslimefn inspector-pop [] 298 | (with-emacs-package 299 | (cond 300 | (rest @inspector-stack) 301 | (inspect-object 302 | (dosync 303 | (ref-pop inspector-stack) 304 | (ref-pop inspector-stack))) 305 | :else nil))) 306 | 307 | (defslimefn inspector-next [] 308 | (with-emacs-package 309 | (let [pos (position #{@inspectee} @inspector-history)] 310 | (cond 311 | (= (inc pos) (count @inspector-history)) nil 312 | :else (inspect-object (get @inspector-history (inc pos))))))) 313 | 314 | (defslimefn inspector-reinspect [] 315 | (inspect-object @inspectee)) 316 | 317 | (defslimefn quit-inspector [] 318 | (reset-inspector) 319 | nil) 320 | 321 | (defslimefn describe-inspectee [] 322 | (with-emacs-package 323 | (str @inspectee))) 324 | -------------------------------------------------------------------------------- /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 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 [i (proxy-super read)] 21 | (.append text (char i)) 22 | i)))] 23 | (read (PushbackReader. pbr)) 24 | (str text)))))) 25 | 26 | (defn- recursive-contains? [coll obj] 27 | "True if coll contains obj. Obj can't be a seq" 28 | (not (empty? (filter #(= obj %) (flatten coll))))) 29 | 30 | (defn- does-var-call-fn [var fn] 31 | "Checks if a var calls a function named 'fn" 32 | (if-let [source (get-source-from-var var)] 33 | (let [node (read-string source)] 34 | (if (recursive-contains? node fn) 35 | var 36 | false)))) 37 | 38 | (defn- does-ns-refer-to-var? [ns var] 39 | (ns-resolve ns var)) 40 | 41 | (defn all-vars-who-call [sym] 42 | (filter 43 | ifn? 44 | (filter 45 | #(identity %) 46 | (map #(does-var-call-fn % sym) 47 | (flatten 48 | (map vals 49 | (map ns-interns 50 | (filter #(does-ns-refer-to-var? % sym) 51 | (all-ns))))))))) 52 | -------------------------------------------------------------------------------- /src/swank/core.clj: -------------------------------------------------------------------------------- 1 | (ns swank.core 2 | (:use (swank util commands) 3 | (swank.util hooks) 4 | (swank.util.concurrent thread) 5 | (swank.core connection hooks threadmap)) 6 | (:require (swank.util.concurrent [mbox :as mb]))) 7 | 8 | ;; Protocol version 9 | (defonce protocol-version (atom "20100404")) 10 | 11 | ;; Emacs packages 12 | (def #^{:dynamic true} *current-package*) 13 | 14 | ;; current emacs eval id 15 | (def #^{:dynamic true} *pending-continuations* '()) 16 | 17 | (def sldb-stepping-p nil) 18 | (def sldb-initial-frames 10) 19 | (def #^{:dynamic true} #^{:doc "The current level of recursive debugging."} 20 | *sldb-level* 0) 21 | (def #^{:dynamic true} #^{:doc "The current restarts."} 22 | *sldb-restarts* 0) 23 | 24 | (def #^{:doc "Include swank-clojure thread in stack trace for debugger."} 25 | debug-swank-clojure false) 26 | 27 | (defonce active-threads (ref ())) 28 | 29 | (defn maybe-ns [package] 30 | (cond 31 | (symbol? package) (or (find-ns package) (maybe-ns 'user)) 32 | (string? package) (maybe-ns (symbol package)) 33 | (keyword? package) (maybe-ns (name package)) 34 | (instance? clojure.lang.Namespace package) package 35 | :else (maybe-ns 'user))) 36 | 37 | (defmacro with-emacs-package [& body] 38 | `(binding [*ns* (maybe-ns *current-package*)] 39 | ~@body)) 40 | 41 | (defmacro with-package-tracking [& body] 42 | `(let [last-ns# *ns*] 43 | (try 44 | ~@body 45 | (finally 46 | (when-not (= last-ns# *ns*) 47 | (send-to-emacs `(:new-package ~(str (ns-name *ns*)) 48 | ~(str (ns-name *ns*))))))))) 49 | 50 | (defmacro dothread-swank [& body] 51 | `(dothread-keeping-clj [*current-connection*] 52 | ~@body)) 53 | 54 | ;; Exceptions for debugging 55 | (defonce debug-quit-exception (Exception. "Debug quit")) 56 | (defonce debug-continue-exception (Exception. "Debug continue")) 57 | (defonce debug-abort-exception (Exception. "Debug abort")) 58 | 59 | (def #^{:dynamic true} #^Throwable *current-exception* nil) 60 | 61 | ;; Local environment 62 | (def #^{:dynamic true} *current-env* nil) 63 | 64 | (let [&env :unavailable] 65 | (defmacro local-bindings 66 | "Produces a map of the names of local bindings to their values." 67 | [] 68 | (if-not (= &env :unavailable) 69 | (let [symbols (keys &env)] 70 | (zipmap (map (fn [sym] `(quote ~sym)) symbols) symbols))))) 71 | 72 | ;; Handle Evaluation 73 | (defn send-to-emacs 74 | "Sends a message (msg) to emacs." 75 | ([msg] 76 | (mb/send @(*current-connection* :control-thread) msg))) 77 | 78 | (defn send-repl-results-to-emacs [val] 79 | (send-to-emacs `(:write-string ~(str (pr-str val) "\n") :repl-result))) 80 | 81 | (defn with-env-locals 82 | "Evals a form with given locals. The locals should be a map of symbols to 83 | values." 84 | [form] 85 | (if (seq *current-env*) 86 | `(let ~(vec (mapcat #(list % `(*current-env* '~%)) (keys *current-env*))) 87 | ~form) 88 | form)) 89 | 90 | (defn eval-in-emacs-package [form] 91 | (with-emacs-package 92 | (eval form))) 93 | 94 | 95 | (defn eval-from-control 96 | "Blocks for a mbox message from the control thread and executes it 97 | when received. The mbox message is expected to be a slime-fn." 98 | ([] (let [form (mb/receive (current-thread))] 99 | (apply (ns-resolve *ns* (first form)) (rest form))))) 100 | 101 | (defn eval-loop 102 | "A loop which continuosly reads actions from the control thread and 103 | evaluates them (will block if no mbox message is available)." 104 | ([] (continuously (eval-from-control)))) 105 | 106 | (defn exception-causes [#^Throwable t] 107 | (lazy-seq 108 | (cons t (when-let [cause (.getCause t)] 109 | (exception-causes cause))))) 110 | 111 | (defn- debug-quit-exception? [t] 112 | (some #(identical? debug-quit-exception %) (exception-causes t))) 113 | 114 | (defn- debug-continue-exception? [t] 115 | (some #(identical? debug-continue-exception %) (exception-causes t))) 116 | 117 | (defn- debug-abort-exception? [t] 118 | (some #(identical? debug-abort-exception %) (exception-causes t))) 119 | 120 | (defn exception-stacktrace [t] 121 | (map #(list %1 %2 '(:restartable nil)) 122 | (iterate inc 0) 123 | (map str (.getStackTrace t)))) 124 | 125 | (defn debugger-condition-for-emacs [] 126 | (list (or (.getMessage *current-exception*) "No message.") 127 | (str " [Thrown " (class *current-exception*) "]") 128 | nil)) 129 | 130 | (defn make-restart [kw name description f] 131 | [kw [name description f]]) 132 | 133 | (defn add-restart-if [condition restarts kw name description f] 134 | (if condition 135 | (conj restarts (make-restart kw name description f)) 136 | restarts)) 137 | 138 | (declare sldb-debug) 139 | (defn cause-restart-for [thrown depth] 140 | (make-restart 141 | (keyword (str "cause" depth)) 142 | (str "CAUSE" depth) 143 | (str "Invoke debugger on cause " 144 | (apply str (take depth (repeat " "))) 145 | (.getMessage thrown) 146 | " [Thrown " (class thrown) "]") 147 | (partial sldb-debug nil thrown *pending-continuations*))) 148 | 149 | (defn add-cause-restarts [restarts thrown] 150 | (loop [restarts restarts 151 | cause (.getCause thrown) 152 | level 1] 153 | (if cause 154 | (recur 155 | (conj restarts (cause-restart-for cause level)) 156 | (.getCause cause) 157 | (inc level)) 158 | restarts))) 159 | 160 | (defn calculate-restarts [thrown] 161 | (let [restarts [(make-restart :quit "QUIT" "Quit to the SLIME top level" 162 | (fn [] (throw debug-quit-exception)))] 163 | restarts (add-restart-if 164 | (pos? *sldb-level*) 165 | restarts 166 | :abort "ABORT" (str "ABORT to SLIME level " (dec *sldb-level*)) 167 | (fn [] (throw debug-abort-exception))) 168 | restarts (add-restart-if 169 | (and (.getMessage thrown) 170 | (.contains (.getMessage thrown) "BREAK")) 171 | restarts 172 | :continue "CONTINUE" (str "Continue from breakpoint") 173 | (fn [] (throw debug-continue-exception))) 174 | restarts (add-cause-restarts restarts thrown)] 175 | (into (array-map) restarts))) 176 | 177 | (defn format-restarts-for-emacs [] 178 | (doall (map #(list (first (second %)) (second (second %))) *sldb-restarts*))) 179 | 180 | (defn build-backtrace [start end] 181 | (doall (take (- end start) (drop start (exception-stacktrace *current-exception*))))) 182 | 183 | (defn build-debugger-info-for-emacs [start end] 184 | (list (debugger-condition-for-emacs) 185 | (format-restarts-for-emacs) 186 | (build-backtrace start end) 187 | *pending-continuations*)) 188 | 189 | (defn sldb-loop 190 | "A loop that is intented to take over an eval thread when a debug is 191 | encountered (an continue to perform the same thing). It will 192 | continue until a *debug-quit* exception is encountered." 193 | [level] 194 | (try 195 | (send-to-emacs 196 | (list* :debug (current-thread) level 197 | (build-debugger-info-for-emacs 0 sldb-initial-frames))) 198 | ([] (continuously 199 | (do 200 | (send-to-emacs `(:debug-activate ~(current-thread) ~level nil)) 201 | (eval-from-control)))) 202 | (catch Throwable t 203 | (send-to-emacs 204 | `(:debug-return ~(current-thread) ~*sldb-level* ~sldb-stepping-p)) 205 | (if-not (debug-continue-exception? t) 206 | (throw t))))) 207 | 208 | (defn invoke-debugger 209 | [locals #^Throwable thrown id] 210 | (binding [*current-env* locals 211 | *current-exception* thrown 212 | *sldb-restarts* (calculate-restarts thrown) 213 | *sldb-level* (inc *sldb-level*)] 214 | (sldb-loop *sldb-level*))) 215 | 216 | (defn sldb-debug [locals thrown id] 217 | (try 218 | (invoke-debugger nil thrown id) 219 | (catch Throwable t 220 | (when (and (pos? *sldb-level*) 221 | (not (debug-abort-exception? t))) 222 | (throw t))))) 223 | 224 | (defmacro break 225 | [] 226 | `(invoke-debugger (local-bindings) (Exception. "BREAK:") *pending-continuations*)) 227 | 228 | (defn doall-seq [coll] 229 | (if (seq? coll) 230 | (doall coll) 231 | coll)) 232 | 233 | (defn eval-for-emacs [form buffer-package id] 234 | (try 235 | (binding [*current-package* buffer-package 236 | *pending-continuations* (cons id *pending-continuations*)] 237 | (if-let [f (slime-fn (first form))] 238 | (let [form (cons f (rest form)) 239 | result (doall-seq (eval-in-emacs-package form))] 240 | (run-hook pre-reply-hook) 241 | (send-to-emacs `(:return ~(thread-name (current-thread)) 242 | (:ok ~result) ~id))) 243 | ;; swank function not defined, abort 244 | (send-to-emacs `(:return ~(thread-name (current-thread)) (:abort) ~id)))) 245 | (catch Throwable t 246 | ;; Thread/interrupted clears this thread's interrupted status; if 247 | ;; Thread.stop was called on us it may be set and will cause an 248 | ;; InterruptedException in one of the send-to-emacs calls below 249 | (Thread/interrupted) 250 | 251 | ;; (.printStackTrace t #^java.io.PrintWriter *err*) 252 | 253 | (cond 254 | (debug-quit-exception? t) 255 | (do 256 | (send-to-emacs `(:return ~(thread-name (current-thread)) (:abort) ~id)) 257 | (if-not (zero? *sldb-level*) 258 | (throw t))) 259 | 260 | (debug-abort-exception? t) 261 | (do 262 | (send-to-emacs `(:return ~(thread-name (current-thread)) (:abort) ~id)) 263 | (if-not (zero? *sldb-level*) 264 | (throw debug-abort-exception))) 265 | 266 | (debug-continue-exception? t) 267 | (do 268 | (send-to-emacs `(:return ~(thread-name (current-thread)) (:abort) ~id)) 269 | (throw t)) 270 | 271 | :else 272 | (do 273 | (set! *e t) 274 | (try 275 | (sldb-debug 276 | nil 277 | (if debug-swank-clojure t (or (.getCause t) t)) 278 | id) 279 | ;; reply with abort 280 | (finally (send-to-emacs `(:return ~(thread-name (current-thread)) (:abort) ~id))))))))) 281 | 282 | (defn- add-active-thread [thread] 283 | (dosync 284 | (commute active-threads conj thread))) 285 | 286 | (defn- remove-active-thread [thread] 287 | (dosync 288 | (commute active-threads (fn [threads] (remove #(= % thread) threads))))) 289 | 290 | (defn spawn-worker-thread 291 | "Spawn an thread that blocks for a single command from the control 292 | thread, executes it, then terminates." 293 | ([conn] 294 | (dothread-swank 295 | (try 296 | (add-active-thread (current-thread)) 297 | (thread-set-name "Swank Worker Thread") 298 | (eval-from-control) 299 | (finally 300 | (remove-active-thread (current-thread))))))) 301 | 302 | (defn spawn-repl-thread 303 | "Spawn an thread that sets itself as the current 304 | connection's :repl-thread and then enters an eval-loop" 305 | ([conn] 306 | (dothread-swank 307 | (thread-set-name "Swank REPL Thread") 308 | (with-connection conn 309 | (eval-loop))))) 310 | 311 | (defn find-or-spawn-repl-thread 312 | "Returns the current connection's repl-thread or create a new one if 313 | the existing one does not exist." 314 | ([conn] 315 | ;; TODO - check if an existing repl-agent is still active & doesn't have errors 316 | (dosync 317 | (or (when-let [conn-repl-thread @(conn :repl-thread)] 318 | (when (.isAlive #^Thread conn-repl-thread) 319 | conn-repl-thread)) 320 | (ref-set (conn :repl-thread) 321 | (spawn-repl-thread conn)))))) 322 | 323 | (defn thread-for-evaluation 324 | "Given an id and connection, find or create the appropiate agent." 325 | ([id conn] 326 | (cond 327 | (= id true) (spawn-worker-thread conn) 328 | (= id :repl-thread) (find-or-spawn-repl-thread conn) 329 | :else (find-thread id)))) 330 | 331 | ;; Handle control 332 | (defn read-loop 333 | "A loop that reads from the socket (will block when no message 334 | available) and dispatches the message to the control thread." 335 | ([conn control] 336 | (with-connection conn 337 | (continuously (mb/send control (read-from-connection conn)))))) 338 | 339 | (defn dispatch-event 340 | "Dispatches/executes an event in the control thread's mailbox queue." 341 | ([ev conn] 342 | (let [[action & args] ev] 343 | (cond 344 | (= action :emacs-rex) 345 | (let [[form-string package thread id] args 346 | thread (thread-for-evaluation thread conn)] 347 | (mb/send thread `(eval-for-emacs ~form-string ~package ~id))) 348 | 349 | (= action :return) 350 | (let [[thread & ret] args] 351 | (binding [*print-level* nil, *print-length* nil] 352 | (write-to-connection conn `(:return ~@ret)))) 353 | 354 | (one-of? action 355 | :presentation-start :presentation-end 356 | :new-package :new-features :ed :percent-apply 357 | :indentation-update 358 | :eval-no-wait :background-message :inspect) 359 | (binding [*print-level* nil, *print-length* nil] 360 | (write-to-connection conn ev)) 361 | 362 | (= action :write-string) 363 | (write-to-connection conn ev) 364 | 365 | (one-of? action 366 | :debug :debug-condition :debug-activate :debug-return) 367 | (let [[thread & args] args] 368 | (write-to-connection conn `(~action ~(thread-map-id thread) ~@args))) 369 | 370 | (= action :emacs-interrupt) 371 | (let [[thread & args] args] 372 | (dosync 373 | (cond 374 | (and (true? thread) (seq @active-threads)) 375 | (.stop #^Thread (first @active-threads)) 376 | (= thread :repl-thread) (.stop #^Thread @(conn :repl-thread))))) 377 | :else 378 | nil)))) 379 | 380 | ;; Main loop definitions 381 | (defn control-loop 382 | "A loop that reads from the mbox queue and runs dispatch-event on 383 | it (will block if no mbox control message is available). This is 384 | intended to only be run on the control thread." 385 | ([conn] 386 | (binding [*1 nil, *2 nil, *3 nil, *e nil] 387 | (with-connection conn 388 | (continuously (dispatch-event (mb/receive (current-thread)) conn)))))) 389 | -------------------------------------------------------------------------------- /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/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 [len (Integer/parseInt (read-chars reader 6 read-fail-exception) 16) 42 | msg (read-chars reader len read-fail-exception) 43 | form (try 44 | (read-string (fix-namespace msg)) 45 | (catch Exception ex 46 | (.println System/err (format "unreadable message: %s" msg)) 47 | (throw ex)))] 48 | (if (seq? form) 49 | (deep-replace {'t true} form) 50 | form)))) 51 | -------------------------------------------------------------------------------- /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 InputStreamReader OutputStreamWriter) 8 | (java.net Socket))) 9 | 10 | ;; The swank.core.server is the layer above swank.util.net.sockets 11 | ;; - Manages the socket server 12 | ;; - Accepts and authenticates incoming connections 13 | ;; - Creates swank.core.connections 14 | ;; - Spins up new threads 15 | 16 | (defonce connections (ref [])) 17 | 18 | (def slime-secret-path (str (user-home-path) File/separator ".slime-secret")) 19 | 20 | (defn- slime-secret 21 | "Returns the first line from the slime-secret file, path found in 22 | slime-secret-path (default: .slime-secret in the user's home 23 | directory). 24 | 25 | See also: `accept-authenticated-connection'" 26 | ([] (failing-gracefully 27 | (let [slime-secret-file (File. (str (user-home-path) File/separator ".slime-secret"))] 28 | (when (and (.isFile slime-secret-file) (.canRead slime-secret-file)) 29 | (with-open [secret (BufferedReader. (FileReader. slime-secret-file))] 30 | (.readLine secret))))))) 31 | 32 | (defn- accept-authenticated-connection ;; rename to authenticate-socket, takes in a connection 33 | "Accepts and returns new connection if it is from an authenticated 34 | machine. Otherwise, return nil. 35 | 36 | Authentication depends on the contents of a slime-secret file on 37 | both the server (swank) and the client (emacs slime). If no 38 | slime-secret file is provided on the server side, all connections 39 | are accepted. 40 | 41 | See also: `slime-secret'" 42 | ([#^Socket socket opts] 43 | (returning [conn (make-connection socket (get opts :encoding default-encoding))] 44 | (if-let [secret (slime-secret)] 45 | (when-not (= (read-from-connection conn) secret) 46 | (close-socket! socket)) 47 | conn)))) 48 | 49 | (defn- make-output-redirection 50 | ([conn] 51 | (call-on-flush-stream 52 | #(with-connection conn 53 | (send-to-emacs `(:write-string ~%))))) 54 | {:tag java.io.StringWriter}) 55 | 56 | (defn- socket-serve [connection-serve socket opts] 57 | (with-connection (accept-authenticated-connection socket opts) 58 | (let [out-redir (java.io.PrintWriter. (make-output-redirection 59 | *current-connection*))] 60 | (binding [*out* out-redir 61 | *err* out-redir] 62 | (dosync (ref-set (*current-connection* :writer-redir) *out*)) 63 | (dosync (alter connections conj *current-connection*)) 64 | (connection-serve *current-connection*))))) 65 | 66 | ;; Setup frontent 67 | (defn start-swank-socket-server! 68 | "Starts and returns the socket server as a swank host. Takes an 69 | optional set of options as a map: 70 | 71 | :announce - an fn that will be called and provided with the 72 | listening port of the newly established server. Default: none." 73 | ([server connection-serve] (start-swank-socket-server! connection-serve {})) 74 | ([server connection-serve options] 75 | (start-server-socket! server connection-serve) 76 | (when-let [announce (options :announce)] 77 | (announce (.getLocalPort server))) 78 | server)) 79 | 80 | (defn setup-server 81 | "The port it started on will be called as an argument to (announce-fn 82 | port). A connection will then be created and (connection-serve conn) 83 | will then be called." 84 | [port announce-fn connection-serve opts] 85 | (start-swank-socket-server! 86 | (make-server-socket {:port port 87 | :host (opts :host "localhost") 88 | :backlog (opts :backlog 0)}) 89 | #(socket-serve connection-serve % opts) 90 | {:announce announce-fn})) 91 | 92 | ;; Announcement functions 93 | (defn simple-announce [port] 94 | (println "Connection opened on local port " port)) 95 | 96 | (defn announce-port-to-file 97 | "Writes the given port number into a file." 98 | ([#^String file port] 99 | (with-open [out (new java.io.FileWriter file)] 100 | (doto out 101 | (.write (str port "\n")) 102 | (.flush))))) 103 | -------------------------------------------------------------------------------- /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 | (defmacro with-swank-io [& body] 5 | `(binding [*out* @(:writer-redir (first @swank.core.server/connections))] 6 | ~@body)) 7 | -------------------------------------------------------------------------------- /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/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 | (.write (or log-output *out*) (apply format format-string args)) 22 | (.flush (or log-output *out*)) 23 | nil)) 24 | 25 | ;; INPUT 26 | 27 | (defn- read-form 28 | "Read a form that conforms to the swank rpc protocol" 29 | ([#^Reader rdr] 30 | (let [c (.read rdr)] 31 | (condp = (char c) 32 | \" (let [sb (StringBuilder.)] 33 | (loop [] 34 | (let [c (.read rdr)] 35 | (if (= c -1) 36 | (throw (java.io.EOFException. "Incomplete reading of quoted string.")) 37 | (condp = (char c) 38 | \" (str sb) 39 | \\ (do (.append sb (char (.read rdr))) 40 | (recur)) 41 | (do (.append sb (char c)) 42 | (recur))))))) 43 | \( (loop [result []] 44 | (let [form (read-form rdr)] 45 | (let [c (.read rdr)] 46 | (if (= c -1) 47 | (throw (java.io.EOFException. "Incomplete reading of list.")) 48 | (condp = (char c) 49 | \) (sequence (conj result form)) 50 | \space (recur (conj result form))))))) 51 | \' (list 'quote (read-form rdr)) 52 | (let [sb (StringBuilder.)] 53 | (loop [c c] 54 | (if (not= c -1) 55 | (condp = (char c) 56 | \\ (do (.append sb (char (.read rdr))) 57 | (recur (.read rdr))) 58 | \space (.unread rdr c) 59 | \) (.unread rdr c) 60 | (do (.append sb (char c)) 61 | (recur (.read rdr)))))) 62 | (let [str (str sb)] 63 | (cond 64 | (. Character isDigit c) (Integer/parseInt str) 65 | (= "nil" str) nil 66 | (= "t" str) true 67 | :else (symbol str)))))))) 68 | 69 | (defn- read-packet 70 | ([#^Reader reader] 71 | (let [len (Integer/parseInt (read-chars reader 6 swank-protocol-error) 16)] 72 | (read-chars reader len swank-protocol-error)))) 73 | 74 | (defn decode-message 75 | "Read an rpc message encoded using the swank rpc protocol." 76 | ([#^Reader rdr] 77 | (let [packet (read-packet rdr)] 78 | (log-event "READ: %s\n" packet) 79 | (try 80 | (with-open [rdr (PushbackReader. (StringReader. packet))] 81 | (read-form rdr)) 82 | (catch Exception e 83 | (list :reader-error packet e)))))) 84 | 85 | ; (with-open [rdr (StringReader. "00001f(swank:a 123 (%b% (t nil) \"c\"))")] (decode-message rdr)) 86 | 87 | 88 | ;; OUTPUT 89 | 90 | (defmulti print-object (fn [x writer] (type x))) 91 | 92 | (defmethod print-object :default [o, #^Writer w] 93 | (print-method o w)) 94 | 95 | (defmethod print-object Boolean [o, #^Writer w] 96 | (.write w (if o "t" "nil"))) 97 | 98 | (defmethod print-object String [#^String s, #^Writer w] 99 | (let [char-escape-string {\" "\\\"" 100 | \\ "\\\\"}] 101 | (do (.append w \") 102 | (dotimes [n (count s)] 103 | (let [c (.charAt s n) 104 | e (char-escape-string c)] 105 | (if e (.write w e) (.append w c)))) 106 | (.append w \")) 107 | nil)) 108 | 109 | (defmethod print-object clojure.lang.ISeq [o, #^Writer w] 110 | (.write w "(") 111 | (print-object (first o) w) 112 | (doseq [item (rest o)] 113 | (.write w " ") 114 | (print-object item w)) 115 | (.write w ")")) 116 | 117 | (defn- write-form 118 | ([#^Writer writer message] 119 | (print-object message writer))) 120 | 121 | (defn- write-packet 122 | ([#^Writer writer str] 123 | (let [len (.length str)] 124 | (doto writer 125 | (.write (format "%06x" len)) 126 | (.write str) 127 | (.flush))))) 128 | 129 | (defn encode-message 130 | "Write an rpc message encoded using the swank rpc protocol." 131 | ([#^Writer writer message] 132 | (let [str (with-out-str 133 | (write-form *out* message)) ] 134 | (log-event "WRITE: %s\n" str) 135 | (write-packet writer str)))) 136 | 137 | ; (with-out-str (encode-message *out* "hello")) 138 | ; (with-out-str (encode-message *out* '(a 123 (swank:b (true false) "c")))) 139 | 140 | 141 | ;; DISPATCH 142 | 143 | (defonce rpc-fn-map {}) 144 | 145 | (defn register-dispatch 146 | ([name fn] 147 | (register-dispatch name fn #'rpc-fn-map)) 148 | ([name fn fn-map] 149 | (alter-var-root fn-map assoc name fn))) 150 | 151 | (defn dispatch-message 152 | ([message fn-map] 153 | (let [operation (first message) 154 | operands (rest message) 155 | fn (fn-map operation)] 156 | (assert fn) 157 | (apply fn operands))) 158 | ([message] 159 | (dispatch-message message rpc-fn-map))) 160 | -------------------------------------------------------------------------------- /src/swank/swank.clj: -------------------------------------------------------------------------------- 1 | ;;;; swank-clojure.clj --- Swank server for Clojure 2 | ;;; 3 | ;;; Copyright (C) 2008 Jeffrey Chu 4 | ;;; 5 | ;;; This file is licensed under the terms of the GNU General Public 6 | ;;; License as distributed with Emacs (press C-h C-c to view it). 7 | ;;; 8 | ;;; See README file for more information about installation 9 | ;;; 10 | 11 | (ns swank.swank 12 | (:use [swank.core] 13 | [swank.core connection server] 14 | [swank.util.concurrent thread] 15 | [swank.util.net sockets] 16 | [clojure.main :only [repl]]) 17 | (:require [swank.commands] 18 | [swank.commands basic indent completion 19 | contrib inspector]) 20 | (:import [java.lang System] 21 | [java.io File]) 22 | (:gen-class)) 23 | 24 | (defn ignore-protocol-version [version] 25 | (reset! protocol-version version)) 26 | 27 | (defn- connection-serve [conn] 28 | (let [control 29 | (dothread-swank 30 | (thread-set-name "Swank Control Thread") 31 | (try 32 | (control-loop conn) 33 | (catch Exception e 34 | ;; fail silently 35 | nil)) 36 | (close-socket! (conn :socket))) 37 | read 38 | (dothread-swank 39 | (thread-set-name "Read Loop Thread") 40 | (try 41 | (read-loop conn control) 42 | (catch Exception e 43 | ;; This could be put somewhere better 44 | (.println System/err "exception in read loop") 45 | (.printStackTrace e) 46 | (.interrupt control) 47 | (dosync (alter connections (partial remove #{conn}))))))] 48 | (dosync 49 | (ref-set (conn :control-thread) control) 50 | (ref-set (conn :read-thread) read)))) 51 | 52 | (defn start-server 53 | "Start the server and write the listen port number to 54 | PORT-FILE. This is the entry point for Emacs." 55 | [port-file & opts] 56 | (let [opts (apply hash-map opts)] 57 | (setup-server (get opts :port 0) 58 | (fn announce-port [port] 59 | (announce-port-to-file port-file port) 60 | (simple-announce port)) 61 | connection-serve 62 | opts))) 63 | 64 | (def #^{:private true} encodings-map 65 | {"UTF-8" "utf-8-unix" 66 | }) 67 | 68 | (defn- get-system-encoding [] 69 | (when-let [enc-name (.name (java.nio.charset.Charset/defaultCharset))] 70 | (encodings-map enc-name))) 71 | 72 | (defn start-repl 73 | "Start the server wrapped in a repl. Use this to embed swank in your code." 74 | ([port & opts] 75 | (let [stop (atom false) 76 | opts (merge {:port (Integer. port) 77 | :encoding (or (System/getProperty "swank.encoding") 78 | (get-system-encoding) 79 | "iso-latin-1-unix")} 80 | (apply hash-map opts))] 81 | (repl :read (fn [rprompt rexit] 82 | (if @stop rexit 83 | (do (reset! stop true) 84 | `(start-server (-> "java.io.tmpdir" 85 | (System/getProperty) 86 | (File. "slime-port.txt") 87 | (.getCanonicalPath)) 88 | ~@(apply concat opts))))) 89 | :need-prompt (constantly false)))) 90 | ([] (start-repl 4005))) 91 | 92 | (def -main start-repl) 93 | -------------------------------------------------------------------------------- /src/swank/util.clj: -------------------------------------------------------------------------------- 1 | (ns swank.util 2 | (:import (java.io StringReader) 3 | (clojure.lang LineNumberingPushbackReader))) 4 | 5 | (defmacro one-of? 6 | "Short circuiting value comparison." 7 | ([val & possible] 8 | (let [v (gensym)] 9 | `(let [~v ~val] 10 | (or ~@(map (fn [p] `(= ~v ~p)) possible)))))) 11 | 12 | (defn find-first 13 | "Returns the first entry in a coll matches a given predicate." 14 | ([coll] (find-first identity coll)) 15 | ([pred coll] 16 | (first (filter pred coll)))) 17 | 18 | (defn position 19 | "Finds the first position of an item that matches a given predicate 20 | within col. Returns nil if not found. Optionally provide a start 21 | offset to search from." 22 | ([pred coll] (position pred coll 0)) 23 | ([pred coll start] 24 | (loop [coll (drop start coll), i start] 25 | (when (seq coll) 26 | (if (pred (first coll)) 27 | i 28 | (recur (rest coll) (inc i)))))) 29 | {:tag Integer}) 30 | 31 | (when-not (ns-resolve 'clojure.core 'group-by) 32 | ;; TODO: not sure why eval is necessary here; breaks without it. 33 | (eval '(defn group-by 34 | "Categorizes elements within a coll into a map based on a function." 35 | ([f coll] 36 | (reduce 37 | (fn [ret x] 38 | (let [k (f x)] 39 | (assoc ret k (conj (get ret k []) x)))) 40 | {}))))) 41 | 42 | (when-not (ns-resolve 'clojure.core 'flatten) 43 | (eval '(defn flatten [x] 44 | (filter (complement sequential?) 45 | (rest (tree-seq sequential? seq x)))))) 46 | 47 | (defmacro returning [[var ret] & body] 48 | `(let [~var ~ret] 49 | ~@body 50 | ~var)) 51 | 52 | 53 | (defn deep-replace [smap coll] 54 | (map #(if (or (seq? %) (vector? %)) 55 | (deep-replace smap %) 56 | %) 57 | (replace smap coll))) 58 | 59 | (defmacro keep-bindings [bindings f] 60 | (let [bind-vars (take (count bindings) (repeatedly gensym))] 61 | `(let [~@(interleave bind-vars bindings)] 62 | (fn [& args#] 63 | (binding [~@(interleave bindings bind-vars)] 64 | (apply ~f args#)))))) 65 | 66 | (defmacro continuously [& body] 67 | `(loop [] ~@body (recur))) 68 | 69 | (defmacro failing-gracefully [& body] 70 | `(try 71 | ~@body 72 | (catch Throwable _# nil))) 73 | -------------------------------------------------------------------------------- /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 | ;;; Path scanning 54 | 55 | (defmulti path-class-files 56 | "Returns a list of classes found on the specified path location 57 | (jar or directory), each comprised of a map with the following keys: 58 | :name Java class or Clojure namespace name 59 | :loc Classpath entry (directory or jar) on which the class is located 60 | :file Path of the class file, relative to :loc" 61 | (fn [#^ File f _] 62 | (cond (.isDirectory f) :dir 63 | (jar-file? (.getName f)) :jar 64 | (class-file? (.getName f)) :class))) 65 | 66 | (defmethod path-class-files :default 67 | [& _] []) 68 | 69 | (defmethod path-class-files :jar 70 | ;; Build class info for all jar entry class files. 71 | [#^File f #^File loc] 72 | (let [lp (.getPath loc)] 73 | (try 74 | (map (fn [fp] {:loc lp :file fp :name (class-or-ns-name fp)}) 75 | (filter class-file? 76 | (map #(.getName #^JarEntry %) 77 | (enumeration-seq (.entries (JarFile. f)))))) 78 | (catch Exception e [])))) ; fail gracefully if jar is unreadable 79 | 80 | (defmethod path-class-files :dir 81 | ;; Dispatch directories and files (excluding jars) recursively. 82 | [#^File d #^File loc] 83 | (let [fs (.listFiles d (proxy [FilenameFilter] [] 84 | (accept [d n] (not (jar-file? n)))))] 85 | (reduce concat (for [f fs] (path-class-files f loc))))) 86 | 87 | (defmethod path-class-files :class 88 | ;; Build class info using file path relative to parent classpath entry 89 | ;; location. Make sure it decends; a class can't be on classpath directly. 90 | [#^File f #^File loc] 91 | (let [fp (.getPath f), lp (.getPath loc) 92 | m (re-matcher (re-pattern (Pattern/quote 93 | (str "^" lp File/separator))) fp)] 94 | (if (not (.find m)) ; must be descendent of loc 95 | [] 96 | (let [fpr (.substring fp (.end m))] 97 | [{:loc lp :file fpr :name (class-or-ns-name fpr)}])))) 98 | 99 | ;;; Classpath expansion 100 | 101 | (def java-version 102 | (Float/parseFloat (.substring (System/getProperty "java.version") 0 3))) 103 | 104 | (defn expand-wildcard 105 | "Expands a wildcard path entry to its matching .jar files (JDK 1.6+). 106 | If not expanding, returns the path entry as a single-element vector." 107 | [#^String path] 108 | (let [f (File. path)] 109 | (if (and (= (.getName f) "*") (>= java-version 1.6)) 110 | (-> f .getParentFile 111 | (.list (proxy [FilenameFilter] [] 112 | (accept [d n] (jar-file? n))))) 113 | [f]))) 114 | 115 | (defn scan-paths 116 | "Takes one or more classpath strings, scans each classpath entry location, and 117 | returns a list of all class file paths found, each relative to its parent 118 | directory or jar on the classpath." 119 | ([cp] 120 | (if cp 121 | (let [entries (enumeration-seq 122 | (StringTokenizer. cp File/pathSeparator)) 123 | locs (mapcat expand-wildcard entries)] 124 | (reduce concat (for [loc locs] (path-class-files loc loc)))) 125 | ())) 126 | ([cp & more] 127 | (reduce #(concat %1 (scan-paths %2)) (scan-paths cp) more))) 128 | 129 | ;;; Class browsing 130 | 131 | (def available-classes 132 | (filter (complement clojure-fn?) ; omit compiled clojure fns 133 | (scan-paths (System/getProperty "sun.boot.class.path") 134 | (System/getProperty "java.ext.dirs") 135 | (System/getProperty "java.class.path")))) 136 | 137 | ;; Force lazy seqs before any user calls, and in background threads; there's 138 | ;; no sense holding up SLIME init. (It's usually quick, but a monstrous 139 | ;; classpath could concievably take a while.) 140 | 141 | (def top-level-classes 142 | (future (doall (map (comp class-or-ns-name :name) 143 | (filter top-level-class? 144 | available-classes))))) 145 | 146 | (def nested-classes 147 | (future (doall (map (comp class-or-ns-name :name) 148 | (filter nested-class? 149 | available-classes))))) 150 | -------------------------------------------------------------------------------- /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 | 4 | (defn- gen-name [] 5 | (name (gensym "Thread-"))) 6 | 7 | (defn start-thread 8 | "Starts a thread that run the given function f" 9 | ([#^Runnable f] 10 | (doto (Thread. f) 11 | (.start)))) 12 | 13 | (defmacro dothread [& body] 14 | `(start-thread (fn [] ~@body))) 15 | 16 | (defmacro dothread-keeping [bindings & body] 17 | `(start-thread (keep-bindings ~bindings (fn [] ~@body)))) 18 | 19 | (defmacro dothread-keeping-clj [more-bindings & body] 20 | (let [clj-star-syms (filter #(or (= (name %) "*e") 21 | (= (name %) "*1") 22 | (= (name %) "*2") 23 | (= (name %) "*3") 24 | (and (.startsWith #^String (name %) "*") 25 | (.endsWith #^String (name %) "*") 26 | (> (count (name %)) 1))) 27 | (keys (ns-publics (find-ns 'clojure.core))))] 28 | `(dothread-keeping [~@clj-star-syms ~@more-bindings] 29 | ~@body))) 30 | 31 | (defn current-thread [] 32 | (Thread/currentThread)) 33 | 34 | (defn thread-set-name 35 | ([name] (thread-set-name (current-thread) name)) 36 | ([#^Thread thread name] 37 | (.setName thread name))) 38 | 39 | (defn thread-name 40 | ([] (thread-name (current-thread))) 41 | ([#^Thread thread] 42 | (.getName thread))) 43 | 44 | (defn thread-id 45 | ([] (thread-id (current-thread))) 46 | ([#^Thread thread] 47 | (.getId thread))) 48 | 49 | (defn thread-alive? [#^Thread t] 50 | (.isAlive t)) 51 | -------------------------------------------------------------------------------- /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.io StringWriter Reader PrintWriter])) 5 | 6 | (defn read-chars 7 | ([rdr n] (read-chars rdr n false)) 8 | ([#^Reader rdr n throw-exception] 9 | (let [cbuf (make-array Character/TYPE n)] 10 | (loop [i 0] 11 | (let [size (.read rdr cbuf i (- n i))] 12 | (cond 13 | (neg? size) (if throw-exception 14 | (throw throw-exception) 15 | (String. cbuf 0 i)) 16 | (= (+ i size) n) (String. cbuf) 17 | :else (recur (+ i size)))))))) 18 | 19 | (defn call-on-flush-stream 20 | "Creates a stream that will call a given function when flushed." 21 | ([flushf] 22 | (let [closed? (atom false) 23 | #^PrintWriter stream 24 | (PrintWriter. 25 | (proxy [StringWriter] [] 26 | (close [] (reset! closed? true)) 27 | (flush [] 28 | (let [#^StringWriter me this 29 | len (.. me getBuffer length)] 30 | (when (> len 0) 31 | (flushf (.. me getBuffer (substring 0 len))) 32 | (.. me getBuffer (delete 0 len)))))))] 33 | (dothread 34 | (thread-set-name "Call-on-write Stream") 35 | (continuously 36 | (Thread/sleep 200) 37 | (when-not @closed? 38 | (.flush stream)))) 39 | stream)) 40 | {:tag PrintWriter}) 41 | -------------------------------------------------------------------------------- /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 "Socket Server [" (thread-id) "]")) 40 | (with-open [#^ServerSocket server server-socket] 41 | (while (not (.isClosed server)) 42 | (handle-socket (.accept server))))))) 43 | 44 | (defn close-socket! 45 | "Cleanly shutdown and close a java.net.Socket. This will not affect 46 | an already running instance of SocketServer." 47 | ([#^Socket socket] 48 | (doto socket 49 | (.shutdownInput) 50 | (.shutdownOutput) 51 | (.close)))) 52 | 53 | (defn close-server-socket! 54 | "Shutdown a java.net.SocketServer. Existing connections will 55 | persist." 56 | ([#^ServerSocket server] 57 | (.close server))) 58 | -------------------------------------------------------------------------------- /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 | 3 | (defn get-pid 4 | "Returns the PID of the JVM. This is largely a hack and may or may 5 | not be accurate depending on the JVM in which clojure is running 6 | off of." 7 | ([] 8 | (or (first (.. java.lang.management.ManagementFactory (getRuntimeMXBean) (getName) (split "@"))) 9 | (System/getProperty "pid"))) 10 | {:tag String}) 11 | 12 | (defn user-home-path [] 13 | (System/getProperty "user.home")) 14 | -------------------------------------------------------------------------------- /swank-clojure.el: -------------------------------------------------------------------------------- 1 | ;;; swank-clojure.el --- slime adapter for clojure 2 | ;; 3 | ;; Copyright (C) 2008-2010 Jeffrey Chu and Phil Hagelberg 4 | ;; 5 | ;; Authors: Jeffrey Chu 6 | ;; Phil Hagelberg 7 | ;; 8 | ;; URL: http://github.com/technomancy/swank-clojure 9 | ;; Version: 1.1.0 10 | ;; Keywords: languages, lisp 11 | ;; Package-Requires: ((slime-repl "20091016") (clojure-mode "1.6")) 12 | ;; 13 | ;; This file is licensed under the terms of the GNU General Public 14 | ;; License as distributed with Emacs (press C-h C-c to view it). 15 | ;; 16 | ;;; Commentary: 17 | ;; 18 | ;; NOTE: swank-clojure.el is currently unmaintained. Please see the 19 | ;; swank-clojure readme for examples of how to start a swank server 20 | ;; from your build tool and connect to it via SLIME. 21 | ;; 22 | ;; The purpose of this file is to set up `slime-lisp-implementations' 23 | ;; to allow SLIME to communicate with the Swank server implemented in 24 | ;; Clojure. There are four ways to launch a session: 25 | ;; 26 | ;; 1. Standalone: If you just hit M-x slime, swank-clojure will 27 | ;; download the jars for Clojure, contrib, and swank-clojure, 28 | ;; launch an instance, and connect to it. If you just want to try 29 | ;; out Clojure, this is all you need. Just get Swank Clojure 30 | ;; through package.el (http://tromey.com/elpa) and stop reading here. 31 | ;; 32 | ;; 2. Custom classpath: If you want to hack on Clojure or Contrib, set 33 | ;; swank-clojure-classpath to a list of paths to the jars you want to 34 | ;; use and then hit M-x slime. 35 | ;; 36 | ;; 3. Project: Put your project's dependencies (either manually or using 37 | ;; Leiningen or Maven) in the directory named by 38 | ;; `swank-clojure-project-dep-path' (lib/ by default), then launch M-x 39 | ;; swank-clojure-project. Note that the directory must contain 40 | ;; swank-clojure.jar, it will not automatically be added to the 41 | ;; classpath as it was in past versions that had to run from a checkout. 42 | ;; 43 | ;; 4. Standalone Server: Users of leiningen or clojure-maven-plugin 44 | ;; can launch a server from a shell 45 | ;; (http://wiki.github.com/technomancy/leiningen/emacs-integration) 46 | ;; and connect to it from within Emacs using M-x slime-connect. 47 | ;; 48 | ;;; Code: 49 | ;; 50 | 51 | (require 'slime) 52 | (require 'clojure-mode) 53 | 54 | (defgroup swank-clojure nil 55 | "SLIME/swank support for clojure" 56 | :prefix "swank-clojure-" 57 | :group 'applications) 58 | 59 | (defcustom swank-clojure-java-path "java" 60 | "The location of the java executable" 61 | :type 'string 62 | :group 'swank-clojure) 63 | 64 | (defcustom swank-clojure-jar-home "~/.swank-clojure/" 65 | "The directory where the jars necessary to run swank-clojure are kept." 66 | :type 'string 67 | :group 'swank-clojure) 68 | 69 | (defun swank-clojure-default-classpath () 70 | (append 71 | (when (and (file-directory-p "~/.clojure") 72 | (directory-files "~/.clojure" nil "swank-clojure.*jar$")) 73 | (directory-files "~/.clojure" t ".jar$")) 74 | (when (file-directory-p swank-clojure-jar-home) 75 | (directory-files swank-clojure-jar-home t ".jar$")))) 76 | 77 | (defcustom swank-clojure-classpath 78 | (swank-clojure-default-classpath) 79 | "The classpath from which clojure will load from (passed into 80 | java as the -cp argument). On default, it includes all jar files 81 | within ~/.clojure/ and ~/.swank-clojure" 82 | :type 'list 83 | :group 'swank-clojure) 84 | 85 | ;; For backwards-compatibility: 86 | (defvaralias 'swank-clojure-extra-classpaths 'swank-clojure-classpath) 87 | 88 | (defcustom swank-clojure-library-paths nil 89 | "The library paths used when loading shared libraries, 90 | used to set the java.library.path property" 91 | :type 'list 92 | :group 'swank-clojure) 93 | 94 | (defcustom swank-clojure-extra-vm-args nil 95 | "Extra arguments to be passed to the Java VM when starting clojure. 96 | For example -Xmx512m or -Dsun.java2d.noddraw=true" 97 | :type 'list 98 | :group 'swank-clojure) 99 | 100 | (defcustom swank-clojure-binary nil 101 | "Used as a binary executable (instead of swank-clojure-java-path) if non-nil." 102 | :type 'string 103 | :group 'swank-clojure) 104 | 105 | (defcustom swank-clojure-init-files nil 106 | "If provided, will be used to initialize the REPL environment." 107 | :type 'list 108 | :group 'swank-clojure) 109 | 110 | (defcustom swank-clojure-compile-p nil 111 | "Whether to instruct swank-clojure to compile files. Set to nil 112 | if it's causing you problems." 113 | :type 'boolean 114 | :group 'swank-clojure) 115 | 116 | (defcustom swank-clojure-project-dep-path "lib" 117 | "The directory (relative to the project root) to look for dependencies in 118 | when using `swank-clojure-project'." 119 | :type 'string 120 | :group 'swank-clojure) 121 | 122 | (defcustom swank-clojure-deps 123 | (list (concat "http://repo.technomancy.us/" 124 | "swank-clojure-1.1.0.jar") 125 | (concat "http://build.clojure.org/snapshots/org/" 126 | "clojure/clojure/1.1.0-master-SNAPSHOT/" 127 | "clojure-1.1.0-master-20091202.150145-1.jar") 128 | (concat "http://build.clojure.org/snapshots/org/" 129 | "clojure/clojure-contrib/1.1.0-master-SNAPSHOT/" 130 | "clojure-contrib-1.1.0-master-20091212.205045-1.jar")) 131 | "A list of urls of jars required to run swank-clojure. If they 132 | don't exist in `swank-clojure-jar-home' and 133 | `swank-clojure-classpath' is not set, the user will be prompted 134 | to download them when invoking `slime'. 135 | 136 | Due to a bug in url-retrieve-synchronously, they must be 137 | downloaded in order of size (ascending), so if you customize 138 | this, keep that in mind." 139 | :type 'list 140 | :group 'swank-clojure) 141 | 142 | (defface swank-clojure-dim-trace-face 143 | '((((class color) (background dark)) 144 | (:foreground "grey50")) 145 | (((class color) (background light)) 146 | (:foreground "grey55"))) 147 | "Face used to dim parentheses." 148 | :group 'slime-ui) 149 | 150 | ;;;###autoload 151 | (defun swank-clojure-init (file encoding) 152 | (concat 153 | (when swank-clojure-compile-p 154 | "(require 'swank.loader)\n\n(swank.loader/init)\n\n") 155 | "(require 'swank.swank)\n\n" 156 | (when (boundp 'slime-protocol-version) 157 | (format "(swank.swank/ignore-protocol-version %S)\n\n" 158 | slime-protocol-version)) 159 | ;; Hacked in call to get the localhost address to work around a bug 160 | ;; where the REPL doesn't pop up until the user presses Enter. 161 | "(do (.. java.net.InetAddress getLocalHost getHostAddress) nil)" 162 | (format "(swank.swank/start-server %S :encoding %S)\n\n" 163 | (expand-file-name file) 164 | (format "%s" (slime-coding-system-cl-name encoding))))) 165 | 166 | (defun swank-clojure-find-package () 167 | (let ((regexp "^(\\(clojure.core/\\)?\\(in-\\)?ns\\+?[ \t\n\r]+\\(#\\^{[^}]+}[ \t\n\r]+\\)?[:']?\\([^()\" \t\n]+\\>\\)")) 168 | (save-excursion 169 | (when (or (re-search-backward regexp nil t) 170 | (re-search-forward regexp nil t)) 171 | (match-string-no-properties 4))))) 172 | 173 | ;;;###autoload 174 | (defun swank-clojure-slime-mode-hook () 175 | (slime-mode 1) 176 | (set (make-local-variable 'slime-find-buffer-package-function) 177 | 'swank-clojure-find-package)) 178 | 179 | (defun swank-clojure-update-indentation (sym indent) 180 | (put sym 'clojure-indent-function indent)) 181 | 182 | (defun swank-clojure-concat-paths (paths) 183 | "Concatenate given list of `paths' using `path-separator'. (`expand-file-name' 184 | will be used over paths too.)" 185 | (mapconcat 'identity (mapcar 'expand-file-name paths) path-separator)) 186 | 187 | (defun swank-clojure-parse-jar-name (url) 188 | (car (last (split-string url "/")))) 189 | 190 | (defun swank-clojure-download-jar (url) 191 | (let ((jar-name (swank-clojure-parse-jar-name url))) 192 | (message "Downloading %s..." jar-name) 193 | (let ((download-buffer (url-retrieve-synchronously url))) 194 | (save-excursion 195 | (condition-case e 196 | (progn 197 | (set-buffer download-buffer) 198 | (re-search-forward "HTTP/[0-9]\.[0-9] 200 OK") 199 | (re-search-forward "^$" nil 'move) 200 | (delete-region (point-min) (+ 1 (point))) 201 | (write-file (concat swank-clojure-jar-home "/" jar-name)) 202 | (kill-buffer nil)) 203 | (error 204 | ;; no recursive directory deletion on emacs 22 =( 205 | (dolist (j (directory-files swank-clojure-jar-home t "[^.]+$")) 206 | (delete-file j)) 207 | (delete-directory swank-clojure-jar-home) 208 | (error "Failed to download Clojure jars."))))))) 209 | 210 | (defun swank-clojure-dep-exists-p (jar-url) 211 | "True if the jar file in `jar-url' exists in `swank-clojure-jar-home'." 212 | (file-exists-p (expand-file-name (swank-clojure-parse-jar-name jar-url) 213 | swank-clojure-jar-home))) 214 | 215 | (defun swank-clojure-check-install () 216 | "Prompt to install Clojure if it's not already present." 217 | (when (and (not swank-clojure-classpath) 218 | (or (not (file-exists-p swank-clojure-jar-home)) 219 | (> (count-if-not 'swank-clojure-dep-exists-p swank-clojure-deps) 220 | 0)) 221 | (y-or-n-p "It looks like Clojure is not installed. Install now? ")) 222 | (make-directory swank-clojure-jar-home t) 223 | (dolist (j swank-clojure-deps) 224 | (swank-clojure-download-jar j)) 225 | (setq swank-clojure-classpath (swank-clojure-default-classpath)))) 226 | 227 | ;;;###autoload 228 | (defun swank-clojure-cmd () 229 | "Create the command to start clojure according to current settings." 230 | (swank-clojure-check-install) 231 | (if swank-clojure-binary 232 | (if (listp swank-clojure-binary) 233 | swank-clojure-binary 234 | (list swank-clojure-binary)) 235 | (delete-if 236 | 'null 237 | (append 238 | (list swank-clojure-java-path) 239 | swank-clojure-extra-vm-args 240 | (list 241 | (when swank-clojure-library-paths 242 | (concat "-Djava.library.path=" 243 | (swank-clojure-concat-paths swank-clojure-library-paths))) 244 | "-classpath" 245 | (swank-clojure-concat-paths swank-clojure-classpath) 246 | "clojure.main") 247 | (let ((init-opts '())) 248 | ;; TODO: cleanup 249 | (dolist (init-file swank-clojure-init-files init-opts) 250 | (setq init-opts (append init-opts (list "-i" init-file)))) 251 | init-opts) 252 | (list "--repl"))))) 253 | 254 | (defun swank-clojure-reset-implementation () 255 | "Redefines the clojure entry in `slime-lisp-implementations'." 256 | (aput 'slime-lisp-implementations 'clojure 257 | (list (swank-clojure-cmd) :init 'swank-clojure-init))) 258 | 259 | ;;;###autoload 260 | (defadvice slime-read-interactive-args (before add-clojure) 261 | ;; Unfortunately we need to construct our Clojure-launching command 262 | ;; at slime-launch time to reflect changes in the classpath. Slime 263 | ;; has no mechanism to support this, so we must resort to advice. 264 | (require 'assoc) 265 | (swank-clojure-reset-implementation)) 266 | 267 | ;; Change the repl to be more clojure friendly 268 | (defun swank-clojure-slime-repl-modify-syntax () 269 | (when (string-match "\\*slime-repl clojure\\*" (buffer-name)) 270 | ;; modify syntax 271 | (set-syntax-table clojure-mode-syntax-table) 272 | 273 | ;; set indentation function (already local) 274 | (setq lisp-indent-function 'clojure-indent-function) 275 | 276 | ;; set paredit keys 277 | (when (and (featurep 'paredit) paredit-mode (>= paredit-version 21)) 278 | (define-key slime-repl-mode-map "{" 'paredit-open-curly) 279 | (define-key slime-repl-mode-map "}" 'paredit-close-curly)))) 280 | 281 | ;; Debugger 282 | 283 | (defun swank-clojure-dim-font-lock () 284 | "Dim irrelevant lines in Clojure debugger buffers." 285 | (if (string-match "clojure" (buffer-name)) 286 | (font-lock-add-keywords 287 | nil `((,(concat " [0-9]+: " (regexp-opt '("clojure.core" 288 | "clojure.lang" 289 | "swank." "java.")) 290 | ;; TODO: regexes ending in .* are ignored by 291 | ;; font-lock; what gives? 292 | "[a-zA-Z0-9\\._$]*") 293 | . font-lock-comment-face)) t))) 294 | 295 | (add-hook 'sldb-mode-hook 'swank-clojure-dim-font-lock) 296 | 297 | (defvar swank-clojure-project-hook nil 298 | "A hook to run when a new SLIME session starts via `swank-clojure-project'. 299 | The `path' variable is bound to the project root when these functions run.") 300 | 301 | (defun swank-clojure-javadoc (classname) 302 | "Show the javadoc for classname using clojure.contrib.repl-utils/javadoc" 303 | (interactive (list (read-from-minibuffer "Javadoc for: " (slime-sexp-at-point)))) 304 | (slime-eval 305 | `(swank:eval-and-grab-output 306 | ,(concat "(try 307 | (require 'clojure.contrib.repl-utils) 308 | (@(ns-resolve 'clojure.contrib.repl-utils 'javadoc) " classname ") 309 | (catch Throwable t (.getMessage t)))")))) 310 | 311 | (defun directoryp (path) 312 | "Return t is path is a directory or a symlink pointing to a directory." 313 | (let ((first-attr (car (file-attributes path)))) 314 | (if (stringp first-attr) 315 | (directoryp first-attr) 316 | first-attr))) 317 | 318 | ;;;###autoload 319 | (defun swank-clojure-project (path) 320 | "Setup classpath for a clojure project and starts a new SLIME session. 321 | Kills existing SLIME session, if any." 322 | (interactive (list 323 | (read-directory-name 324 | "Project root: " 325 | (if (functionp 'locate-dominating-file) ; Emacs 23 only 326 | (locate-dominating-file default-directory "src") 327 | default-directory)))) 328 | ;; TODO: allow multiple SLIME sessions per Emacs instance 329 | (when (get-buffer "*inferior-lisp*") (kill-buffer "*inferior-lisp*")) 330 | 331 | (let ((slime-lisp-implementations (copy-list slime-lisp-implementations)) 332 | (swank-clojure-extra-vm-args (copy-list swank-clojure-extra-vm-args)) 333 | (swank-clojure-binary nil) 334 | (swank-clojure-classpath (let ((l (expand-file-name 335 | swank-clojure-project-dep-path path))) 336 | (if (file-directory-p l) 337 | (append 338 | (directory-files l t ".jar$") 339 | (remove-if-not 340 | 'directoryp 341 | (directory-files l t "^[^\\.]"))))))) 342 | 343 | (add-to-list 'swank-clojure-classpath (expand-file-name "classes/" path)) 344 | (add-to-list 'swank-clojure-classpath (expand-file-name "src/" path)) 345 | (add-to-list 'swank-clojure-classpath (expand-file-name "test/" path)) 346 | (add-to-list 'swank-clojure-classpath (expand-file-name "resources/" path)) 347 | 348 | ;; For Maven style project layouts 349 | (when (file-exists-p (expand-file-name "pom.xml" path)) 350 | (dolist (d '("src/main/clojure/" "src/test/clojure/" 351 | "target/test-classes/" "target/classes/" "target/dependency/")) 352 | (add-to-list 'swank-clojure-classpath (expand-file-name d path) t)) 353 | (dolist (d (let ((l (expand-file-name "target/dependency/" path))) 354 | (if (file-directory-p l) 355 | (directory-files l t ".jar$")))) 356 | (add-to-list 'swank-clojure-classpath (expand-file-name d path) t)) 357 | (add-to-list 'swank-clojure-extra-vm-args 358 | (format "-Dclojure.compile.path=%s" 359 | (expand-file-name "target/classes/" path)))) 360 | (swank-clojure-reset-implementation) 361 | (run-hooks 'swank-clojure-project-hook) 362 | 363 | (save-window-excursion 364 | (let ((default-directory path)) 365 | (slime 'clojure))))) 366 | 367 | (provide 'swank-clojure) 368 | ;;; swank-clojure.el ends here 369 | -------------------------------------------------------------------------------- /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]) 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 | (clojure.lang.Compiler$CompilerException. "a.clj" 1 (Exception. "err")))))) 26 | 27 | (deftest exception-location-test 28 | (is (= '(:location (:file "a.clj") (:line 1) nil) 29 | (exception-location 30 | (clojure.lang.Compiler$CompilerException. "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/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 [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) --------------------------------------------------------------------------------