341 changes: 341 additions & 0 deletions src/clj/clojure/core/server.clj
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,341 @@
; Copyright (c) Rich Hickey. All rights reserved.
; The use and distribution terms for this software are covered by the
; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
; which can be found in the file epl-v10.html at the root of this distribution.
; By using this software in any fashion, you are agreeing to be bound by
; the terms of this license.
; You must not remove this notice, or any other, from this software.

(ns ^{:doc "Socket server support"
:author "Alex Miller"}
clojure.core.server
(:require [clojure.string :as str]
[clojure.edn :as edn]
[clojure.main :as m])
(:import
[clojure.lang LineNumberingPushbackReader]
[java.net InetAddress Socket ServerSocket SocketException]
[java.io Reader Writer PrintWriter BufferedWriter BufferedReader InputStreamReader OutputStreamWriter]
[java.util Properties]
[java.util.concurrent.locks ReentrantLock]))

(set! *warn-on-reflection* true)

(def ^:dynamic *session* nil)

;; lock protects servers
(defonce ^:private lock (ReentrantLock.))
(defonce ^:private servers {})

(defmacro ^:private with-lock
[lock-expr & body]
`(let [lockee# ~(with-meta lock-expr {:tag 'java.util.concurrent.locks.ReentrantLock})]
(.lock lockee#)
(try
~@body
(finally
(.unlock lockee#)))))

(defmacro ^:private thread
[^String name daemon & body]
`(doto (Thread. (fn [] ~@body) ~name)
(.setDaemon ~daemon)
(.start)))

(defn- required
"Throw if opts does not contain prop."
[opts prop]
(when (nil? (get opts prop))
(throw (ex-info (str "Missing required socket server property " prop) opts))))

(defn- validate-opts
"Validate server config options"
[{:keys [name port accept] :as opts}]
(doseq [prop [:name :port :accept]] (required opts prop))
(when (or (not (integer? port)) (not (<= 0 port 65535)))
(throw (ex-info (str "Invalid socket server port: " port) opts))))

(defn- accept-connection
"Start accept function, to be invoked on a client thread, given:
conn - client socket
name - server name
client-id - client identifier
in - in stream
out - out stream
err - err stream
accept - accept fn symbol to invoke
args - to pass to accept-fn"
[^Socket conn name client-id in out err accept args]
(try
(binding [*in* in
*out* out
*err* err
*session* {:server name :client client-id}]
(with-lock lock
(alter-var-root #'servers assoc-in [name :sessions client-id] {}))
(require (symbol (namespace accept)))
(let [accept-fn (resolve accept)]
(apply accept-fn args)))
(catch SocketException _disconnect)
(finally
(with-lock lock
(alter-var-root #'servers update-in [name :sessions] dissoc client-id))
(.close conn))))

(defn start-server
"Start a socket server given the specified opts:
:address Host or address, string, defaults to loopback address
:port Port, integer, required
:name Name, required
:accept Namespaced symbol of the accept function to invoke, required
:args Vector of args to pass to accept function
:bind-err Bind *err* to socket out stream?, defaults to true
:server-daemon Is server thread a daemon?, defaults to true
:client-daemon Are client threads daemons?, defaults to true
Returns server socket."
[opts]
(validate-opts opts)
(let [{:keys [address port name accept args bind-err server-daemon client-daemon]
:or {bind-err true
server-daemon true
client-daemon true}} opts
address (InetAddress/getByName address) ;; nil returns loopback
socket (ServerSocket. port 0 address)]
(with-lock lock
(alter-var-root #'servers assoc name {:name name, :socket socket, :sessions {}}))
(thread
(str "Clojure Server " name) server-daemon
(try
(loop [client-counter 1]
(when (not (.isClosed socket))
(try
(let [conn (.accept socket)
in (LineNumberingPushbackReader. (InputStreamReader. (.getInputStream conn)))
out (BufferedWriter. (OutputStreamWriter. (.getOutputStream conn)))
client-id (str client-counter)]
(thread
(str "Clojure Connection " name " " client-id) client-daemon
(accept-connection conn name client-id in out (if bind-err out *err*) accept args)))
(catch SocketException _disconnect))
(recur (inc client-counter))))
(finally
(with-lock lock
(alter-var-root #'servers dissoc name)))))
socket))

(defn stop-server
"Stop server with name or use the server-name from *session* if none supplied.
Returns true if server stopped successfully, nil if not found, or throws if
there is an error closing the socket."
([]
(stop-server (:server *session*)))
([name]
(with-lock lock
(let [server-socket ^ServerSocket (get-in servers [name :socket])]
(when server-socket
(alter-var-root #'servers dissoc name)
(.close server-socket)
true)))))

(defn stop-servers
"Stop all servers ignores all errors, and returns nil."
[]
(with-lock lock
(doseq [name (keys servers)]
(future (stop-server name)))))

(defn- parse-props
"Parse clojure.server.* from properties to produce a map of server configs."
[^Properties props]
(reduce
(fn [acc ^String k]
(let [[k1 k2 k3] (str/split k #"\.")]
(if (and (= k1 "clojure") (= k2 "server"))
(let [v (get props k)]
(conj acc (merge {:name k3} (edn/read-string v))))
acc)))
[]
(.stringPropertyNames props)))

(defn start-servers
"Start all servers specified in the system properties."
[system-props]
(doseq [server (parse-props system-props)]
(start-server server)))

(defn repl-init
"Initialize repl in user namespace and make standard repl requires."
[]
(in-ns 'user)
(apply require clojure.main/repl-requires))

(defn repl-read
"Enhanced :read hook for repl supporting :repl/quit."
[request-prompt request-exit]
(or ({:line-start request-prompt :stream-end request-exit}
(m/skip-whitespace *in*))
(let [input (read {:read-cond :allow} *in*)]
(m/skip-if-eol *in*)
(case input
:repl/quit request-exit
input))))

(defn repl
"REPL with predefined hooks for attachable socket server."
[]
(m/repl
:init repl-init
:read repl-read))

(defn- ex->data
[ex phase]
(assoc (Throwable->map ex) :phase phase))

(defn prepl
"a REPL with structured output (for programs)
reads forms to eval from in-reader (a LineNumberingPushbackReader)
Closing the input or passing the form :repl/quit will cause it to return
Calls out-fn with data, one of:
{:tag :ret
:val val ;;eval result, or Throwable->map data if exception thrown
:ns ns-name-string
:ms long ;;eval time in milliseconds
:form string ;;iff successfully read
:exception true ;;iff exception thrown
}
{:tag :out
:val string} ;chars from during-eval *out*
{:tag :err
:val string} ;chars from during-eval *err*
{:tag :tap
:val val} ;values from tap>
You might get more than one :out or :err per eval, but exactly one :ret
tap output can happen at any time (i.e. between evals)
If during eval an attempt is made to read *in* it will read from in-reader unless :stdin is supplied
Alpha, subject to change."
{:added "1.10"}
[in-reader out-fn & {:keys [stdin]}]
(let [EOF (Object.)
tapfn #(out-fn {:tag :tap :val %1})]
(m/with-bindings
(in-ns 'user)
(binding [*in* (or stdin in-reader)
*out* (PrintWriter-on #(out-fn {:tag :out :val %1}) nil true)
*err* (PrintWriter-on #(out-fn {:tag :err :val %1}) nil true)]
(try
(add-tap tapfn)
(loop []
(when (try
(let [[form s] (read+string {:eof EOF :read-cond :allow} in-reader)]
(try
(when-not (identical? form EOF)
(let [start (System/nanoTime)
ret (eval form)
ms (quot (- (System/nanoTime) start) 1000000)]
(when-not (= :repl/quit ret)
(set! *3 *2)
(set! *2 *1)
(set! *1 ret)
(out-fn {:tag :ret
:val (if (instance? Throwable ret)
(Throwable->map ret)
ret)
:ns (str (.name *ns*))
:ms ms
:form s})
true)))
(catch Throwable ex
(set! *e ex)
(out-fn {:tag :ret :val (ex->data ex (or (-> ex ex-data :clojure.error/phase) :execution))
:ns (str (.name *ns*)) :form s
:exception true})
true)))
(catch Throwable ex
(set! *e ex)
(out-fn {:tag :ret :val (ex->data ex :read-source)
:ns (str (.name *ns*))
:exception true})
true))
(recur)))
(finally
(remove-tap tapfn)))))))

(defn- resolve-fn [valf]
(if (symbol? valf)
(or (resolve valf)
(when-let [nsname (namespace valf)]
(require (symbol nsname))
(resolve valf))
(throw (Exception. (str "can't resolve: " valf))))
valf))

(defn io-prepl
"prepl bound to *in* and *out*, suitable for use with e.g. server/repl (socket-repl).
:ret and :tap vals will be processed by valf, a fn of one argument
or a symbol naming same (default pr-str)
Alpha, subject to change."
{:added "1.10"}
[& {:keys [valf] :or {valf pr-str}}]
(let [valf (resolve-fn valf)
out *out*
lock (Object.)]
(prepl *in*
(fn [m]
(binding [*out* out, *flush-on-newline* true, *print-readably* true]
(locking lock
(prn (if (#{:ret :tap} (:tag m))
(try
(assoc m :val (valf (:val m)))
(catch Throwable ex
(assoc m :val (valf (ex->data ex :print-eval-result))
:exception true)))
m))))))))

(defn remote-prepl
"Implements a prepl on in-reader and out-fn by forwarding to a
remote [io-]prepl over a socket. Messages will be read by readf, a
fn of a LineNumberingPushbackReader and EOF value or a symbol naming
same (default #(read %1 false %2)),
:ret and :tap vals will be processed by valf, a fn of one argument
or a symbol naming same (default read-string). If that function
throws, :val will be unprocessed.
Alpha, subject to change."
{:added "1.10"}
[^String host port ^Reader
in-reader out-fn & {:keys [valf readf] :or {valf read-string, readf #(read %1 false %2)}}]
(let [valf (resolve-fn valf)
readf (resolve-fn readf)
^long port (if (string? port) (Integer/valueOf ^String port) port)
socket (Socket. host port)
rd (-> socket .getInputStream InputStreamReader. BufferedReader. LineNumberingPushbackReader.)
wr (-> socket .getOutputStream OutputStreamWriter.)
EOF (Object.)]
(thread "clojure.core.server/remote-prepl" true
(try (loop []
(let [{:keys [tag val] :as m} (readf rd EOF)]
(when-not (identical? m EOF)
(out-fn
(if (#{:ret :tap} tag)
(try
(assoc m :val (valf val))
(catch Throwable ex
(assoc m :val (ex->data ex :read-eval-result)
:exception true)))
m))
(recur))))
(finally
(.close wr))))
(let [buf (char-array 1024)]
(try (loop []
(let [n (.read in-reader buf)]
(when-not (= n -1)
(.write wr buf 0 n)
(.flush wr)
(recur))))
(finally
(.close rd))))))
919 changes: 919 additions & 0 deletions src/clj/clojure/core_deftype.clj
View file

Large diffs are not rendered by default.

427 changes: 348 additions & 79 deletions src/clj/clojure/core_print.clj
View file

Large diffs are not rendered by default.

169 changes: 109 additions & 60 deletions src/clj/clojure/core_proxy.clj
View file

Large diffs are not rendered by default.

143 changes: 143 additions & 0 deletions src/clj/clojure/data.clj
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,143 @@
; Copyright (c) Rich Hickey. All rights reserved.
; The use and distribution terms for this software are covered by the
; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
; which can be found in the file epl-v10.html at the root of this distribution.
; By using this software in any fashion, you are agreeing to be bound by
; the terms of this license.
; You must not remove this notice, or any other, from this software.

(ns
^{:author "Stuart Halloway",
:doc "Non-core data functions."}
clojure.data
(:require [clojure.set :as set]))

(set! *warn-on-reflection* true)

(declare diff)

(defn- atom-diff
"Internal helper for diff."
[a b]
(if (= a b) [nil nil a] [a b nil]))

;; for big things a sparse vector class would be better
(defn- vectorize
"Convert an associative-by-numeric-index collection into
an equivalent vector, with nil for any missing keys"
[m]
(when (seq m)
(reduce
(fn [result [k v]] (assoc result k v))
(vec (repeat (apply max (keys m)) nil))
m)))

(defn- diff-associative-key
"Diff associative things a and b, comparing only the key k."
[a b k]
(let [va (get a k)
vb (get b k)
[a* b* ab] (diff va vb)
in-a (contains? a k)
in-b (contains? b k)
same (and in-a in-b
(or (not (nil? ab))
(and (nil? va) (nil? vb))))]
[(when (and in-a (or (not (nil? a*)) (not same))) {k a*})
(when (and in-b (or (not (nil? b*)) (not same))) {k b*})
(when same {k ab})
]))

(defn- diff-associative
"Diff associative things a and b, comparing only keys in ks."
[a b ks]
(reduce
(fn [diff1 diff2]
(doall (map merge diff1 diff2)))
[nil nil nil]
(map
(partial diff-associative-key a b)
ks)))

(defn- diff-sequential
[a b]
(vec (map vectorize (diff-associative
(if (vector? a) a (vec a))
(if (vector? b) b (vec b))
(range (max (count a) (count b)))))))

(defprotocol ^{:added "1.3"} EqualityPartition
"Implementation detail. Subject to change."
(^{:added "1.3"} equality-partition [x] "Implementation detail. Subject to change."))

(defprotocol ^{:added "1.3"} Diff
"Implementation detail. Subject to change."
(^{:added "1.3"} diff-similar [a b] "Implementation detail. Subject to change."))

(extend nil
Diff
{:diff-similar atom-diff})

(extend Object
Diff
{:diff-similar (fn [^Object a b]
((if (.. a getClass isArray) diff-sequential atom-diff) a b))}
EqualityPartition
{:equality-partition (fn [^Object x]
(if (.. x getClass isArray) :sequential :atom))})

(extend-protocol EqualityPartition
nil
(equality-partition [x] :atom)

java.util.Set
(equality-partition [x] :set)

java.util.List
(equality-partition [x] :sequential)

java.util.Map
(equality-partition [x] :map))

(defn- as-set-value
[s]
(if (set? s) s (into #{} s)))

(extend-protocol Diff
java.util.Set
(diff-similar
[a b]
(let [aval (as-set-value a)
bval (as-set-value b)]
[(not-empty (set/difference aval bval))
(not-empty (set/difference bval aval))
(not-empty (set/intersection aval bval))]))

java.util.List
(diff-similar [a b]
(diff-sequential a b))

java.util.Map
(diff-similar [a b]
(diff-associative a b (set/union (keys a) (keys b)))))

(defn diff
"Recursively compares a and b, returning a tuple of
[things-only-in-a things-only-in-b things-in-both].
Comparison rules:
* For equal a and b, return [nil nil a].
* Maps are subdiffed where keys match and values differ.
* Sets are never subdiffed.
* All sequential things are treated as associative collections
by their indexes, with results returned as vectors.
* Everything else (including strings!) is treated as
an atom and compared for equality."
{:added "1.3"}
[a b]
(if (= a b)
[nil nil a]
(if (= (equality-partition a) (equality-partition b))
(diff-similar a b)
(atom-diff a b))))

62 changes: 62 additions & 0 deletions src/clj/clojure/datafy.clj
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,62 @@
; Copyright (c) Rich Hickey. All rights reserved.
; The use and distribution terms for this software are covered by the
; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
; which can be found in the file epl-v10.html at the root of this distribution.
; By using this software in any fashion, you are agreeing to be bound by
; the terms of this license.
; You must not remove this notice, or any other, from this software.

(ns ^{:doc "Functions to turn objects into data. Alpha, subject to change"}
clojure.datafy
(:require [clojure.core.protocols :as p]))

(set! *warn-on-reflection* true)

(defn datafy
"Attempts to return x as data.
datafy will return the value of clojure.core.protocols/datafy. If
the value has been transformed and the result supports
metadata, :clojure.datafy/obj will be set on the metadata to the
original value of x, and :clojure.datafy/class to the name of the
class of x, as a symbol."
[x]
(let [v (p/datafy x)]
(if (identical? v x)
v
(if (instance? clojure.lang.IObj v)
(vary-meta v assoc ::obj x ::class (-> x class .getName symbol))
v))))

(defn nav
"Returns (possibly transformed) v in the context of coll and k (a
key/index or nil). Callers should attempt to provide the key/index
context k for Indexed/Associative/ILookup colls if possible, but not
to fabricate one e.g. for sequences (pass nil). nav returns the
value of clojure.core.protocols/nav."
[coll k v]
(p/nav coll k v))

(defn- sortmap [m]
(into (sorted-map) m))

(extend-protocol p/Datafiable
Throwable
(datafy [x]
(Throwable->map x))

clojure.lang.IRef
(datafy [r]
(with-meta [(deref r)] (meta r)))

clojure.lang.Namespace
(datafy [n]
(with-meta {:name (.getName n)
:publics (-> n ns-publics sortmap)
:imports (-> n ns-imports sortmap)
:interns (-> n ns-interns sortmap)}
(meta n)))

java.lang.Class
(datafy [c]
(let [{:keys [members] :as ret} ((requiring-resolve 'clojure.reflect/reflect) c)]
(assoc ret :name (-> c .getName symbol) :members (->> members (group-by :name) sortmap)))))
46 changes: 46 additions & 0 deletions src/clj/clojure/edn.clj
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,46 @@
; Copyright (c) Rich Hickey. All rights reserved.
; The use and distribution terms for this software are covered by the
; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
; which can be found in the file epl-v10.html at the root of this distribution.
; By using this software in any fashion, you are agreeing to be bound by
; the terms of this license.
; You must not remove this notice, or any other, from this software.

(ns ^{:doc "edn reading."
:author "Rich Hickey"}
clojure.edn
(:refer-clojure :exclude [read read-string]))

(defn read
"Reads the next object from stream, which must be an instance of
java.io.PushbackReader or some derivee. stream defaults to the
current value of *in*.
Reads data in the edn format (subset of Clojure data):
http://edn-format.org
opts is a map that can include the following keys:
:eof - value to return on end-of-file. When not supplied, eof throws an exception.
:readers - a map of tag symbols to data-reader functions to be considered before default-data-readers.
When not supplied, only the default-data-readers will be used.
:default - A function of two args, that will, if present and no reader is found for a tag,
be called with the tag and the value."

{:added "1.5"}
([]
(read *in*))
([stream]
(read {} stream))
([opts stream]
(clojure.lang.EdnReader/read stream opts)))

(defn read-string
"Reads one object from the string s. Returns nil when s is nil or empty.
Reads data in the edn format (subset of Clojure data):
http://edn-format.org
opts is a map as per clojure.edn/read"
{:added "1.5"}
([s] (read-string {:eof nil} s))
([opts s] (when s (clojure.lang.EdnReader/readString s opts))))
188 changes: 123 additions & 65 deletions src/clj/clojure/genclass.clj
View file

Large diffs are not rendered by default.

566 changes: 566 additions & 0 deletions src/clj/clojure/gvec.clj
View file

Large diffs are not rendered by default.

21 changes: 15 additions & 6 deletions src/clj/clojure/inspector.clj
View file
Original file line number Diff line number Diff line change
Expand Up @@ -6,7 +6,9 @@
; the terms of this license.
; You must not remove this notice, or any other, from this software.

(ns clojure.inspector
(ns ^{:doc "Graphical object inspector for Clojure data structures."
:author "Rich Hickey"}
clojure.inspector
(:import
(java.awt BorderLayout)
(java.awt.event ActionEvent ActionListener)
Expand All @@ -19,9 +21,11 @@

(defn collection-tag [x]
(cond
(instance? java.util.Map$Entry x) :entry
(instance? java.util.Map x) :map
(map-entry? x) :entry
(instance? java.util.Map x) :seqable
(instance? java.util.Set x) :seqable
(sequential? x) :seq
(instance? clojure.lang.Seqable x) :seqable
:else :atom))

(defmulti is-leaf collection-tag)
Expand All @@ -42,10 +46,12 @@
(defmethod get-child-count :entry [e]
(count (val e)))

(defmethod is-leaf :map [m]
(defmethod is-leaf :seqable [parent]
false)
(defmethod get-child :map [m index]
(nth (seq m) index))
(defmethod get-child :seqable [parent index]
(nth (seq parent) index))
(defmethod get-child-count :seqable [parent]
(count (seq parent)))

(defn tree-model [data]
(proxy [TreeModel] []
Expand Down Expand Up @@ -84,6 +90,7 @@

(defn inspect-tree
"creates a graphical (Swing) inspector on the supplied hierarchical data"
{:added "1.0"}
[data]
(doto (JFrame. "Clojure Inspector")
(.add (JScrollPane. (JTree. (tree-model data))))
Expand All @@ -94,6 +101,7 @@
"creates a graphical (Swing) inspector on the supplied regular
data, which must be a sequential data structure of data structures
of equal length"
{:added "1.0"}
[data]
(doto (JFrame. "Clojure Inspector")
(.add (JScrollPane. (JTable. (old-table-model data))))
Expand Down Expand Up @@ -145,6 +153,7 @@

(defn inspect
"creates a graphical (Swing) inspector on the supplied object"
{:added "1.0"}
[x]
(doto (JFrame. "Clojure Inspector")
(.add
Expand Down
294 changes: 294 additions & 0 deletions src/clj/clojure/instant.clj
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,294 @@
; Copyright (c) Rich Hickey. All rights reserved.
; The use and distribution terms for this software are covered by the
; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
; which can be found in the file epl-v10.html at the root of this distribution.
; By using this software in any fashion, you are agreeing to be bound by
; the terms of this license.
; You must not remove this notice, or any other, from this software.

(ns clojure.instant
(:import [java.util Calendar Date GregorianCalendar TimeZone]
[java.sql Timestamp]))


(set! *warn-on-reflection* true)

;;; ------------------------------------------------------------------------
;;; convenience macros

(defmacro ^:private fail
[msg]
`(throw (RuntimeException. ~msg)))

(defmacro ^:private verify
([test msg] `(when-not ~test (fail ~msg)))
([test] `(verify ~test ~(str "failed: " (pr-str test)))))

(defn- divisible?
[num div]
(zero? (mod num div)))

(defn- indivisible?
[num div]
(not (divisible? num div)))


;;; ------------------------------------------------------------------------
;;; parser implementation

(defn- parse-int [^String s]
(Long/parseLong s))

(defn- zero-fill-right [^String s width]
(cond (= width (count s)) s
(< width (count s)) (.substring s 0 width)
:else (loop [b (StringBuilder. s)]
(if (< (.length b) width)
(recur (.append b \0))
(.toString b)))))

(def ^:private timestamp
#"(\d\d\d\d)(?:-(\d\d)(?:-(\d\d)(?:[T](\d\d)(?::(\d\d)(?::(\d\d)(?:[.](\d+))?)?)?)?)?)?(?:[Z]|([-+])(\d\d):(\d\d))?")

(defn parse-timestamp
"Parse a string containing an RFC3339-like like timestamp.
The function new-instant is called with the following arguments.
min max default
--- ------------ -------
years 0 9999 N/A (s must provide years)
months 1 12 1
days 1 31 1 (actual max days depends
hours 0 23 0 on month and year)
minutes 0 59 0
seconds 0 60 0 (though 60 is only valid
nanoseconds 0 999999999 0 when minutes is 59)
offset-sign -1 1 0
offset-hours 0 23 0
offset-minutes 0 59 0
These are all integers and will be non-nil. (The listed defaults
will be passed if the corresponding field is not present in s.)
Grammar (of s):
date-fullyear = 4DIGIT
date-month = 2DIGIT ; 01-12
date-mday = 2DIGIT ; 01-28, 01-29, 01-30, 01-31 based on
; month/year
time-hour = 2DIGIT ; 00-23
time-minute = 2DIGIT ; 00-59
time-second = 2DIGIT ; 00-58, 00-59, 00-60 based on leap second
; rules
time-secfrac = '.' 1*DIGIT
time-numoffset = ('+' / '-') time-hour ':' time-minute
time-offset = 'Z' / time-numoffset
time-part = time-hour [ ':' time-minute [ ':' time-second
[time-secfrac] [time-offset] ] ]
timestamp = date-year [ '-' date-month [ '-' date-mday
[ 'T' time-part ] ] ]
Unlike RFC3339:
- we only parse the timestamp format
- timestamp can elide trailing components
- time-offset is optional (defaults to +00:00)
Though time-offset is syntactically optional, a missing time-offset
will be treated as if the time-offset zero (+00:00) had been
specified.
"
[new-instant ^CharSequence cs]
(if-let [[_ years months days hours minutes seconds fraction
offset-sign offset-hours offset-minutes]
(re-matches timestamp cs)]
(new-instant
(parse-int years)
(if-not months 1 (parse-int months))
(if-not days 1 (parse-int days))
(if-not hours 0 (parse-int hours))
(if-not minutes 0 (parse-int minutes))
(if-not seconds 0 (parse-int seconds))
(if-not fraction 0 (parse-int (zero-fill-right fraction 9)))
(cond (= "-" offset-sign) -1
(= "+" offset-sign) 1
:else 0)
(if-not offset-hours 0 (parse-int offset-hours))
(if-not offset-minutes 0 (parse-int offset-minutes)))
(fail (str "Unrecognized date/time syntax: " cs))))


;;; ------------------------------------------------------------------------
;;; Verification of Extra-Grammatical Restrictions from RFC3339

(defn- leap-year?
[year]
(and (divisible? year 4)
(or (indivisible? year 100)
(divisible? year 400))))

(def ^:private days-in-month
(let [dim-norm [nil 31 28 31 30 31 30 31 31 30 31 30 31]
dim-leap [nil 31 29 31 30 31 30 31 31 30 31 30 31]]
(fn [month leap-year?]
((if leap-year? dim-leap dim-norm) month))))

(defn validated
"Return a function which constructs an instant by calling constructor
after first validating that those arguments are in range and otherwise
plausible. The resulting function will throw an exception if called
with invalid arguments."
[new-instance]
(fn [years months days hours minutes seconds nanoseconds
offset-sign offset-hours offset-minutes]
(verify (<= 1 months 12))
(verify (<= 1 days (days-in-month months (leap-year? years))))
(verify (<= 0 hours 23))
(verify (<= 0 minutes 59))
(verify (<= 0 seconds (if (= minutes 59) 60 59)))
(verify (<= 0 nanoseconds 999999999))
(verify (<= -1 offset-sign 1))
(verify (<= 0 offset-hours 23))
(verify (<= 0 offset-minutes 59))
(new-instance years months days hours minutes seconds nanoseconds
offset-sign offset-hours offset-minutes)))


;;; ------------------------------------------------------------------------
;;; print integration

(def ^:private ^ThreadLocal thread-local-utc-date-format
;; SimpleDateFormat is not thread-safe, so we use a ThreadLocal proxy for access.
;; http://bugs.sun.com/bugdatabase/view_bug.do?bug_id=4228335
(proxy [ThreadLocal] []
(initialValue []
(doto (java.text.SimpleDateFormat. "yyyy-MM-dd'T'HH:mm:ss.SSS-00:00")
;; RFC3339 says to use -00:00 when the timezone is unknown (+00:00 implies a known GMT)
(.setTimeZone (java.util.TimeZone/getTimeZone "GMT"))))))

(defn- print-date
"Print a java.util.Date as RFC3339 timestamp, always in UTC."
[^java.util.Date d, ^java.io.Writer w]
(let [^java.text.DateFormat utc-format (.get thread-local-utc-date-format)]
(.write w "#inst \"")
(.write w (.format utc-format d))
(.write w "\"")))

(defmethod print-method java.util.Date
[^java.util.Date d, ^java.io.Writer w]
(print-date d w))

(defmethod print-dup java.util.Date
[^java.util.Date d, ^java.io.Writer w]
(print-date d w))

(defn- print-calendar
"Print a java.util.Calendar as RFC3339 timestamp, preserving timezone."
[^java.util.Calendar c, ^java.io.Writer w]
(let [calstr (format "%1$tFT%1$tT.%1$tL%1$tz" c)
offset-minutes (- (.length calstr) 2)]
;; calstr is almost right, but is missing the colon in the offset
(.write w "#inst \"")
(.write w calstr 0 offset-minutes)
(.write w ":")
(.write w calstr offset-minutes 2)
(.write w "\"")))

(defmethod print-method java.util.Calendar
[^java.util.Calendar c, ^java.io.Writer w]
(print-calendar c w))

(defmethod print-dup java.util.Calendar
[^java.util.Calendar c, ^java.io.Writer w]
(print-calendar c w))


(def ^:private ^ThreadLocal thread-local-utc-timestamp-format
;; SimpleDateFormat is not thread-safe, so we use a ThreadLocal proxy for access.
;; http://bugs.sun.com/bugdatabase/view_bug.do?bug_id=4228335
(proxy [ThreadLocal] []
(initialValue []
(doto (java.text.SimpleDateFormat. "yyyy-MM-dd'T'HH:mm:ss")
(.setTimeZone (java.util.TimeZone/getTimeZone "GMT"))))))

(defn- print-timestamp
"Print a java.sql.Timestamp as RFC3339 timestamp, always in UTC."
[^java.sql.Timestamp ts, ^java.io.Writer w]
(let [^java.text.DateFormat utc-format (.get thread-local-utc-timestamp-format)]
(.write w "#inst \"")
(.write w (.format utc-format ts))
;; add on nanos and offset
;; RFC3339 says to use -00:00 when the timezone is unknown (+00:00 implies a known GMT)
(.write w (format ".%09d-00:00" (.getNanos ts)))
(.write w "\"")))

(defmethod print-method java.sql.Timestamp
[^java.sql.Timestamp ts, ^java.io.Writer w]
(print-timestamp ts w))

(defmethod print-dup java.sql.Timestamp
[^java.sql.Timestamp ts, ^java.io.Writer w]
(print-timestamp ts w))


;;; ------------------------------------------------------------------------
;;; reader integration

(defn- construct-calendar
"Construct a java.util.Calendar, preserving the timezone
offset, but truncating the subsecond fraction to milliseconds."
^GregorianCalendar
[years months days hours minutes seconds nanoseconds
offset-sign offset-hours offset-minutes]
(doto (GregorianCalendar. years (dec months) days hours minutes seconds)
(.set Calendar/MILLISECOND (quot nanoseconds 1000000))
(.setTimeZone (TimeZone/getTimeZone
(format "GMT%s%02d:%02d"
(if (neg? offset-sign) "-" "+")
offset-hours offset-minutes)))))

(defn- construct-date
"Construct a java.util.Date, which expresses the original instant as
milliseconds since the epoch, UTC."
[years months days hours minutes seconds nanoseconds
offset-sign offset-hours offset-minutes]
(.getTime (construct-calendar years months days
hours minutes seconds nanoseconds
offset-sign offset-hours offset-minutes)))

(defn- construct-timestamp
"Construct a java.sql.Timestamp, which has nanosecond precision."
[years months days hours minutes seconds nanoseconds
offset-sign offset-hours offset-minutes]
(doto (Timestamp.
(.getTimeInMillis
(construct-calendar years months days
hours minutes seconds 0
offset-sign offset-hours offset-minutes)))
;; nanos must be set separately, pass 0 above for the base calendar
(.setNanos nanoseconds)))

(defn read-instant-date
"To read an instant as a java.util.Date, bind *data-readers* to a map with
this var as the value for the 'inst key. The timezone offset will be used
to convert into UTC."
[^CharSequence cs]
(parse-timestamp (validated construct-date) cs))

(defn read-instant-calendar
"To read an instant as a java.util.Calendar, bind *data-readers* to a map with
this var as the value for the 'inst key. Calendar preserves the timezone
offset."
[^CharSequence cs]
(parse-timestamp (validated construct-calendar) cs))

(defn read-instant-timestamp
"To read an instant as a java.sql.Timestamp, bind *data-readers* to a
map with this var as the value for the 'inst key. Timestamp preserves
fractional seconds with nanosecond precision. The timezone offset will
be used to convert into UTC."
[^CharSequence cs]
(parse-timestamp (validated construct-timestamp) cs))
47 changes: 47 additions & 0 deletions src/clj/clojure/java/basis.clj
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,47 @@
; Copyright (c) Rich Hickey. All rights reserved.
; The use and distribution terms for this software are covered by the
; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
; which can be found in the file epl-v10.html at the root of this distribution.
; By using this software in any fashion, you are agreeing to be bound by
; the terms of this license.
; You must not remove this notice, or any other, from this software.

(ns clojure.java.basis
"The lib basis includes which libraries and versions were loaded both
for direct dependencies and transitive dependencies, as well as the
classpath and possibly other information from the resolution process.
This basis will be known if the runtime was started by the Clojure CLI.
The Clojure CLI or tools.deps merge a set of deps maps (often from
deps.edn files). Additional runtime modifications are supplied via argmap
keys, provided via alias maps in the merged deps. Deps maps typically have
:paths, :deps, and :aliases keys.
The basis is a superset of merged deps.edn files with the following
additional keys:
:basis-config - params used to configure basis deps sources, can be
string path, deps map, nil, or :default
:root - default = loaded as a resource from tools.deps)
:user - default = ~/.clojure/deps.edn)
:project - default = ./deps.edn)
:extra - default = nil
:aliases - coll of keyword aliases to include during dep calculation
:argmap - effective argmap (after resolving and merging argmaps from aliases)
:libs - map of lib to coord for all included libraries
:classpath - classpath map, keys are paths (to directory or .jar), values
are maps with source identifier (either :lib-name or :path-key)
:classpath-roots - vector of paths in classpath order (keys of :classpath)"
(:require
[clojure.java.basis.impl :as impl]))

(defn initial-basis
"Initial runtime basis at launch, nil if unknown (process not started by CLI)"
{:added "1.12"}
[]
@impl/init-basis)

(defn current-basis
"Return the current basis, which may have been modified since runtime launch."
{:added "1.12"}
[]
@@impl/the-basis)
51 changes: 51 additions & 0 deletions src/clj/clojure/java/basis/impl.clj
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,51 @@
; Copyright (c) Rich Hickey. All rights reserved.
; The use and distribution terms for this software are covered by the
; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
; which can be found in the file epl-v10.html at the root of this distribution.
; By using this software in any fashion, you are agreeing to be bound by
; the terms of this license.
; You must not remove this notice, or any other, from this software.

(ns clojure.java.basis.impl
(:require
[clojure.edn :as edn]
[clojure.java.io :as jio])
(:import
[java.io PushbackReader]))

(set! *warn-on-reflection* true)

(defn- read-edn
"Coerce f to a reader via clojure.java.io/reader and read one edn value.
The reader should contain a single value. Empty input returns nil.
The reader will be read to EOF and closed."
[f]
(let [reader (jio/reader f)
EOF (Object.)]
(with-open [rdr (PushbackReader. reader)]
(let [val (edn/read {:default tagged-literal :eof EOF} rdr)]
(if (identical? EOF val)
nil
(if (not (identical? EOF (edn/read {:eof EOF} rdr)))
(throw (ex-info "Invalid file, expected edn to contain a single value." {}))
val))))))

(defn- read-basis
"Read basis edn from basis file or throw"
[basis-file]
(when-let [f (jio/file basis-file)]
(when (.exists f)
(read-edn f))))

;; delay construction until needed, access via initial-basis
(def init-basis
(delay (read-basis (System/getProperty "clojure.basis"))))

;; delay construction until needed, access via current-basis
(def the-basis
(delay (atom @init-basis)))

(defn update-basis!
"Update the runtime basis by applying f with args"
[f & args]
(apply swap! @the-basis f args))
88 changes: 88 additions & 0 deletions src/clj/clojure/java/browse.clj
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,88 @@
; Copyright (c) Rich Hickey. All rights reserved.
; The use and distribution terms for this software are covered by the
; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
; which can be found in the file epl-v10.html at the root of this distribution.
; By using this software in any fashion, you are agreeing to be bound by
; the terms of this license.
; You must not remove this notice, or any other, from this software.

(ns
^{:author "Christophe Grand",
:doc "Start a web browser from Clojure"}
clojure.java.browse
(:require [clojure.java.shell :as sh]
[clojure.string :as str])
(:import (java.io File)
(java.net URI)
(java.lang ProcessBuilder ProcessBuilder$Redirect)))

(defn- macosx? []
(-> "os.name" System/getProperty .toLowerCase
(.startsWith "mac os x")))

(defn- xdg-open-loc []
;; try/catch needed to mask exception on Windows without Cygwin
(let [which-out (try (:out (sh/sh "which" "xdg-open"))
(catch Exception e ""))]
(if (= which-out "")
nil
(str/trim-newline which-out))))

(defn- open-url-script-val []
(if (macosx?)
"/usr/bin/open"
(xdg-open-loc)))

;; We could assign (open-url-script-val) to *open-url-script* right
;; away in the def below, but clojure.java.shell/sh creates a future
;; that causes a long wait for the JVM to exit during Clojure compiles
;; (unless we can somehow here make it call (shutdown-agents) later).
;; Better to initialize it when we first need it, in browse-url.

(def ^:dynamic *open-url-script* (atom :uninitialized))

(defn- open-url-in-browser
"Opens url (a string) in the default system web browser. May not
work on all platforms. Returns url on success, nil if not
supported."
[url]
(try
(when (clojure.lang.Reflector/invokeStaticMethod "java.awt.Desktop"
"isDesktopSupported" (to-array nil))
(-> (clojure.lang.Reflector/invokeStaticMethod "java.awt.Desktop"
"getDesktop" (to-array nil))
(.browse (URI. url)))
url)
(catch ClassNotFoundException e
nil)))

(defn- open-url-in-swing
"Opens url (a string) in a Swing window."
[url]
; the implementation of this function resides in another namespace to be loaded "on demand"
; this fixes a bug on mac os x where the process turns into a GUI app
; see http://code.google.com/p/clojure-contrib/issues/detail?id=32
(require 'clojure.java.browse-ui)
((find-var 'clojure.java.browse-ui/open-url-in-swing) url))

(defn browse-url
"Open url in a browser"
{:added "1.2"}
[url]
(let [script @*open-url-script*
script (if (= :uninitialized script)
(reset! *open-url-script* (open-url-script-val))
script)]
(or (when script
(try
(let [command [script (str url)]
null-file (File. (if (.startsWith (System/getProperty "os.name") "Windows") "NUL" "/dev/null"))
pb (doto (ProcessBuilder. ^java.util.List command)
;; emulate ProcessBuilder.Redirect.DISCARD added in Java 9
(.redirectOutput null-file)
(.redirectError null-file))]
(.start pb) ;; do not wait for the process
true)
(catch Throwable _ false)))
(open-url-in-browser url)
(open-url-in-swing url))))
30 changes: 30 additions & 0 deletions src/clj/clojure/java/browse_ui.clj
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,30 @@
; Copyright (c) Rich Hickey. All rights reserved.
; The use and distribution terms for this software are covered by the
; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
; which can be found in the file epl-v10.html at the root of this distribution.
; By using this software in any fashion, you are agreeing to be bound by
; the terms of this license.
; You must not remove this notice, or any other, from this software.

(ns
^{:author "Christophe Grand",
:doc "Helper namespace for clojure.java.browse.
Prevents console apps from becoming GUI unnecessarily."}
clojure.java.browse-ui)

(defn- open-url-in-swing
[url]
(let [htmlpane (javax.swing.JEditorPane. url)]
(.setEditable htmlpane false)
(.addHyperlinkListener htmlpane
(proxy [javax.swing.event.HyperlinkListener] []
(hyperlinkUpdate [^javax.swing.event.HyperlinkEvent e]
(when (= (.getEventType e) (. javax.swing.event.HyperlinkEvent$EventType ACTIVATED))
(if (instance? javax.swing.text.html.HTMLFrameHyperlinkEvent e)
(-> htmlpane .getDocument (.processHTMLFrameHyperlinkEvent e))
(.setPage htmlpane (.getURL e)))))))
(doto (javax.swing.JFrame.)
(.setContentPane (javax.swing.JScrollPane. htmlpane))
(.setBounds 32 32 700 900)
(.setVisible true))))

454 changes: 454 additions & 0 deletions src/clj/clojure/java/io.clj
View file

Large diffs are not rendered by default.

102 changes: 102 additions & 0 deletions src/clj/clojure/java/javadoc.clj
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,102 @@
; Copyright (c) Rich Hickey. All rights reserved.
; The use and distribution terms for this software are covered by the
; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
; which can be found in the file epl-v10.html at the root of this distribution.
; By using this software in any fashion, you are agreeing to be bound by
; the terms of this license.
; You must not remove this notice, or any other, from this software.
(ns
^{:author "Christophe Grand, Stuart Sierra",
:doc "A repl helper to quickly open javadocs."}
clojure.java.javadoc
(:use [clojure.java.browse :only (browse-url)] )
(:import
(java.io File)))

(def ^:dynamic *feeling-lucky-url* "http://www.google.com/search?btnI=I%27m%20Feeling%20Lucky&q=allinurl:")
(def ^:dynamic *feeling-lucky* true)

(def ^:dynamic *local-javadocs* (ref (list)))

(def ^:dynamic *core-java-api*
(case (System/getProperty "java.specification.version")
"1.8" "http://docs.oracle.com/javase/8/docs/api/"
"9" "http://docs.oracle.com/javase/9/docs/api/"
"10" "http://docs.oracle.com/javase/10/docs/api/"
"11" "https://docs.oracle.com/en/java/javase/11/docs/api/%s/"
"12" "https://docs.oracle.com/en/java/javase/12/docs/api/%s/"
"13" "https://docs.oracle.com/en/java/javase/13/docs/api/%s/"
"14" "https://docs.oracle.com/en/java/javase/14/docs/api/%s/"
"15" "https://docs.oracle.com/en/java/javase/15/docs/api/%s/"
"http://docs.oracle.com/javase/8/docs/api/"))

(def ^:dynamic *remote-javadocs*
(ref (sorted-map
"com.google.common." "http://google.github.io/guava/releases/23.0/api/docs/"
"java." *core-java-api*
"javax." *core-java-api*
"org.ietf.jgss." *core-java-api*
"org.omg." *core-java-api*
"org.w3c.dom." *core-java-api*
"org.xml.sax." *core-java-api*
"org.apache.commons.codec." "http://commons.apache.org/proper/commons-codec/apidocs/"
"org.apache.commons.io." "http://commons.apache.org/proper/commons-io/javadocs/api-release/"
"org.apache.commons.lang." "http://commons.apache.org/proper/commons-lang/javadocs/api-2.6/"
"org.apache.commons.lang3." "http://commons.apache.org/proper/commons-lang/javadocs/api-release/")))

(defn add-local-javadoc
"Adds to the list of local Javadoc paths."
{:added "1.2"}
[path]
(dosync (commute *local-javadocs* conj path)))

(defn add-remote-javadoc
"Adds to the list of remote Javadoc URLs. package-prefix is the
beginning of the package name that has docs at this URL."
{:added "1.2"}
[package-prefix url]
(dosync (commute *remote-javadocs* assoc package-prefix url)))

(defn- fill-in-module-name [^String url ^String classname]
;; The getModule method was introduced in JDK 9, and did not exist
;; in earlier JDK versions. Avoid calling it unless its result is
;; needed.
(if (.contains url "%s")
(let [klass (Class/forName classname)
module-name (.getName (.getModule klass))]
(format url module-name))
url))

(defn- javadoc-url
"Searches for a URL for the given class name. Tries
*local-javadocs* first, then *remote-javadocs*. Returns a string."
{:tag String,
:added "1.2"}
[^String classname]
(let [file-path (.replace classname \. File/separatorChar)
url-path (.replace classname \. \/)]
(if-let [file ^File (first
(filter #(.exists ^File %)
(map #(File. (str %) (str file-path ".html"))
@*local-javadocs*)))]
(-> file .toURI str)
;; If no local file, try remote URLs:
(or (some (fn [[prefix url]]
(when (.startsWith classname prefix)
(str (fill-in-module-name url classname)
url-path ".html")))
@*remote-javadocs*)
;; if *feeling-lucky* try a web search
(when *feeling-lucky* (str *feeling-lucky-url* url-path ".html"))))))

(defn javadoc
"Opens a browser window displaying the javadoc for the argument.
Tries *local-javadocs* first, then *remote-javadocs*."
{:added "1.2"}
[class-or-object]
(let [^Class c (if (instance? Class class-or-object)
class-or-object
(class class-or-object))]
(if-let [url (javadoc-url (.getName c))]
(browse-url url)
(println "Could not find Javadoc for" c))))
191 changes: 191 additions & 0 deletions src/clj/clojure/java/process.clj
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,191 @@
; Copyright (c) Rich Hickey. All rights reserved.
; The use and distribution terms for this software are covered by the
; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
; which can be found in the file epl-v10.html at the root of this distribution.
; By using this software in any fashion, you are agreeing to be bound by
; the terms of this license.
; You must not remove this notice, or any other, from this software.

(ns clojure.java.process
"A process invocation API wrapping the Java process API.
The primary function is 'start' which starts a process and handles the
streams as directed. It returns the Process object. Use 'exit-ref' to wait
for completion and receive the exit value, and ‘stdout', 'stderr', 'stdin'
to access the process streams. The 'exec' function handles the common case
to 'start' a process, wait for process exit, and return stdout."
(:require
[clojure.java.io :as jio])
(:import
[java.io File InputStream OutputStream]
[java.lang ProcessBuilder ProcessBuilder$Redirect Process]
[java.util List]
[clojure.lang IDeref IBlockingDeref]
[java.util.concurrent Executors ExecutorService ThreadFactory]))

(set! *warn-on-reflection* true)

;; this is built into Java 9, backfilled here for Java 8
(def ^:private ^File null-file
(delay
(jio/file
(if (.startsWith (System/getProperty "os.name") "Windows")
"NUL"
"/dev/null"))))

(defn to-file
"Coerce f to a file per clojure.java.io/file and return a ProcessBuilder.Redirect writing to the file.
Set ':append' in opts to append. This can be passed to 'start' in :out or :err."
{:added "1.12"}
^ProcessBuilder$Redirect [f & {:keys [append] :as opts}]
(let [fo (jio/file f)]
(if append
(ProcessBuilder$Redirect/appendTo fo)
(ProcessBuilder$Redirect/to fo))))

(defn from-file
"Coerce f to a file per clojure.java.io/file and return a ProcessBuilder.Redirect reading from the file.
This can be passed to 'start' in :in."
{:added "1.12"}
^ProcessBuilder$Redirect [f]
(ProcessBuilder$Redirect/from (jio/file f)))

(defn start
"Start an external command, defined in args.
The process environment vars are inherited from the parent by
default (use :clear-env to clear them).
If needed, provide options in map as first arg:
:in - a ProcessBuilder.Redirect (default = :pipe) or :inherit
:out - a ProcessBuilder.Redirect (default = :pipe) or :inherit :discard
:err - a ProcessBuilder.Redirect (default = :pipe) or :inherit :discard :stdout
:dir - current directory when the process runs (default=\".\")
:clear-env - if true, remove all inherited parent env vars
:env - {env-var value} of environment variables to set (all strings)
Returns the java.lang.Process."
{:added "1.12"}
^Process [& opts+args]
(let [[opts command] (if (map? (first opts+args))
[(first opts+args) (rest opts+args)]
[{} opts+args])
{:keys [in out err dir env clear-env]
:or {in :pipe, out :pipe, err :pipe, dir "."}} opts
pb (ProcessBuilder. ^List command)
to-redirect (fn to-redirect
[x]
(case x
:pipe ProcessBuilder$Redirect/PIPE
:inherit ProcessBuilder$Redirect/INHERIT
:discard (ProcessBuilder$Redirect/to @null-file)
;; in Java 9+, just use ProcessBuilder$Redirect/DISCARD
x))]
(.directory pb (jio/file dir))
(.redirectInput pb ^ProcessBuilder$Redirect (to-redirect in))
(.redirectOutput pb ^ProcessBuilder$Redirect (to-redirect out))
(if
(= err :stdout) (.redirectErrorStream pb true)
(.redirectError pb ^ProcessBuilder$Redirect (to-redirect err)))
(when clear-env
(.clear (.environment pb)))
(when env
(let [pb-env (.environment pb)]
(run! (fn [[k v]] (.put pb-env k v)) env)))
(.start pb)))

(defn stdin
"Given a process, return the stdin of the external process (an OutputStream)"
^OutputStream [^Process process]
(.getOutputStream process))

(defn stdout
"Given a process, return the stdout of the external process (an InputStream)"
^InputStream [^Process process]
(.getInputStream process))

(defn stderr
"Given a process, return the stderr of the external process (an InputStream)"
^InputStream [^Process process]
(.getErrorStream process))

(defn exit-ref
"Given a Process (the output of 'start'), return a reference that can be
used to wait for process completion then returns the exit value."
[^Process process]
(reify
IDeref
(deref [_] (long (.waitFor process)))

IBlockingDeref
(deref [_ timeout-ms timeout-val]
(if (.waitFor process timeout-ms java.util.concurrent.TimeUnit/MILLISECONDS)
(long (.exitValue process))
timeout-val))))

;; A thread factory for daemon threads
(defonce ^:private io-thread-factory
(let [counter (atom 0)]
(reify ThreadFactory
(newThread [_ r]
(doto (Thread. r)
(.setName (str "Clojure Process IO " (swap! counter inc)))
(.setDaemon true))))))

;; An ExecutorService for cached, daemon threads
(defonce ^:private io-executor
(Executors/newCachedThreadPool ^ThreadFactory io-thread-factory))

(defn io-task
{:skip-wiki true}
[^Runnable f]
(let [f (bound-fn* f)
fut (.submit ^ExecutorService io-executor ^Callable f)]
(reify
clojure.lang.IDeref
(deref [_] (#'clojure.core/deref-future fut))
clojure.lang.IBlockingDeref
(deref
[_ timeout-ms timeout-val]
(#'clojure.core/deref-future fut timeout-ms timeout-val))
clojure.lang.IPending
(isRealized [_] (.isDone fut))
java.util.concurrent.Future
(get [_] (.get fut))
(get [_ timeout unit] (.get fut timeout unit))
(isCancelled [_] (.isCancelled fut))
(isDone [_] (.isDone fut))
(cancel [_ interrupt?] (.cancel fut interrupt?)))))

(defn exec
"Execute a command and on successful exit, return the captured output,
else throw RuntimeException. Args are the same as 'start' and options
if supplied override the default 'exec' settings."
{:added "1.12"}
[& opts+args]
(let [[opts command] (if (map? (first opts+args))
[(first opts+args) (rest opts+args)]
[{} opts+args])
opts (merge {:err :inherit} opts)]
(let [proc (apply start opts command)
captured (io-task #(slurp (stdout proc)))
exit (deref (exit-ref proc))]
(if (zero? exit)
@captured
(throw (RuntimeException. (str "Process failed with exit=" exit)))))))

(comment
;; shell out and inherit the i/o
(start {:out :inherit, :err :stdout} "ls" "-l")

;; write out and err to files, wait for process to exit, return exit code
@(exit-ref (start {:out (to-file "out") :err (to-file "err")} "ls" "-l"))

;; capture output to string
(-> (start "ls" "-l") stdout slurp)

;; with exec
(exec "ls" "-l")

;; read input from file
(-> (exec {:in (from-file "deps.edn")} "wc" "-l") clojure.string/trim parse-long)
)
142 changes: 142 additions & 0 deletions src/clj/clojure/java/shell.clj
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,142 @@
; Copyright (c) Rich Hickey. All rights reserved.
; The use and distribution terms for this software are covered by the
; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
; which can be found in the file epl-v10.html at the root of this distribution.
; By using this software in any fashion, you are agreeing to be bound by
; the terms of this license.
; You must not remove this notice, or any other, from this software.

(ns
^{:author "Chris Houser, Stuart Halloway",
:doc "Conveniently launch a sub-process providing its stdin and
collecting its stdout"}
clojure.java.shell
(:use [clojure.java.io :only (as-file copy)])
(:import (java.io ByteArrayOutputStream StringWriter)
(java.nio.charset Charset)))

(def ^:dynamic *sh-dir* nil)
(def ^:dynamic *sh-env* nil)

(defmacro with-sh-dir
"Sets the directory for use with sh, see sh for details."
{:added "1.2"}
[dir & forms]
`(binding [*sh-dir* ~dir]
~@forms))

(defmacro with-sh-env
"Sets the environment for use with sh, see sh for details."
{:added "1.2"}
[env & forms]
`(binding [*sh-env* ~env]
~@forms))

(defn- aconcat
"Concatenates arrays of given type."
[type & xs]
(let [target (make-array type (apply + (map count xs)))]
(loop [i 0 idx 0]
(when-let [a (nth xs i nil)]
(System/arraycopy a 0 target idx (count a))
(recur (inc i) (+ idx (count a)))))
target))

(defn- parse-args
[args]
(let [default-encoding "UTF-8" ;; see sh doc string
default-opts {:out-enc default-encoding :in-enc default-encoding :dir *sh-dir* :env *sh-env*}
[cmd opts] (split-with string? args)]
[cmd (merge default-opts (apply hash-map opts))]))

(defn- ^"[Ljava.lang.String;" as-env-strings
"Helper so that callers can pass a Clojure map for the :env to sh."
[arg]
(cond
(nil? arg) nil
(map? arg) (into-array String (map (fn [[k v]] (str (name k) "=" v)) arg))
true arg))

(defn- stream-to-bytes
[in]
(with-open [bout (ByteArrayOutputStream.)]
(copy in bout)
(.toByteArray bout)))

(defn- stream-to-string
([in] (stream-to-string in (.name (Charset/defaultCharset))))
([in enc]
(with-open [bout (StringWriter.)]
(copy in bout :encoding enc)
(.toString bout))))

(defn- stream-to-enc
[stream enc]
(if (= enc :bytes)
(stream-to-bytes stream)
(stream-to-string stream enc)))

(defn sh
"Passes the given strings to Runtime.exec() to launch a sub-process.
Options are
:in may be given followed by any legal input source for
clojure.java.io/copy, e.g. InputStream, Reader, File, byte[],
or String, to be fed to the sub-process's stdin.
:in-enc option may be given followed by a String, used as a character
encoding name (for example \"UTF-8\" or \"ISO-8859-1\") to
convert the input string specified by the :in option to the
sub-process's stdin. Defaults to UTF-8.
If the :in option provides a byte array, then the bytes are passed
unencoded, and this option is ignored.
:out-enc option may be given followed by :bytes or a String. If a
String is given, it will be used as a character encoding
name (for example \"UTF-8\" or \"ISO-8859-1\") to convert
the sub-process's stdout to a String which is returned.
If :bytes is given, the sub-process's stdout will be stored
in a byte array and returned. Defaults to UTF-8.
:env override the process env with a map (or the underlying Java
String[] if you are a masochist).
:dir override the process dir with a String or java.io.File.
You can bind :env or :dir for multiple operations using with-sh-env
and with-sh-dir.
sh returns a map of
:exit => sub-process's exit code
:out => sub-process's stdout (as byte[] or String)
:err => sub-process's stderr (String via platform default encoding)"
{:added "1.2"}
[& args]
(let [[cmd opts] (parse-args args)
proc (.exec (Runtime/getRuntime)
^"[Ljava.lang.String;" (into-array cmd)
(as-env-strings (:env opts))
(as-file (:dir opts)))
{:keys [in in-enc out-enc]} opts]
(if in
(future
(with-open [os (.getOutputStream proc)]
(copy in os :encoding in-enc)))
(.close (.getOutputStream proc)))
(with-open [stdout (.getInputStream proc)
stderr (.getErrorStream proc)]
(let [out (future (stream-to-enc stdout out-enc))
err (future (stream-to-string stderr))
exit-code (.waitFor proc)]
{:exit exit-code :out @out :err @err}))))

(comment

(println (sh "ls" "-l"))
(println (sh "ls" "-l" "/no-such-thing"))
(println (sh "sed" "s/[aeiou]/oo/g" :in "hello there\n"))
(println (sh "sed" "s/[aeiou]/oo/g" :in (java.io.StringReader. "hello there\n")))
(println (sh "cat" :in "x\u25bax\n"))
(println (sh "echo" "x\u25bax"))
(println (sh "echo" "x\u25bax" :out-enc "ISO-8859-1")) ; reads 4 single-byte chars
(println (sh "cat" "myimage.png" :out-enc :bytes)) ; reads binary file into bytes[]
(println (sh "cmd" "/c dir 1>&2"))

)
461 changes: 400 additions & 61 deletions src/clj/clojure/main.clj
View file

Large diffs are not rendered by default.

523 changes: 523 additions & 0 deletions src/clj/clojure/math.clj
View file

Large diffs are not rendered by default.

4 changes: 3 additions & 1 deletion src/clj/clojure/parallel.clj
View file
Original file line number Diff line number Diff line change
Expand Up @@ -6,7 +6,9 @@
; the terms of this license.
; You must not remove this notice, or any other, from this software.

(ns clojure.parallel)
(ns ^{:doc "DEPRECATED Wrapper of the ForkJoin library (JSR-166)."
:author "Rich Hickey"}
clojure.parallel)
(alias 'parallel 'clojure.parallel)

(comment "
Expand Down
51 changes: 51 additions & 0 deletions src/clj/clojure/pprint.clj
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,51 @@
;;; pprint.clj -- Pretty printer and Common Lisp compatible format function (cl-format) for Clojure

; Copyright (c) Rich Hickey. All rights reserved.
; The use and distribution terms for this software are covered by the
; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
; which can be found in the file epl-v10.html at the root of this distribution.
; By using this software in any fashion, you are agreeing to be bound by
; the terms of this license.
; You must not remove this notice, or any other, from this software.

;; Author: Tom Faulhaber
;; April 3, 2009

(ns
^{:author "Tom Faulhaber",
:doc "A Pretty Printer for Clojure
clojure.pprint implements a flexible system for printing structured data
in a pleasing, easy-to-understand format. Basic use of the pretty printer is
simple, just call pprint instead of println. More advanced users can use
the building blocks provided to create custom output formats.
Out of the box, pprint supports a simple structured format for basic data
and a specialized format for Clojure source code. More advanced formats,
including formats that don't look like Clojure data at all like XML and
JSON, can be rendered by creating custom dispatch functions.
In addition to the pprint function, this module contains cl-format, a text
formatting function which is fully compatible with the format function in
Common Lisp. Because pretty printing directives are directly integrated with
cl-format, it supports very concise custom dispatch. It also provides
a more powerful alternative to Clojure's standard format function.
See documentation for pprint and cl-format for more information or
complete documentation on the Clojure web site on GitHub.",
:added "1.2"}
clojure.pprint
(:refer-clojure :exclude (deftype))
(:use [clojure.walk :only [walk]]))

(set! *warn-on-reflection* true)

(load "pprint/utilities")
(load "pprint/column_writer")
(load "pprint/pretty_writer")
(load "pprint/pprint_base")
(load "pprint/cl_format")
(load "pprint/dispatch")
(load "pprint/print_table")

nil
1,949 changes: 1,949 additions & 0 deletions src/clj/clojure/pprint/cl_format.clj
View file

Large diffs are not rendered by default.

83 changes: 83 additions & 0 deletions src/clj/clojure/pprint/column_writer.clj
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,83 @@
;;; column_writer.clj -- part of the pretty printer for Clojure


; Copyright (c) Rich Hickey. All rights reserved.
; The use and distribution terms for this software are covered by the
; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
; which can be found in the file epl-v10.html at the root of this distribution.
; By using this software in any fashion, you are agreeing to be bound by
; the terms of this license.
; You must not remove this notice, or any other, from this software.

;; Author: Tom Faulhaber
;; April 3, 2009
;; Revised to use proxy instead of gen-class April 2010

;; This module implements a column-aware wrapper around an instance of java.io.Writer

(in-ns 'clojure.pprint)

(import [clojure.lang IDeref]
[java.io Writer])

(def ^:dynamic ^{:private true} *default-page-width* 72)

(defn- get-field [^Writer this sym]
(sym @@this))

(defn- set-field [^Writer this sym new-val]
(alter @this assoc sym new-val))

(defn- get-column [this]
(get-field this :cur))

(defn- get-line [this]
(get-field this :line))

(defn- get-max-column [this]
(get-field this :max))

(defn- set-max-column [this new-max]
(dosync (set-field this :max new-max))
nil)

(defn- get-writer [this]
(get-field this :base))

(defn- c-write-char [^Writer this ^Integer c]
(dosync (if (= c (int \newline))
(do
(set-field this :cur 0)
(set-field this :line (inc (get-field this :line))))
(set-field this :cur (inc (get-field this :cur)))))
(.write ^Writer (get-field this :base) c))

(defn- column-writer
([writer] (column-writer writer *default-page-width*))
([^Writer writer max-columns]
(let [fields (ref {:max max-columns, :cur 0, :line 0 :base writer})]
(proxy [Writer IDeref] []
(deref [] fields)
(flush []
(.flush writer))
(write
([^chars cbuf ^Integer off ^Integer len]
(let [^Writer writer (get-field this :base)]
(.write writer cbuf off len)))
([x]
(condp = (class x)
String
(let [^String s x
nl (.lastIndexOf s (int \newline))]
(dosync (if (neg? nl)
(set-field this :cur (+ (get-field this :cur) (count s)))
(do
(set-field this :cur (- (count s) nl 1))
(set-field this :line (+ (get-field this :line)
(count (filter #(= % \newline) s)))))))
(.write ^Writer (get-field this :base) s))

Integer
(c-write-char this x)
Long
(c-write-char this x))))))))
568 changes: 568 additions & 0 deletions src/clj/clojure/pprint/dispatch.clj
View file

Large diffs are not rendered by default.

403 changes: 403 additions & 0 deletions src/clj/clojure/pprint/pprint_base.clj
View file

Large diffs are not rendered by default.

506 changes: 506 additions & 0 deletions src/clj/clojure/pprint/pretty_writer.clj
View file

Large diffs are not rendered by default.

35 changes: 35 additions & 0 deletions src/clj/clojure/pprint/print_table.clj
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,35 @@
; Copyright (c) Rich Hickey. All rights reserved.
; The use and distribution terms for this software are covered by the
; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
; which can be found in the file epl-v10.html at the root of this distribution.
; By using this software in any fashion, you are agreeing to be bound by
; the terms of this license.
; You must not remove this notice, or any other, from this software.

(in-ns 'clojure.pprint)

(defn print-table
"Prints a collection of maps in a textual table. Prints table headings
ks, and then a line of output for each row, corresponding to the keys
in ks. If ks are not specified, use the keys of the first item in rows."
{:added "1.3"}
([ks rows]
(when (seq rows)
(let [widths (map
(fn [k]
(apply max (count (str k)) (map #(count (str (get % k))) rows)))
ks)
spacers (map #(apply str (repeat % "-")) widths)
fmts (map #(str "%" % "s") widths)
fmt-row (fn [leader divider trailer row]
(str leader
(apply str (interpose divider
(for [[col fmt] (map vector (map #(get row %) ks) fmts)]
(format fmt (str col)))))
trailer))]
(println)
(println (fmt-row "| " " | " " |" (zipmap ks ks)))
(println (fmt-row "|-" "-+-" "-|" (zipmap ks spacers)))
(doseq [row rows]
(println (fmt-row "| " " | " " |" row))))))
([rows] (print-table (keys (first rows)) rows)))
114 changes: 114 additions & 0 deletions src/clj/clojure/pprint/utilities.clj
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,114 @@
;;; utilities.clj -- part of the pretty printer for Clojure

; Copyright (c) Rich Hickey. All rights reserved.
; The use and distribution terms for this software are covered by the
; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
; which can be found in the file epl-v10.html at the root of this distribution.
; By using this software in any fashion, you are agreeing to be bound by
; the terms of this license.
; You must not remove this notice, or any other, from this software.

;; Author: Tom Faulhaber
;; April 3, 2009

;; This module implements some utility function used in formatting and pretty
;; printing. The functions here could go in a more general purpose library,
;; perhaps.

(in-ns 'clojure.pprint)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Helper functions for digesting formats in the various
;;; phases of their lives.
;;; These functions are actually pretty general.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defn- map-passing-context [func initial-context lis]
(loop [context initial-context
lis lis
acc []]
(if (empty? lis)
[acc context]
(let [this (first lis)
remainder (next lis)
[result new-context] (apply func [this context])]
(recur new-context remainder (conj acc result))))))

(defn- consume [func initial-context]
(loop [context initial-context
acc []]
(let [[result new-context] (apply func [context])]
(if (not result)
[acc new-context]
(recur new-context (conj acc result))))))

(defn- consume-while [func initial-context]
(loop [context initial-context
acc []]
(let [[result continue new-context] (apply func [context])]
(if (not continue)
[acc context]
(recur new-context (conj acc result))))))

(defn- unzip-map
"Take a map that has pairs in the value slots and produce a pair of
maps, the first having all the first elements of the pairs and the
second all the second elements of the pairs"
[m]
[(into {} (for [[k [v1 v2]] m] [k v1]))
(into {} (for [[k [v1 v2]] m] [k v2]))])

(defn- tuple-map
"For all the values, v, in the map, replace them with [v v1]"
[m v1]
(into {} (for [[k v] m] [k [v v1]])))

(defn- rtrim
"Trim all instances of c from the end of sequence s"
[s c]
(let [len (count s)]
(if (and (pos? len) (= (nth s (dec (count s))) c))
(loop [n (dec len)]
(cond
(neg? n) ""
(not (= (nth s n) c)) (subs s 0 (inc n))
true (recur (dec n))))
s)))

(defn- ltrim
"Trim all instances of c from the beginning of sequence s"
[s c]
(let [len (count s)]
(if (and (pos? len) (= (nth s 0) c))
(loop [n 0]
(if (or (= n len) (not (= (nth s n) c)))
(subs s n)
(recur (inc n))))
s)))

(defn- prefix-count
"Return the number of times that val occurs at the start of sequence aseq,
if val is a seq itself, count the number of times any element of val
occurs at the beginning of aseq"
[aseq val]
(let [test (if (coll? val) (set val) #{val})]
(loop [pos 0]
(if (or (= pos (count aseq)) (not (test (nth aseq pos))))
pos
(recur (inc pos))))))

(defn- prerr
"Println to *err*"
[& args]
(binding [*out* *err*]
(apply println args)))

(defmacro ^{:private true} prlabel
"Print args to *err* in name = value format"
[prefix arg & more-args]
`(prerr ~@(cons (list 'quote prefix) (mapcat #(list (list 'quote %) "=" %)
(cons arg (seq more-args))))))

;; Flush the pretty-print buffer without flushing the underlying stream
(definterface PrettyFlush
(^void ppflush []))
123 changes: 123 additions & 0 deletions src/clj/clojure/reflect.clj
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,123 @@
; Copyright (c) Rich Hickey. All rights reserved.
; The use and distribution terms for this software are covered by the
; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
; which can be found in the file epl-v10.html at the root of this distribution.
; By using this software in any fashion, you are agreeing to be bound by
; the terms of this license.
; You must not remove this notice, or any other, from this software.

(ns ^{:author "Stuart Halloway"
:added "1.3"
:doc "Reflection on Host Types
Alpha - subject to change.
Two main entry points:
* type-reflect reflects on something that implements TypeReference.
* reflect (for REPL use) reflects on the class of an instance, or
on a class if passed a class
Key features:
* Exposes the read side of reflection as pure data. Reflecting
on a type returns a map with keys :bases, :flags, and :members.
* Canonicalizes class names as Clojure symbols. Types can extend
to the TypeReference protocol to indicate that they can be
unambiguously resolved as a type name. The canonical format
requires one non-Java-ish convention: array brackets are <>
instead of [] so they can be part of a Clojure symbol.
* Pluggable Reflectors for different implementations. The default
JavaReflector is good when you have a class in hand, or use
the AsmReflector for \"hands off\" reflection without forcing
classes to load.
Platform implementers must:
* Create an implementation of Reflector.
* Create one or more implementations of TypeReference.
* def default-reflector to be an instance that satisfies Reflector."}
clojure.reflect
(:require [clojure.set :as set]))

(defprotocol Reflector
"Protocol for reflection implementers."
(do-reflect [reflector typeref]))

(defprotocol TypeReference
"A TypeReference can be unambiguously converted to a type name on
the host platform.
All typerefs are normalized into symbols. If you need to
normalize a typeref yourself, call typesym."
(typename [o] "Returns Java name as returned by ASM getClassName, e.g. byte[], java.lang.String[]"))

(declare default-reflector)

(defn type-reflect
"Alpha - subject to change.
Reflect on a typeref, returning a map with :bases, :flags, and
:members. In the discussion below, names are always Clojure symbols.
:bases a set of names of the type's bases
:flags a set of keywords naming the boolean attributes
of the type.
:members a set of the type's members. Each member is a map
and can be a constructor, method, or field.
Keys common to all members:
:name name of the type
:declaring-class name of the declarer
:flags keyword naming boolean attributes of the member
Keys specific to constructors:
:parameter-types vector of parameter type names
:exception-types vector of exception type names
Key specific to methods:
:parameter-types vector of parameter type names
:exception-types vector of exception type names
:return-type return type name
Keys specific to fields:
:type type name
Options:
:ancestors in addition to the keys described above, also
include an :ancestors key with the entire set of
ancestors, and add all ancestor members to
:members.
:reflector implementation to use. Defaults to JavaReflector,
AsmReflector is also an option."
{:added "1.3"}
[typeref & options]
(let [{:keys [ancestors reflector]}
(merge {:reflector default-reflector}
(apply hash-map options))
refl (partial do-reflect reflector)
result (refl typeref)]
;; could make simpler loop of two args: names an
(if ancestors
(let [make-ancestor-map (fn [names]
(zipmap names (map refl names)))]
(loop [reflections (make-ancestor-map (:bases result))]
(let [ancestors-visited (set (keys reflections))
ancestors-to-visit (set/difference (set (mapcat :bases (vals reflections)))
ancestors-visited)]
(if (seq ancestors-to-visit)
(recur (merge reflections (make-ancestor-map ancestors-to-visit)))
(apply merge-with into result {:ancestors ancestors-visited}
(map #(select-keys % [:members]) (vals reflections)))))))
result)))

(defn reflect
"Alpha - subject to change.
Reflect on the type of obj (or obj itself if obj is a class).
Return value and options are the same as for type-reflect. "
{:added "1.3"}
[obj & options]
(apply type-reflect (if (class? obj) obj (class obj)) options))

(load "reflect/java")
267 changes: 267 additions & 0 deletions src/clj/clojure/reflect/java.clj
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,267 @@
; Copyright (c) Rich Hickey. All rights reserved.
; The use and distribution terms for this software are covered by the
; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
; which can be found in the file epl-v10.html at the root of this distribution.
; By using this software in any fashion, you are agreeing to be bound by
; the terms of this license.
; You must not remove this notice, or any other, from this software.

;; Java-specific parts of clojure.reflect
(in-ns 'clojure.reflect)

(require '[clojure.datafy :refer (datafy)]
'[clojure.set :as set]
'[clojure.string :as str])
(import '[clojure.asm ClassReader ClassVisitor Type Opcodes]
'[java.lang.reflect Modifier]
java.io.InputStream)

(set! *warn-on-reflection* true)

(extend-protocol TypeReference
clojure.lang.Symbol
(typename [s] (str/replace (str s) "<>" "[]"))

Class
;; neither .getName not .getSimpleName returns the right thing, so best to delegate to Type
(typename
[c]
(typename (Type/getType c)))

Type
(typename
[t]
(-> (.getClassName t))))

(defn- typesym
"Given a typeref, create a legal Clojure symbol version of the
type's name."
[t]
(cond->
(-> (typename t)
(str/replace "[]" "<>")
(symbol))
(class? t) (with-meta {'clojure.core.protocols/datafy
(fn [_] (datafy t))})))

(defn- resource-name
"Given a typeref, return implied resource name. Used by Reflectors
such as ASM that need to find and read classbytes from files."
[typeref]
(-> (typename typeref)
(str/replace "." "/")
(str ".class")))

(defn- access-flag
[[name flag & contexts]]
{:name name :flag flag :contexts (set (map keyword contexts))})

(defn- field-descriptor->class-symbol
"Convert a Java field descriptor to a Clojure class symbol. Field
descriptors are described in section 4.3.2 of the JVM spec, 2nd ed.:
http://java.sun.com/docs/books/jvms/second_edition/html/ClassFile.doc.html#14152"
[^String d]
{:pre [(string? d)]}
(typesym (Type/getType d)))

(defn- internal-name->class-symbol
"Convert a Java internal name to a Clojure class symbol. Internal
names uses slashes instead of dots, e.g. java/lang/String. See
Section 4.2 of the JVM spec, 2nd ed.:
http://java.sun.com/docs/books/jvms/second_edition/html/ClassFile.doc.html#14757"
[d]
{:pre [(string? d)]}
(typesym (Type/getObjectType d)))

(def ^{:doc "The Java access bitflags, along with their friendly names and
the kinds of objects to which they can apply."}
flag-descriptors
(vec
(map access-flag
[[:public 0x0001 :class :field :method]
[:private 0x002 :class :field :method]
[:protected 0x0004 :class :field :method]
[:static 0x0008 :field :method]
[:final 0x0010 :class :field :method]
;; :super is ancient history and is unfindable (?) by
;; reflection. skip it
#_[:super 0x0020 :class]
[:synchronized 0x0020 :method]
[:volatile 0x0040 :field]
[:bridge 0x0040 :method]
[:varargs 0x0080 :method]
[:transient 0x0080 :field]
[:native 0x0100 :method]
[:interface 0x0200 :class]
[:abstract 0x0400 :class :method]
[:strict 0x0800 :method]
[:synthetic 0x1000 :class :field :method]
[:annotation 0x2000 :class]
[:enum 0x4000 :class :field :inner]])))

(defn- parse-flags
"Convert reflection bitflags into a set of keywords."
[flags context]
(reduce
(fn [result fd]
(if (and (get (:contexts fd) context)
(not (zero? (bit-and flags (:flag fd)))))
(conj result (:name fd))
result))
#{}
flag-descriptors))

(defrecord Constructor
[name declaring-class parameter-types exception-types flags])

(defn- constructor->map
[^java.lang.reflect.Constructor constructor]
(Constructor.
(symbol (.getName constructor))
(typesym (.getDeclaringClass constructor))
(vec (map typesym (.getParameterTypes constructor)))
(vec (map typesym (.getExceptionTypes constructor)))
(parse-flags (.getModifiers constructor) :method)))

(defn- declared-constructors
"Return a set of the declared constructors of class as a Clojure map."
[^Class cls]
(set (map
constructor->map
(.getDeclaredConstructors cls))))

(defrecord Method
[name return-type declaring-class parameter-types exception-types flags])

(defn- method->map
[^java.lang.reflect.Method method]
(Method.
(symbol (.getName method))
(typesym (.getReturnType method))
(typesym (.getDeclaringClass method))
(vec (map typesym (.getParameterTypes method)))
(vec (map typesym (.getExceptionTypes method)))
(parse-flags (.getModifiers method) :method)))

(defn- declared-methods
"Return a set of the declared constructors of class as a Clojure map."
[^Class cls]
(set (map
method->map
(.getDeclaredMethods cls))))

(defrecord Field
[name type declaring-class flags])

(defn- field->map
[^java.lang.reflect.Field field]
(Field.
(symbol (.getName field))
(typesym (.getType field))
(typesym (.getDeclaringClass field))
(parse-flags (.getModifiers field) :field)))

(defn- declared-fields
"Return a set of the declared fields of class as a Clojure map."
[^Class cls]
(set (map
field->map
(.getDeclaredFields cls))))

(defn- typeref->class
^Class [typeref classloader]
(if (class? typeref)
typeref
(clojure.lang.RT/classForName (typename typeref) false classloader)))

(deftype JavaReflector [classloader]
Reflector
(do-reflect [_ typeref]
(let [cls (typeref->class typeref classloader)]
{:bases (not-empty (set (map typesym (bases cls))))
:flags (parse-flags (.getModifiers cls) :class)
:members (set/union (declared-fields cls)
(declared-methods cls)
(declared-constructors cls))})))

(def ^:private default-reflector
(JavaReflector. (.getContextClassLoader (Thread/currentThread))))

(defn- parse-method-descriptor
[^String md]
{:parameter-types (vec (map typesym (Type/getArgumentTypes md)))
:return-type (typesym (Type/getReturnType md))})

(defprotocol ClassResolver
(^InputStream resolve-class [this name]
"Given a class name, return that typeref's class bytes as an InputStream."))

(extend-protocol ClassResolver
clojure.lang.Fn
(resolve-class [this typeref] (this typeref))

ClassLoader
(resolve-class [this typeref]
(.getResourceAsStream this (resource-name typeref))))

(deftype AsmReflector [class-resolver]
Reflector
(do-reflect [_ typeref]
(with-open [is (resolve-class class-resolver typeref)]
(let [class-symbol (typesym typeref)
r (ClassReader. is)
result (atom {:bases #{} :flags #{} :members #{}})]
(.accept
r
(proxy
[ClassVisitor]
[Opcodes/ASM4]
(visit [version access name signature superName interfaces]
(let [flags (parse-flags access :class)
;; ignore java.lang.Object on interfaces to match reflection
superName (if (and (flags :interface)
(= superName "java/lang/Object"))
nil
superName)
bases (->> (cons superName interfaces)
(remove nil?)
(map internal-name->class-symbol)
(map symbol)
(set)
(not-empty))]
(swap! result merge {:bases bases
:flags flags})))
(visitAnnotation [desc visible])
(visitSource [name debug])
(visitInnerClass [name outerName innerName access])
(visitField [access name desc signature value]
(swap! result update :members (fnil conj #{})
(Field. (symbol name)
(field-descriptor->class-symbol desc)
class-symbol
(parse-flags access :field)))
nil)
(visitMethod [access name desc signature exceptions]
(when-not (= name "<clinit>")
(let [constructor? (= name "<init>")]
(swap! result update :members (fnil conj #{})
(let [{:keys [parameter-types return-type]} (parse-method-descriptor desc)
flags (parse-flags access :method)]
(if constructor?
(Constructor. class-symbol
class-symbol
parameter-types
(vec (map internal-name->class-symbol exceptions))
flags)
(Method. (symbol name)
return-type
class-symbol
parameter-types
(vec (map internal-name->class-symbol exceptions))
flags))))))
nil)
(visitEnd [])
) 0)
@result))))

289 changes: 289 additions & 0 deletions src/clj/clojure/repl.clj
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,289 @@
; Copyright (c) Chris Houser, Dec 2008. All rights reserved.
; The use and distribution terms for this software are covered by the
; Common Public License 1.0 (http://opensource.org/licenses/cpl.php)
; which can be found in the file CPL.TXT at the root of this distribution.
; By using this software in any fashion, you are agreeing to be bound by
; the terms of this license.
; You must not remove this notice, or any other, from this software.

; Utilities meant to be used interactively at the REPL

(ns
^{:author "Chris Houser, Christophe Grand, Stephen Gilardi, Michel Salim"
:doc "Utilities meant to be used interactively at the REPL"}
clojure.repl
(:require [clojure.spec.alpha :as spec])
(:import (java.io LineNumberReader InputStreamReader PushbackReader)
(clojure.lang RT Reflector)))

(def ^:private special-doc-map
'{. {:url "java_interop#dot"
:forms [(.instanceMember instance args*)
(.instanceMember Classname args*)
(Classname/staticMethod args*)
Classname/staticField]
:doc "The instance member form works for both fields and methods.
They all expand into calls to the dot operator at macroexpansion time."}
def {:forms [(def symbol doc-string? init?)]
:doc "Creates and interns a global var with the name
of symbol in the current namespace (*ns*) or locates such a var if
it already exists. If init is supplied, it is evaluated, and the
root binding of the var is set to the resulting value. If init is
not supplied, the root binding of the var is unaffected."}
do {:forms [(do exprs*)]
:doc "Evaluates the expressions in order and returns the value of
the last. If no expressions are supplied, returns nil."}
if {:forms [(if test then else?)]
:doc "Evaluates test. If not the singular values nil or false,
evaluates and yields then, otherwise, evaluates and yields else. If
else is not supplied it defaults to nil."}
monitor-enter {:forms [(monitor-enter x)]
:doc "Synchronization primitive that should be avoided
in user code. Use the 'locking' macro."}
monitor-exit {:forms [(monitor-exit x)]
:doc "Synchronization primitive that should be avoided
in user code. Use the 'locking' macro."}
new {:forms [(Classname. args*) (new Classname args*)]
:url "java_interop#new"
:doc "The args, if any, are evaluated from left to right, and
passed to the constructor of the class named by Classname. The
constructed object is returned."}
quote {:forms [(quote form)]
:doc "Yields the unevaluated form."}
recur {:forms [(recur exprs*)]
:doc "Evaluates the exprs in order, then, in parallel, rebinds
the bindings of the recursion point to the values of the exprs.
Execution then jumps back to the recursion point, a loop or fn method."}
set! {:forms[(set! var-symbol expr)
(set! (. instance-expr instanceFieldName-symbol) expr)
(set! (. Classname-symbol staticFieldName-symbol) expr)]
:url "vars#set"
:doc "Used to set thread-local-bound vars, Java object instance
fields, and Java class static fields."}
throw {:forms [(throw expr)]
:doc "The expr is evaluated and thrown, therefore it should
yield an instance of some derivee of Throwable."}
try {:forms [(try expr* catch-clause* finally-clause?)]
:doc "catch-clause => (catch classname name expr*)
finally-clause => (finally expr*)
Catches and handles Java exceptions."}
var {:forms [(var symbol)]
:doc "The symbol must resolve to a var, and the Var object
itself (not its value) is returned. The reader macro #'x expands to (var x)."}})

(defn- special-doc [name-symbol]
(assoc (or (special-doc-map name-symbol) (meta (resolve name-symbol)))
:name name-symbol
:special-form true))

(defn- namespace-doc [nspace]
(assoc (meta nspace) :name (ns-name nspace)))

(defn- print-doc [{n :ns
nm :name
:keys [forms arglists special-form doc url macro spec]
:as m}]
(println "-------------------------")
(println (or spec (str (when n (str (ns-name n) "/")) nm)))
(when forms
(doseq [f forms]
(print " ")
(prn f)))
(when arglists
(prn arglists))
(cond
special-form
(println "Special Form")
macro
(println "Macro")
spec
(println "Spec"))
(when doc (println " " doc))
(when special-form
(if (contains? m :url)
(when url
(println (str "\n Please see http://clojure.org/" url)))
(println (str "\n Please see http://clojure.org/special_forms#" nm))))
(when n
(when-let [fnspec (spec/get-spec (symbol (str (ns-name n)) (name nm)))]
(println "Spec")
(doseq [role [:args :ret :fn]]
(when-let [spec (get fnspec role)]
(println " " (str (name role) ":") (spec/describe spec)))))))

(defn find-doc
"Prints documentation for any var whose documentation or name
contains a match for re-string-or-pattern"
{:added "1.0"}
[re-string-or-pattern]
(let [re (re-pattern re-string-or-pattern)
ms (concat (mapcat #(sort-by :name (map meta (vals (ns-interns %))))
(all-ns))
(map namespace-doc (all-ns))
(map special-doc (keys special-doc-map)))]
(doseq [m ms
:when (and (:doc m)
(or (re-find (re-matcher re (:doc m)))
(re-find (re-matcher re (str (:name m))))))]
(print-doc m))))

(defmacro doc
"Prints documentation for a var or special form given its name,
or for a spec if given a keyword"
{:added "1.0"}
[name]
(if-let [special-name ('{& fn catch try finally try} name)]
`(#'print-doc (#'special-doc '~special-name))
(cond
(special-doc-map name) `(#'print-doc (#'special-doc '~name))
(keyword? name) `(#'print-doc {:spec '~name :doc '~(spec/describe name)})
(find-ns name) `(#'print-doc (#'namespace-doc (find-ns '~name)))
(resolve name) `(#'print-doc (meta (var ~name))))))

;; ----------------------------------------------------------------------
;; Examine Clojure functions (Vars, really)

(defn source-fn
"Returns a string of the source code for the given symbol, if it can
find it. This requires that the symbol resolve to a Var defined in
a namespace for which the .clj is in the classpath. Returns nil if
it can't find the source. For most REPL usage, 'source' is more
convenient.
Example: (source-fn 'filter)"
[x]
(when-let [v (resolve x)]
(when-let [filepath (:file (meta v))]
(when-let [strm (.getResourceAsStream (RT/baseLoader) filepath)]
(with-open [rdr (LineNumberReader. (InputStreamReader. strm))]
(dotimes [_ (dec (:line (meta v)))] (.readLine rdr))
(let [text (StringBuilder.)
pbr (proxy [PushbackReader] [rdr]
(read [] (let [i (proxy-super read)]
(.append text (char i))
i)))
read-opts (if (.endsWith ^String filepath "cljc") {:read-cond :allow} {})]
(if (= :unknown *read-eval*)
(throw (IllegalStateException. "Unable to read source while *read-eval* is :unknown."))
(read read-opts (PushbackReader. pbr)))
(str text)))))))

(defmacro source
"Prints the source code for the given symbol, if it can find it.
This requires that the symbol resolve to a Var defined in a
namespace for which the .clj is in the classpath.
Example: (source filter)"
[n]
`(println (or (source-fn '~n) (str "Source not found"))))

(defn apropos
"Given a regular expression or stringable thing, return a seq of all
public definitions in all currently-loaded namespaces that match the
str-or-pattern."
[str-or-pattern]
(let [matches? (if (instance? java.util.regex.Pattern str-or-pattern)
#(re-find str-or-pattern (str %))
#(.contains (str %) (str str-or-pattern)))]
(sort (mapcat (fn [ns]
(let [ns-name (str ns)]
(map #(symbol ns-name (str %))
(filter matches? (keys (ns-publics ns))))))
(all-ns)))))

(defn dir-fn
"Returns a sorted seq of symbols naming public vars in
a namespace or namespace alias. Looks for aliases in *ns*"
[ns]
(sort (map first (ns-publics (the-ns (get (ns-aliases *ns*) ns ns))))))

(defmacro dir
"Prints a sorted directory of public vars in a namespace"
[nsname]
`(doseq [v# (dir-fn '~nsname)]
(println v#)))

(defn demunge
"Given a string representation of a fn class,
as in a stack trace element, returns a readable version."
{:added "1.3"}
[fn-name]
(clojure.lang.Compiler/demunge fn-name))

(defn root-cause
"Returns the initial cause of an exception or error by peeling off all of
its wrappers"
{:added "1.3"}
[^Throwable t]
(loop [cause t]
(if (and (instance? clojure.lang.Compiler$CompilerException cause)
(not= (.source ^clojure.lang.Compiler$CompilerException cause) "NO_SOURCE_FILE"))
cause
(if-let [cause (.getCause cause)]
(recur cause)
cause))))

(defn stack-element-str
"Returns a (possibly unmunged) string representation of a StackTraceElement"
{:added "1.3"}
[^StackTraceElement el]
(let [file (.getFileName el)
clojure-fn? (and file (or (.endsWith file ".clj")
(.endsWith file ".cljc")
(= file "NO_SOURCE_FILE")))]
(str (if clojure-fn?
(demunge (.getClassName el))
(str (.getClassName el) "." (.getMethodName el)))
" (" (.getFileName el) ":" (.getLineNumber el) ")")))

(defn pst
"Prints a stack trace of the exception, to the depth requested. If none supplied, uses the root cause of the
most recent repl exception (*e), and a depth of 12."
{:added "1.3"}
([] (pst 12))
([e-or-depth]
(if (instance? Throwable e-or-depth)
(pst e-or-depth 12)
(when-let [e *e]
(pst (root-cause e) e-or-depth))))
([^Throwable e depth]
(binding [*out* *err*]
(when (#{:read-source :macro-syntax-check :macroexpansion :compile-syntax-check :compilation}
(-> e ex-data :clojure.error/phase))
(println "Note: The following stack trace applies to the reader or compiler, your code was not executed."))
(println (str (-> e class .getSimpleName) " "
(.getMessage e)
(when-let [info (ex-data e)] (str " " (pr-str info)))))
(let [st (.getStackTrace e)
cause (.getCause e)]
(doseq [el (take depth
(remove #(#{"clojure.lang.RestFn" "clojure.lang.AFn"} (.getClassName %))
st))]
(println (str \tab (stack-element-str el))))
(when cause
(println "Caused by:")
(pst cause (min depth
(+ 2 (- (count (.getStackTrace cause))
(count st))))))))))

;; ----------------------------------------------------------------------
;; Handle Ctrl-C keystrokes

(defn thread-stopper
"Returns a function that takes one arg and uses that as an exception message
to stop the given thread. Defaults to the current thread"
([] (thread-stopper (Thread/currentThread)))
([thread] (fn [msg] (.stop thread (Error. msg)))))

(defn set-break-handler!
"Register INT signal handler. After calling this, Ctrl-C will cause
the given function f to be called with a single argument, the signal.
Uses thread-stopper if no function given."
([] (set-break-handler! (thread-stopper)))
([f]
(sun.misc.Signal/handle
(sun.misc.Signal. "INT")
(proxy [sun.misc.SignalHandler] []
(handle [signal]
(f (str "-- caught signal " signal)))))))
Loading