mirror of
https://github.com/janet-lang/janet
synced 2024-11-20 07:34:49 +00:00
Use a single janet file for hooks..
This commit is contained in:
parent
4a0f67f3bd
commit
42bd27c24b
@ -2677,8 +2677,8 @@
|
|||||||
(defn eval
|
(defn eval
|
||||||
``Evaluates a form in the current environment. If more control over the
|
``Evaluates a form in the current environment. If more control over the
|
||||||
environment is needed, use `run-context`.``
|
environment is needed, use `run-context`.``
|
||||||
[form]
|
[form &opt env]
|
||||||
(def res (compile form nil :eval))
|
(def res (compile form env :eval))
|
||||||
(if (= (type res) :function)
|
(if (= (type res) :function)
|
||||||
(res)
|
(res)
|
||||||
(error (get res :error))))
|
(error (get res :error))))
|
||||||
@ -2717,9 +2717,9 @@
|
|||||||
(defn eval-string
|
(defn eval-string
|
||||||
``Evaluates a string in the current environment. If more control over the
|
``Evaluates a string in the current environment. If more control over the
|
||||||
environment is needed, use `run-context`.``
|
environment is needed, use `run-context`.``
|
||||||
[str]
|
[str &opt env]
|
||||||
(var ret nil)
|
(var ret nil)
|
||||||
(each x (parse-all str) (set ret (eval x)))
|
(each x (parse-all str) (set ret (eval x env)))
|
||||||
ret)
|
ret)
|
||||||
|
|
||||||
(def load-image-dict
|
(def load-image-dict
|
||||||
@ -2768,8 +2768,8 @@
|
|||||||
(defn- check-project-relative [x] (if (string/has-prefix? "/" x) x))
|
(defn- check-project-relative [x] (if (string/has-prefix? "/" x) x))
|
||||||
|
|
||||||
(defdyn *module/cache* "Dynamic binding for overriding `module/cache`")
|
(defdyn *module/cache* "Dynamic binding for overriding `module/cache`")
|
||||||
(defdyn *module/paths* "Dynamic binding for overriding `module/cache`")
|
(defdyn *module/paths* "Dynamic binding for overriding `module/paths`")
|
||||||
(defdyn *module/loading* "Dynamic binding for overriding `module/cache`")
|
(defdyn *module/loading* "Dynamic binding for overriding `module/loading`")
|
||||||
(defdyn *module/loaders* "Dynamic binding for overriding `module/loaders`")
|
(defdyn *module/loaders* "Dynamic binding for overriding `module/loaders`")
|
||||||
|
|
||||||
(def module/cache
|
(def module/cache
|
||||||
@ -2947,6 +2947,32 @@
|
|||||||
|
|
||||||
(set debugger-on-status-var debugger-on-status)
|
(set debugger-on-status-var debugger-on-status)
|
||||||
|
|
||||||
|
(defn- env-walk
|
||||||
|
[pred &opt env local]
|
||||||
|
(default env (fiber/getenv (fiber/current)))
|
||||||
|
(def envs @[])
|
||||||
|
(do (var e env) (while e (array/push envs e) (set e (table/getproto e)) (if local (break))))
|
||||||
|
(def ret-set @{})
|
||||||
|
(loop [envi :in envs
|
||||||
|
k :keys envi
|
||||||
|
:when (pred k)]
|
||||||
|
(put ret-set k true))
|
||||||
|
(sort (keys ret-set)))
|
||||||
|
|
||||||
|
(defn all-bindings
|
||||||
|
``Get all symbols available in an environment. Defaults to the current
|
||||||
|
fiber's environment. If `local` is truthy, will not show inherited bindings
|
||||||
|
(from prototype tables).``
|
||||||
|
[&opt env local]
|
||||||
|
(env-walk symbol? env local))
|
||||||
|
|
||||||
|
(defn all-dynamics
|
||||||
|
``Get all dynamic bindings in an environment. Defaults to the current
|
||||||
|
fiber's environment. If `local` is truthy, will not show inherited bindings
|
||||||
|
(from prototype tables).``
|
||||||
|
[&opt env local]
|
||||||
|
(env-walk keyword? env local))
|
||||||
|
|
||||||
(defn dofile
|
(defn dofile
|
||||||
``Evaluate a file, file path, or stream and return the resulting environment. :env, :expander,
|
``Evaluate a file, file path, or stream and return the resulting environment. :env, :expander,
|
||||||
:source, :evaluator, :read, and :parser are passed through to the underlying
|
:source, :evaluator, :read, and :parser are passed through to the underlying
|
||||||
@ -3110,32 +3136,6 @@
|
|||||||
###
|
###
|
||||||
###
|
###
|
||||||
|
|
||||||
(defn- env-walk
|
|
||||||
[pred &opt env local]
|
|
||||||
(default env (fiber/getenv (fiber/current)))
|
|
||||||
(def envs @[])
|
|
||||||
(do (var e env) (while e (array/push envs e) (set e (table/getproto e)) (if local (break))))
|
|
||||||
(def ret-set @{})
|
|
||||||
(loop [envi :in envs
|
|
||||||
k :keys envi
|
|
||||||
:when (pred k)]
|
|
||||||
(put ret-set k true))
|
|
||||||
(sort (keys ret-set)))
|
|
||||||
|
|
||||||
(defn all-bindings
|
|
||||||
``Get all symbols available in an environment. Defaults to the current
|
|
||||||
fiber's environment. If `local` is truthy, will not show inherited bindings
|
|
||||||
(from prototype tables).``
|
|
||||||
[&opt env local]
|
|
||||||
(env-walk symbol? env local))
|
|
||||||
|
|
||||||
(defn all-dynamics
|
|
||||||
``Get all dynamic bindings in an environment. Defaults to the current
|
|
||||||
fiber's environment. If `local` is truthy, will not show inherited bindings
|
|
||||||
(from prototype tables).``
|
|
||||||
[&opt env local]
|
|
||||||
(env-walk keyword? env local))
|
|
||||||
|
|
||||||
(defdyn *doc-width*
|
(defdyn *doc-width*
|
||||||
"Width in columns to print documentation printed with `doc-format`.")
|
"Width in columns to print documentation printed with `doc-format`.")
|
||||||
|
|
||||||
@ -3967,15 +3967,13 @@
|
|||||||
|
|
||||||
(compwhen (dyn 'os/stat)
|
(compwhen (dyn 'os/stat)
|
||||||
|
|
||||||
(defdyn *bundle-manifest* "Current manifest table of an installed package. Bound when executing hooks.")
|
|
||||||
|
|
||||||
(defn- bundle-dir
|
(defn- bundle-dir
|
||||||
[&opt bundle-name]
|
[&opt bundle-name]
|
||||||
(string (dyn *syspath*) "/.bundles/" bundle-name))
|
(string (os/realpath (dyn *syspath*)) "/_bundles/" bundle-name))
|
||||||
|
|
||||||
(defn- bundle-file
|
(defn- bundle-file
|
||||||
[bundle-name filename]
|
[bundle-name filename]
|
||||||
(string (dyn *syspath*) "/.bundles/" bundle-name "/" filename))
|
(string (os/realpath (dyn *syspath*)) "/_bundles/" bundle-name "/" filename))
|
||||||
|
|
||||||
(defn- get-manifest-filename
|
(defn- get-manifest-filename
|
||||||
[bundle-name]
|
[bundle-name]
|
||||||
@ -3985,9 +3983,7 @@
|
|||||||
[]
|
[]
|
||||||
(os/mkdir (bundle-dir)))
|
(os/mkdir (bundle-dir)))
|
||||||
|
|
||||||
(defn- get-files []
|
(defn- get-files [manifest]
|
||||||
(def manifest (dyn *bundle-manifest*))
|
|
||||||
(assert manifest "nothing bound to (dyn *bundle-manifest*)")
|
|
||||||
(def files (get manifest :files @[]))
|
(def files (get manifest :files @[]))
|
||||||
(put manifest :files files)
|
(put manifest :files files)
|
||||||
files)
|
files)
|
||||||
@ -4013,17 +4009,18 @@
|
|||||||
(file/write fto b)
|
(file/write fto b)
|
||||||
(buffer/clear b)))))
|
(buffer/clear b)))))
|
||||||
|
|
||||||
(defn- copy-hooks
|
(defn- copyrf
|
||||||
[hooks-src bundle-name]
|
[from to]
|
||||||
(when (os/stat hooks-src :mode)
|
(case (os/stat from :mode)
|
||||||
(each hook (os/dir hooks-src)
|
:file (copyfile from to)
|
||||||
(when (string/has-suffix? ".janet" hook)
|
:directory (do
|
||||||
(def hookpath (string hooks-src "/" hook))
|
(os/mkdir to)
|
||||||
(copyfile hookpath (bundle-file bundle-name hook))))))
|
(each y (os/dir from)
|
||||||
|
(copyrf (string from "/" y) (string to "/" y)))))
|
||||||
|
nil)
|
||||||
|
|
||||||
(defn- sync-manifest
|
(defn- sync-manifest
|
||||||
[&opt manifest]
|
[manifest]
|
||||||
(default manifest (dyn *bundle-manifest*))
|
|
||||||
(def bn (get manifest :bundle-name))
|
(def bn (get manifest :bundle-name))
|
||||||
(def manifest-name (get-manifest-filename bn))
|
(def manifest-name (get-manifest-filename bn))
|
||||||
(spit manifest-name (string/format "%j\n" manifest)))
|
(spit manifest-name (string/format "%j\n" manifest)))
|
||||||
@ -4035,32 +4032,31 @@
|
|||||||
(assert (fexists name) (string "no bundle " bundle-name " found"))
|
(assert (fexists name) (string "no bundle " bundle-name " found"))
|
||||||
(parse (slurp name)))
|
(parse (slurp name)))
|
||||||
|
|
||||||
(defn- do-hook
|
(defn- get-bundle-module
|
||||||
[bundle-name hook from-source]
|
[bundle-name]
|
||||||
(bundle/manifest bundle-name) # assert good bundle-name
|
|
||||||
(def filename (bundle-file bundle-name hook))
|
|
||||||
(when (os/stat filename :mode)
|
|
||||||
(def dir (os/cwd))
|
|
||||||
(def real-syspath (os/realpath (dyn *syspath*))) # if syspath is a relative path
|
|
||||||
(def env (make-env))
|
|
||||||
(def manifest-name (get-manifest-filename bundle-name))
|
|
||||||
(def manifest (bundle/manifest bundle-name))
|
(def manifest (bundle/manifest bundle-name))
|
||||||
(def srcdir (get manifest :local-source))
|
(def dir (os/cwd))
|
||||||
(def filename-real (os/realpath filename))
|
(os/cd (get manifest :local-source "."))
|
||||||
(put env *bundle-manifest* manifest)
|
|
||||||
(merge-into env manifest)
|
|
||||||
(put env *syspath* real-syspath)
|
|
||||||
# After install, srcdir does not always exist
|
|
||||||
(when (and from-source (os/stat srcdir :mode)) (os/cd srcdir))
|
|
||||||
(defer (os/cd dir)
|
(defer (os/cd dir)
|
||||||
(print "running " filename-real " for bundle " bundle-name)
|
# like :fresh true, but recursive
|
||||||
(dofile filename-real :env env)
|
(with-dyns [*module/cache* @{}
|
||||||
(sync-manifest manifest))))
|
*module/loading* @{}]
|
||||||
|
(require (string "_bundles/" bundle-name)))))
|
||||||
|
|
||||||
|
(defn- do-hook
|
||||||
|
[module bundle-name hook & args]
|
||||||
|
(def hookf (module/value module (symbol hook)))
|
||||||
|
(unless hookf (break))
|
||||||
|
(def manifest (bundle/manifest bundle-name))
|
||||||
|
(def dir (os/cwd))
|
||||||
|
(os/cd (get manifest :local-source "."))
|
||||||
|
(defer (os/cd dir)
|
||||||
|
(print "running hook " hook " for bundle " bundle-name)
|
||||||
|
(hookf ;args)))
|
||||||
|
|
||||||
(defn bundle/uninstall
|
(defn bundle/uninstall
|
||||||
"Remove a bundle from the current syspath"
|
"Remove a bundle from the current syspath"
|
||||||
[bundle-name]
|
[bundle-name]
|
||||||
(do-hook bundle-name "uninstall.janet" false)
|
|
||||||
(def man (bundle/manifest bundle-name))
|
(def man (bundle/manifest bundle-name))
|
||||||
(def files (get man :files []))
|
(def files (get man :files []))
|
||||||
(each file (reverse files)
|
(each file (reverse files)
|
||||||
@ -4082,53 +4078,50 @@
|
|||||||
"bundle is already installed")
|
"bundle is already installed")
|
||||||
(prime-bundle-paths)
|
(prime-bundle-paths)
|
||||||
(os/mkdir (bundle-dir bundle-name))
|
(os/mkdir (bundle-dir bundle-name))
|
||||||
(def src-hooks (string path "/hooks/"))
|
# Copy some files into the new location unconditionally
|
||||||
(copy-hooks src-hooks bundle-name)
|
(def implicit-sources (string path "/bundle"))
|
||||||
(def man @{:bundle-name bundle-name :local-source path :config config})
|
(when (= :directory (os/stat implicit-sources :mode))
|
||||||
|
(copyrf implicit-sources (bundle-dir bundle-name)))
|
||||||
|
(def man @{:bundle-name bundle-name :local-source path :files @[]})
|
||||||
(merge-into man config)
|
(merge-into man config)
|
||||||
(sync-manifest man)
|
(sync-manifest man)
|
||||||
(edefer (do (print "installation error, uninstalling") (bundle/uninstall bundle-name))
|
(edefer (do (print "installation error, uninstalling") (bundle/uninstall bundle-name))
|
||||||
(do-hook bundle-name "deps.janet" true)
|
(def module (get-bundle-module bundle-name))
|
||||||
(do-hook bundle-name "build.janet" true)
|
(do-hook module bundle-name :build man)
|
||||||
(do-hook bundle-name "install.janet" true))
|
(do-hook module bundle-name :install man)
|
||||||
|
(if (empty? (get man :files)) (print "no files installed, is this a valid bundle?"))
|
||||||
|
(sync-manifest man))
|
||||||
(print "installed " bundle-name)
|
(print "installed " bundle-name)
|
||||||
bundle-name)
|
bundle-name)
|
||||||
|
|
||||||
(defn bundle/pack
|
(defn bundle/pack
|
||||||
"Take an installed bundle and create a bundle source directory that can be used to
|
"Take an installed bundle and create a bundle source directory that can be used to
|
||||||
reinstall this bundle on a compatible system. This is used to create backups for installed
|
reinstall the bundle on a compatible system. This is used to create backups for installed
|
||||||
bundles without rebuilding."
|
bundles without rebuilding, or make a prebuilt bundle for other systems."
|
||||||
[bundle-name dest-dir &opt is-backup]
|
[bundle-name dest-dir &opt is-backup]
|
||||||
|
(var i 0)
|
||||||
(def man (bundle/manifest bundle-name))
|
(def man (bundle/manifest bundle-name))
|
||||||
(def files (get man :files @[]))
|
(def files (get man :files @[]))
|
||||||
(assert (os/mkdir dest-dir) (string "could not create directory " dest-dir " (or it already exists)"))
|
(assert (os/mkdir dest-dir) (string "could not create directory " dest-dir " (or it already exists)"))
|
||||||
(def hooks-dir (string dest-dir "/hooks"))
|
(os/mkdir (string dest-dir "/bundle"))
|
||||||
(def old-hooks-dir (string dest-dir "/old-hooks"))
|
(def install-hook (string dest-dir "/bundle/init.janet"))
|
||||||
(def install-hook (string dest-dir "/hooks/install.janet"))
|
|
||||||
(edefer (rmrf dest-dir) # don't leave garbage on failure
|
(edefer (rmrf dest-dir) # don't leave garbage on failure
|
||||||
(var i 0)
|
|
||||||
(def install-source @[])
|
(def install-source @[])
|
||||||
(def syspath (os/realpath (dyn *syspath*)))
|
(def syspath (os/realpath (dyn *syspath*)))
|
||||||
(os/mkdir hooks-dir)
|
(when is-backup (copyrf (bundle-dir bundle-name) (string dest-dir "/old-bundle")))
|
||||||
(when is-backup
|
|
||||||
(os/mkdir old-hooks-dir)
|
|
||||||
(spit (string dest-dir "/old-manifest.jdn") (string/format "%j\n" man))
|
|
||||||
(def current-hooks (bundle-dir bundle-name))
|
|
||||||
(each file (os/dir current-hooks)
|
|
||||||
(def from (string current-hooks "/" file))
|
|
||||||
(copyfile from (string old-hooks-dir "/" file))))
|
|
||||||
(each file files
|
(each file files
|
||||||
(def {:mode mode :permissions perm} (os/stat file))
|
(def {:mode mode :permissions perm} (os/stat file))
|
||||||
(def relpath (string/triml (slice file (length syspath) -1) "/"))
|
(def relpath (string/triml (slice file (length syspath) -1) "/"))
|
||||||
(case mode
|
(case mode
|
||||||
:directory (array/push install-source ~(bundle/add-directory ,relpath ,perm))
|
:directory (array/push install-source ~(bundle/add-directory manifest ,relpath ,perm))
|
||||||
:file (do
|
:file (do
|
||||||
(def filename (string/format "file_%06d" (++ i)))
|
(def filename (string/format "file_%06d" (++ i)))
|
||||||
(copyfile file (string dest-dir "/" filename))
|
(copyfile file (string dest-dir "/" filename))
|
||||||
(array/push install-source ~(bundle/add-file ,filename ,relpath ,perm)))
|
(array/push install-source ~(bundle/add-file manifest ,filename ,relpath ,perm)))
|
||||||
(errorf "unexpected file %v" file)))
|
(errorf "unexpected file %v" file)))
|
||||||
(def b @"")
|
(def b @"(defn install [manifest]\n")
|
||||||
(each form install-source (buffer/format b "%j\n" form))
|
(each form install-source (buffer/format b " %j\n" form))
|
||||||
|
(buffer/push b ")")
|
||||||
(spit install-hook b))
|
(spit install-hook b))
|
||||||
dest-dir)
|
dest-dir)
|
||||||
|
|
||||||
@ -4143,9 +4136,7 @@
|
|||||||
(def backup-bundle-source (bundle/pack bundle-name backup-dir true))
|
(def backup-bundle-source (bundle/pack bundle-name backup-dir true))
|
||||||
(edefer (do
|
(edefer (do
|
||||||
(bundle/install backup-bundle-source bundle-name)
|
(bundle/install backup-bundle-source bundle-name)
|
||||||
# Restore old manifest and hooks that point to local source instead of backup source
|
(copyrf (string backup-bundle-source "/old-bundle") (bundle-dir bundle-name))
|
||||||
(copy-hooks (string backup-bundle-source "/old-hooks") bundle-name)
|
|
||||||
(sync-manifest manifest)
|
|
||||||
(rmrf backup-bundle-source))
|
(rmrf backup-bundle-source))
|
||||||
(bundle/uninstall bundle-name)
|
(bundle/uninstall bundle-name)
|
||||||
(bundle/install path bundle-name ;(kvs config)))
|
(bundle/install path bundle-name ;(kvs config)))
|
||||||
@ -4154,9 +4145,8 @@
|
|||||||
|
|
||||||
(defn bundle/add-directory
|
(defn bundle/add-directory
|
||||||
"Add a directory during the install process relative to `(dyn *syspath*)`"
|
"Add a directory during the install process relative to `(dyn *syspath*)`"
|
||||||
[dest &opt chmod-mode]
|
[manifest dest &opt chmod-mode]
|
||||||
(edefer (sync-manifest)
|
(def files (get-files manifest))
|
||||||
(def files (get-files))
|
|
||||||
(def absdest (string (dyn *syspath*) "/" dest))
|
(def absdest (string (dyn *syspath*) "/" dest))
|
||||||
(unless (os/mkdir absdest)
|
(unless (os/mkdir absdest)
|
||||||
(errorf "collision at %s, directory already exists" absdest))
|
(errorf "collision at %s, directory already exists" absdest))
|
||||||
@ -4164,14 +4154,13 @@
|
|||||||
(when chmod-mode
|
(when chmod-mode
|
||||||
(os/chmod absdest chmod-mode))
|
(os/chmod absdest chmod-mode))
|
||||||
(print "+ " absdest)
|
(print "+ " absdest)
|
||||||
absdest))
|
absdest)
|
||||||
|
|
||||||
(defn bundle/add-file
|
(defn bundle/add-file
|
||||||
"Add files during an install relative to `(dyn *syspath*)`"
|
"Add files during an install relative to `(dyn *syspath*)`"
|
||||||
[src &opt dest chmod-mode]
|
[manifest src &opt dest chmod-mode]
|
||||||
(default dest src)
|
(default dest src)
|
||||||
(edefer (sync-manifest)
|
(def files (get-files manifest))
|
||||||
(def files (get-files))
|
|
||||||
(def absdest (string (dyn *syspath*) "/" dest))
|
(def absdest (string (dyn *syspath*) "/" dest))
|
||||||
(when (os/stat absdest :mode)
|
(when (os/stat absdest :mode)
|
||||||
(errorf "collision at %s, file already exists" absdest))
|
(errorf "collision at %s, file already exists" absdest))
|
||||||
@ -4180,7 +4169,7 @@
|
|||||||
(when chmod-mode
|
(when chmod-mode
|
||||||
(os/chmod absdest chmod-mode))
|
(os/chmod absdest chmod-mode))
|
||||||
(print "+ " absdest)
|
(print "+ " absdest)
|
||||||
absdest))
|
absdest)
|
||||||
|
|
||||||
(defn bundle/list
|
(defn bundle/list
|
||||||
"Get a list of all installed bundles in lexical order."
|
"Get a list of all installed bundles in lexical order."
|
||||||
@ -4232,6 +4221,28 @@
|
|||||||
(compwhen (not (dyn 'os/isatty))
|
(compwhen (not (dyn 'os/isatty))
|
||||||
(defmacro os/isatty [&] true))
|
(defmacro os/isatty [&] true))
|
||||||
|
|
||||||
|
(def- long-to-short
|
||||||
|
"map long options to short options"
|
||||||
|
{"-help" "h"
|
||||||
|
"-version" "v"
|
||||||
|
"-stdin" "s"
|
||||||
|
"-eval" "e"
|
||||||
|
"-expression" "E"
|
||||||
|
"-debug" "d"
|
||||||
|
"-repl" "r"
|
||||||
|
"-noprofile" "R"
|
||||||
|
"-persistent" "p"
|
||||||
|
"-quiet" "q"
|
||||||
|
"-flycheck" "k"
|
||||||
|
"-syspath" "m"
|
||||||
|
"-compile" "c"
|
||||||
|
"-image" "i"
|
||||||
|
"-nocolor" "n"
|
||||||
|
"-color" "N"
|
||||||
|
"-library" "l"
|
||||||
|
"-lint-warn" "w"
|
||||||
|
"-lint-error" "x"})
|
||||||
|
|
||||||
(defn cli-main
|
(defn cli-main
|
||||||
`Entrance for the Janet CLI tool. Call this function with the command line
|
`Entrance for the Janet CLI tool. Call this function with the command line
|
||||||
arguments as an array or tuple of strings to invoke the CLI interface.`
|
arguments as an array or tuple of strings to invoke the CLI interface.`
|
||||||
@ -4263,28 +4274,6 @@
|
|||||||
(def x (in args (+ i 1)))
|
(def x (in args (+ i 1)))
|
||||||
(or (scan-number x) (keyword x)))
|
(or (scan-number x) (keyword x)))
|
||||||
|
|
||||||
(def- long-to-short
|
|
||||||
"map long options to short options"
|
|
||||||
{"-help" "h"
|
|
||||||
"-version" "v"
|
|
||||||
"-stdin" "s"
|
|
||||||
"-eval" "e"
|
|
||||||
"-expression" "E"
|
|
||||||
"-debug" "d"
|
|
||||||
"-repl" "r"
|
|
||||||
"-noprofile" "R"
|
|
||||||
"-persistent" "p"
|
|
||||||
"-quiet" "q"
|
|
||||||
"-flycheck" "k"
|
|
||||||
"-syspath" "m"
|
|
||||||
"-compile" "c"
|
|
||||||
"-image" "i"
|
|
||||||
"-nocolor" "n"
|
|
||||||
"-color" "N"
|
|
||||||
"-library" "l"
|
|
||||||
"-lint-warn" "w"
|
|
||||||
"-lint-error" "x"})
|
|
||||||
|
|
||||||
# Flag handlers
|
# Flag handlers
|
||||||
(def handlers
|
(def handlers
|
||||||
{"h" (fn [&]
|
{"h" (fn [&]
|
||||||
|
Loading…
Reference in New Issue
Block a user