luciano/babashka
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

[#584, #1037] Uberscript in bb (#1115)

Browse source
This commit is contained in:
Michiel Borkent 2021-12-23 21:23:11 +01:00 committed by GitHub
parent 3a30a11c1f
commit 93fb4379ff
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
6 changed files with 358 additions and 220 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
sci

@ -1 +1 @@
Subproject commit 6ad100c7376bfac0f58ac12576caa805e2026d33
Subproject commit f29089b68e2e7d41e9491be0c1d7c48e1b9691e7

105
src/babashka/impl/uberscript.clj Normal file
View file

@ -0,0 +1,105 @@
(ns babashka.impl.uberscript
(:require [sci.core :as sci]))
(defn decompose-clause [clause]
(if (symbol? clause)
{:ns clause}
(when (seqable? clause)
(let [clause (if (= 'quote (first clause))
(second clause)
clause)
[ns & tail] clause]
(loop [parsed {:ns ns}
tail (seq tail)]
(if tail
(let [ftail (first tail)]
(case ftail
:as (recur (assoc parsed :as (second tail))
(nnext tail))
:refer
(let [refer (second tail)]
(if (seqable? refer)
(recur (assoc parsed :refer (second tail))
(nnext tail))
(recur parsed (nnext tail))))
;; default
(recur parsed
(nnext tail))))
parsed))))))
(defn recompose-clause [{:keys [:ns :as]}]
[ns :as as])
(defn process-ns
[_ctx ns]
(keep (fn [x]
(if (seqable? x)
(let [fx (first x)]
(when (identical? :require fx)
(let [decomposed (keep decompose-clause (rest x))
recomposed (map recompose-clause decomposed)]
(list* :require recomposed))))
x))
ns))
(defn keep-quoted [clauses]
(keep (fn [clause]
(when (and (seq? clause) (= 'quote (first clause)))
(second clause)))
clauses))
(defn process-require [_ctx req]
(let [quoted (keep-quoted (rest req))
decomposed (map decompose-clause quoted)]
(list* 'require (map (fn [clause]
(list 'quote (recompose-clause clause)))
decomposed))))
(defn process-in-ns [_ctx req]
(let [quoted (keep-quoted (rest req))
quoted (map (fn [ns]
(list 'quote ns))
quoted)]
(when (clojure.core/seq quoted)
(list* 'in-ns quoted))))
(defn loc [rdr]
(str (when-let [f @sci/file]
(str f ":"))
(sci/get-line-number rdr)
":"
(sci/get-column-number rdr)))
(defn uberscript [{:keys [ctx expressions]}]
(let [ctx (assoc ctx :reload-all true)]
(sci/binding [sci/file @sci/file]
(doseq [expr expressions]
(let [rdr (sci/reader expr)]
(loop []
(let [next-val
(try (sci/parse-next ctx rdr)
;; swallow reader error
(catch Exception _e
(binding [*out* *err*]
(println "[babashka]" "Ignoring read error while assembling uberscript near"
(loc rdr)))))]
;; (.println System/err (pr-str next-val))
(when-not (= ::sci/eof next-val)
(if (seq? next-val)
(let [fst (first next-val)
expr (cond (= 'ns fst)
(process-ns ctx next-val)
(= 'require fst)
(process-require ctx next-val)
(= 'in-ns fst)
(process-in-ns ctx next-val))]
(when expr
(try
(sci/eval-form ctx expr)
;; swallow exception and continue
(catch Exception _e
(binding [*out* *err*]
(println "[babashka]" "Ignoring expression while assembling uberscript:"
expr "near" (loc rdr))))))
(recur))
(recur))))))))))

429
src/babashka/main.clj
View file

@ -41,6 +41,7 @@
[babashka.impl.tasks :as tasks :refer [tasks-namespace]]
[babashka.impl.test :as t]
[babashka.impl.tools.cli :refer [tools-cli-namespace]]
[babashka.impl.uberscript :as uberscript]
[babashka.nrepl.server :as nrepl-server]
[babashka.wait :refer [wait-namespace]]
[clojure.edn :as edn]
@ -272,8 +273,8 @@ Use bb run --help to show this help output.
(let [f (io/file file)]
(if (.exists f)
(as-> (slurp file) x
;; remove shebang
(str/replace x #"^#!.*" ""))
;; remove shebang
(str/replace x #"^#!.*" ""))
(throw (Exception. (str "File does not exist: " file))))))
(defn load-file* [f]
@ -727,9 +728,13 @@ Use bb run --help to show this help output.
(or (contains? namespaces namespace)
(contains? sci-namespaces/namespaces namespace)))
""
(let [res (cp/source-for-namespace loader namespace nil)]
(when uberscript (swap! uberscript-sources conj (:source res)))
res)))
(when-let [res (cp/source-for-namespace loader namespace nil)]
(if uberscript
(do (swap! uberscript-sources conj (:source res))
(uberscript/uberscript {:ctx @common/ctx
:expressions [(:source res)]})
{})
res))))
(case namespace
clojure.spec.alpha
(binding [*out* *err*]
@ -738,224 +743,228 @@ Use bb run --help to show this help output.
(binding [*out* *err*]
(println "[babashka] WARNING: clojure.core.specs.alpha is removed from the classpath, unless you explicitly add the dependency."))
nil)))
main (if (and jar (not main))
(when-let [res (cp/getResource
(cp/loader jar)
["META-INF/MANIFEST.MF"] {:url? true})]
(cp/main-ns res))
main)
;; TODO: pull more of these values to compile time
opts {:aliases aliases
:namespaces (-> namespaces
(assoc 'clojure.core
(assoc core-extras
'load-file (sci-namespaces/core-var 'load-file load-file*))))
:env env
:features #{:bb :clj}
:classes classes/class-map
:imports classes/imports
:load-fn load-fn
:uberscript uberscript
;; :readers core/data-readers
:reify-fn reify-fn
:proxy-fn proxy-fn}
opts (addons/future opts)
sci-ctx (sci/init opts)
_ (vreset! common/ctx sci-ctx)
preloads (some-> (System/getenv "BABASHKA_PRELOADS") (str/trim))
[expressions exit-code]
(cond expressions [expressions nil]
main
(let [sym (symbol main)
ns? (namespace sym)
ns (or ns? sym)
var-name (if ns?
(name sym)
"-main")]
[[(format "(ns user (:require [%1$s])) (apply %1$s/%2$s *command-line-args*)"
ns var-name)] nil])
run (if (:run-help cli-opts)
[(print-run-help) 0]
(do
(System/setProperty "babashka.task" (str run))
(tasks/assemble-task run
(:parallel-tasks cli-opts))))
file (try [[(read-file file)] nil]
(catch Exception e
(error-handler e {:expression expressions
:debug debug
:preloads preloads
:init init
:loader (:loader @cp/cp-state)}))))
expression (str/join " " expressions) ;; this might mess with the locations...
exit-code
;; handle preloads
(if exit-code exit-code
(do (when preloads
(sci/binding [sci/file "<preloads>"]
(try
(sci/eval-string* sci-ctx preloads)
(catch Throwable e
(error-handler e {:expression expression
:debug debug
:preloads preloads
:init init
:loader (:loader @cp/cp-state)})))))
nil))
exit-code
;; handle --init
(if exit-code exit-code
(do (when init
(try
(load-file* init)
(catch Throwable e
(error-handler e {:expression expression
:debug debug
:preloads preloads
:init init
:loader (:loader @cp/cp-state)}))))
nil))
;; socket REPL is start asynchronously. when no other args are
;; provided, a normal REPL will be started as well, which causes the
;; process to wait until SIGINT
_ (when socket-repl (start-socket-repl! socket-repl sci-ctx))
exit-code
(or exit-code
(second
(cond version-opt
[(print-version) 0]
help (print-help sci-ctx command-line-args)
doc (print-doc sci-ctx command-line-args)
describe?
[(print-describe) 0]
repl [(repl/start-repl! sci-ctx) 0]
nrepl [(start-nrepl! nrepl sci-ctx) 0]
uberjar [nil 0]
list-tasks [(tasks/list-tasks sci-ctx) 0]
print-deps [(print-deps/print-deps (:print-deps-format cli-opts)) 0]
expressions
(sci/binding [sci/file abs-path]
(try
main (if (and jar (not main))
(when-let [res (cp/getResource
(cp/loader jar)
["META-INF/MANIFEST.MF"] {:url? true})]
(cp/main-ns res))
main)
;; TODO: pull more of these values to compile time
opts {:aliases aliases
:namespaces (-> namespaces
(assoc 'clojure.core
(assoc core-extras
'load-file (sci-namespaces/core-var 'load-file load-file*))))
:env env
:features #{:bb :clj}
:classes classes/class-map
:imports classes/imports
:load-fn load-fn
:uberscript uberscript
;; :readers core/data-readers
:reify-fn reify-fn
:proxy-fn proxy-fn}
opts (addons/future opts)
sci-ctx (sci/init opts)
_ (vreset! common/ctx sci-ctx)
preloads (some-> (System/getenv "BABASHKA_PRELOADS") (str/trim))
[expressions exit-code]
(cond expressions [expressions nil]
main
(let [sym (symbol main)
ns? (namespace sym)
ns (or ns? sym)
var-name (if ns?
(name sym)
"-main")]
[[(format "(ns user (:require [%1$s])) (apply %1$s/%2$s *command-line-args*)"
ns var-name)] nil])
run (if (:run-help cli-opts)
[(print-run-help) 0]
(do
(System/setProperty "babashka.task" (str run))
(tasks/assemble-task run
(:parallel-tasks cli-opts))))
file (try [[(read-file file)] nil]
(catch Exception e
(error-handler e {:expression expressions
:debug debug
:preloads preloads
:init init
:loader (:loader @cp/cp-state)}))))
expression (str/join " " expressions) ;; this might mess with the locations...
exit-code
;; handle preloads
(if exit-code exit-code
(do (when preloads
(sci/binding [sci/file "<preloads>"]
(try
(sci/eval-string* sci-ctx preloads)
(catch Throwable e
(error-handler e {:expression expression
:debug debug
:preloads preloads
:init init
:loader (:loader @cp/cp-state)})))))
nil))
exit-code
;; handle --init
(if exit-code exit-code
(do (when init
(try
(load-file* init)
(catch Throwable e
(error-handler e {:expression expression
:debug debug
:preloads preloads
:init init
:loader (:loader @cp/cp-state)}))))
nil))
;; socket REPL is start asynchronously. when no other args are
;; provided, a normal REPL will be started as well, which causes the
;; process to wait until SIGINT
_ (when socket-repl (start-socket-repl! socket-repl sci-ctx))
exit-code
(or exit-code
(second
(cond version-opt
[(print-version) 0]
help (print-help sci-ctx command-line-args)
doc (print-doc sci-ctx command-line-args)
describe?
[(print-describe) 0]
repl [(repl/start-repl! sci-ctx) 0]
nrepl [(start-nrepl! nrepl sci-ctx) 0]
uberjar [nil 0]
list-tasks [(tasks/list-tasks sci-ctx) 0]
print-deps [(print-deps/print-deps (:print-deps-format cli-opts)) 0]
uberscript
[nil (do (uberscript/uberscript {:ctx sci-ctx
:expressions expressions})
0)]
expressions
;; execute code
(sci/binding [sci/file abs-path]
(try
; when evaluating expression(s), add in repl-requires so things like
; pprint and dir are available
(sci/eval-form sci-ctx `(apply require (quote ~clojure-main/repl-requires)))
(loop []
(let [in (read-next *in*)]
(if (identical? ::EOF in)
[nil 0] ;; done streaming
(let [res [(let [res
(sci/binding [sci/file (or @sci/file "<expr>")
input-var in
core/command-line-args command-line-args]
(sci/eval-string* sci-ctx expression))]
;; return value printing
(when (and (some? res)
(or (not run)
(:prn cli-opts)))
(if-let [pr-f (cond shell-out println
edn-out prn)]
(if (sequential? res)
(doseq [l res
:while (not (pipe-signal-received?))]
(pr-f l))
(pr-f res))
(prn res)))) 0]]
(if stream?
(recur)
res)))))
(catch Throwable e
(error-handler e {:expression expression
:debug debug
:preloads preloads
:loader (:loader @cp/cp-state)}))))
clojure [nil (if-let [proc (bdeps/clojure command-line-args)]
(-> @proc :exit)
0)]
uberscript [nil 0]
:else [(repl/start-repl! sci-ctx) 0]))
1)]
(flush)
(when uberscript
(let [uberscript-out uberscript]
(spit uberscript-out "") ;; reset file
(doseq [s (distinct @uberscript-sources)]
(spit uberscript-out s :append true))
(spit uberscript-out preloads :append true)
(spit uberscript-out expression :append true)))
(when uberjar
(if-let [cp (cp/get-classpath)]
(uberjar/run {:dest uberjar
:jar :uber
:classpath cp
:main-class main
:verbose debug})
(throw (Exception. "The uberjar task needs a classpath."))))
exit-code))))
(sci/eval-form sci-ctx `(apply require (quote ~clojure-main/repl-requires)))
(loop []
(let [in (read-next *in*)]
(if (identical? ::EOF in)
[nil 0] ;; done streaming
(let [res [(let [res
(sci/binding [sci/file (or @sci/file "<expr>")
input-var in
core/command-line-args command-line-args]
(sci/eval-string* sci-ctx expression))]
;; return value printing
(when (and (some? res)
(or (not run)
(:prn cli-opts)))
(if-let [pr-f (cond shell-out println
edn-out prn)]
(if (sequential? res)
(doseq [l res
:while (not (pipe-signal-received?))]
(pr-f l))
(pr-f res))
(prn res)))) 0]]
(if stream?
(recur)
res)))))
(catch Throwable e
(error-handler e {:expression expression
:debug debug
:preloads preloads
:loader (:loader @cp/cp-state)}))))
clojure [nil (if-let [proc (bdeps/clojure command-line-args)]
(-> @proc :exit)
0)]
:else [(repl/start-repl! sci-ctx) 0]))
1)]
(flush)
(when uberscript
(let [uberscript-out uberscript]
(spit uberscript-out "") ;; reset file
(doseq [s (distinct @uberscript-sources)]
(spit uberscript-out s :append true))
(spit uberscript-out preloads :append true)
(spit uberscript-out expression :append true)))
(when uberjar
(if-let [cp (cp/get-classpath)]
(uberjar/run {:dest uberjar
:jar :uber
:classpath cp
:main-class main
:verbose debug})
(throw (Exception. "The uberjar task needs a classpath."))))
exit-code))))
(defn satisfies-min-version? [min-version]
(let [[major-current minor-current patch-current] version-data
[major-min minor-min patch-min] (parse-version min-version)]
(or (> major-current major-min)
(and (= major-current major-min)
(or (> minor-current minor-min)
(and (= minor-current minor-min)
(>= patch-current patch-min)))))))
(let [[major-current minor-current patch-current] version-data
[major-min minor-min patch-min] (parse-version min-version)]
(or (> major-current major-min)
(and (= major-current major-min)
(or (> minor-current minor-min)
(and (= minor-current minor-min)
(>= patch-current patch-min)))))))
(defn main [& args]
(let [bb-edn-file (or (System/getenv "BABASHKA_EDN")
"bb.edn")
bb-edn (or (when (fs/exists? bb-edn-file)
(let [raw-string (slurp bb-edn-file)
edn (edn/read-string raw-string)
edn (assoc edn :raw raw-string)]
(vreset! common/bb-edn edn)))
;; tests may have modified bb-edn
@common/bb-edn)
min-bb-version (:min-bb-version bb-edn)]
(when min-bb-version
(when-not (satisfies-min-version? min-bb-version)
(binding [*out* *err*]
(println (str "WARNING: this project requires babashka "
min-bb-version " or newer, but you have: " version))))))
(let [opts (parse-opts args)]
(exec opts)))
(let [bb-edn-file (or (System/getenv "BABASHKA_EDN")
"bb.edn")
bb-edn (or (when (fs/exists? bb-edn-file)
(let [raw-string (slurp bb-edn-file)
edn (edn/read-string raw-string)
edn (assoc edn :raw raw-string)]
(vreset! common/bb-edn edn)))
;; tests may have modified bb-edn
@common/bb-edn)
min-bb-version (:min-bb-version bb-edn)]
(when min-bb-version
(when-not (satisfies-min-version? min-bb-version)
(binding [*out* *err*]
(println (str "WARNING: this project requires babashka "
min-bb-version " or newer, but you have: " version))))))
(let [opts (parse-opts args)]
(exec opts)))
(def musl?
"Captured at compile time, to know if we are running inside a
"Captured at compile time, to know if we are running inside a
statically compiled executable with musl."
(and (= "true" (System/getenv "BABASHKA_STATIC"))
(= "true" (System/getenv "BABASHKA_MUSL"))))
(and (= "true" (System/getenv "BABASHKA_STATIC"))
(= "true" (System/getenv "BABASHKA_MUSL"))))
(defmacro run [args]
(if musl?
;; When running in musl-compiled static executable we lift execution of bb
;; inside a thread, so we have a larger than default stack size, set by an
;; argument to the linker. See https://github.com/oracle/graal/issues/3398
`(let [v# (volatile! nil)
f# (fn []
(vreset! v# (apply main ~args)))]
(doto (Thread. nil f# "main")
(.start)
(.join))
@v#)
`(apply main ~args)))
(if musl?
;; When running in musl-compiled static executable we lift execution of bb
;; inside a thread, so we have a larger than default stack size, set by an
;; argument to the linker. See https://github.com/oracle/graal/issues/3398
`(let [v# (volatile! nil)
f# (fn []
(vreset! v# (apply main ~args)))]
(doto (Thread. nil f# "main")
(.start)
(.join))
@v#)
`(apply main ~args)))
(defn -main
[& args]
(handle-pipe!)
(handle-sigint!)
(if-let [dev-opts (System/getenv "BABASHKA_DEV")]
(let [{:keys [:n]} (if (= "true" dev-opts) {:n 1}
(edn/read-string dev-opts))
last-iteration (dec n)]
(dotimes [i n]
(if (< i last-iteration)
(with-out-str (apply main args))
(do (run args)
(binding [*out* *err*]
(println "ran" n "times"))))))
(let [exit-code (run args)]
(System/exit exit-code))))
[& args]
(handle-pipe!)
(handle-sigint!)
(if-let [dev-opts (System/getenv "BABASHKA_DEV")]
(let [{:keys [:n]} (if (= "true" dev-opts) {:n 1}
(edn/read-string dev-opts))
last-iteration (dec n)]
(dotimes [i n]
(if (< i last-iteration)
(with-out-str (apply main args))
(do (run args)
(binding [*out* *err*]
(println "ran" n "times"))))))
(let [exit-code (run args)]
(System/exit exit-code))))
;;;; Scratch

15
test-resources/babashka/uberscript/src/my/impl1.clj
View file

@ -1,5 +1,18 @@
(ns my.impl1
(:require [clojure.string]))
(:require [babashka.pods :as pods]
[clojure.string :as str]))
;; uberscript parser can parse and skip this
(prn ::str/foo)
str/join
(alias 'a 'clojure.string)
::a/foo ;; no error either
(pods/load-pod 'clj-kondo/clj-kondo "2021.10.19")
(require '[pod.borkdude.clj-kondo :as clj-kondo])
(prn (some? clj-kondo/run!))
(defn impl-fn
"identity"

4
test/babashka/test_utils.clj
View file

@ -75,7 +75,9 @@
(with-in-str input-or-opts (apply main/main args))
(apply main/main args)))]
(if (zero? res)
(normalize (str os))
(do
(println (str es)) ;; flush stderr
(normalize (str os)))
(do
(println (str os))
(throw (ex-info (str es)

23
test/babashka/uberscript_test.clj
View file

@ -1,16 +1,25 @@
(ns babashka.uberscript-test
(:require
[babashka.test-utils :as tu]
[clojure.test :as t :refer [deftest is testing]]))
[clojure.test :as t :refer [deftest is]]))
(deftest uberscript-test
(deftest basic-test
(let [tmp-file (java.io.File/createTempFile "uberscript" ".clj")]
(.deleteOnExit tmp-file)
(is (empty? (tu/bb nil "--classpath" "test-resources/babashka/src_for_classpath_test" "uberscript" (.getPath tmp-file) "-m" "my.main" )))
(is (empty? (tu/bb nil "--classpath" "test-resources/babashka/src_for_classpath_test" "uberscript" (.getPath tmp-file) "-m" "my.main")))
(is (= "(\"1\" \"2\" \"3\" \"4\")\n"
(tu/bb nil "--file" (.getPath tmp-file) "1" "2" "3" "4")))
(testing "order of namespaces is correct"
(tu/bb nil "--classpath" "test-resources/babashka/uberscript/src" "uberscript" (.getPath tmp-file) "-m" "my.main")
(is (= "(\"1\" \"2\" \"3\" \"4\")\n"
(tu/bb nil "--file" (.getPath tmp-file) "1" "2" "3" "4")))))
(when-not (= "aarch64" (System/getenv "BABASHKA_ARCH"))
(deftest advanced-test
(let [tmp-file (java.io.File/createTempFile "uberscript" ".clj")]
(.deleteOnExit tmp-file)
;; we test:
;; order of namespaces
;; reader error for ::a/foo is swallowed
;; pod namespaces can be loaded without a problem
;; resulting program can be executed
(is (empty? (tu/bb nil "--classpath" "test-resources/babashka/uberscript/src" "uberscript" (.getPath tmp-file) "-m" "my.main")))
(is (= ":clojure.string/foo\ntrue\n(\"1\" \"2\" \"3\" \"4\")\n"
(tu/bb nil "--file" (.getPath tmp-file) "1" "2" "3" "4"))))))