mirrors/janet
1
0
Fork 0
mirror of https://github.com/janet-lang/janet synced 2024-11-14 12:44:49 +00:00
Code Issues 1 Releases Wiki Activity

Work on port of jpm to modules.

Browse Source
This commit is contained in:
Calvin Rose 2021-06-13 21:11:08 -05:00
parent 87f8fe14dd
commit f198071964
15 changed files with 1683 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
jpm
View File

@ -2,6 +2,15 @@
# CLI tool for building janet projects.
# Check for package to replace jpm - jpm package exists, run it's `cli` function.
(def- [ok cli]
(protect
(def pkg (require "jpm"))
(get (get pkg 'cli) :value)))
(when ok
(cli ;(dyn :args))
(os/exit 0))
#
# Basic Path Settings
#
@ -598,8 +607,6 @@
(with [f (file/open source :r)]
(create-buffer-c-impl (:read f :all) dest name))))
(def- root-env (table/getproto (fiber/getenv (fiber/current))))
(defn- modpath-to-meta
"Get the meta file path (.meta.janet) corresponding to a native module path (.so)."
[path]

17
src/boot/boot.janet
View File

@ -1281,8 +1281,7 @@
res)
(defn any?
`Returns the first truthy value in ind, otherwise nil.
falsey value.`
`Returns the first truthy value in ind, otherwise nil.`
[ind]
(var res nil)
(loop [x :in ind :until res]
@ -3345,6 +3344,20 @@
(each f fibers (ev/cancel f "sibling canceled"))
(propagate (fiber/last-value fiber) fiber))))
(defn ev/gather-thunks
``
Function form of `ev/gather` that takes thunks instead of forms. If any of the
sibling fibers error, all other siblings will be canceled. Returns the gathered
results in an array.
``
[thunks]
(def chan (ev/chan))
(def res @[])
(wait-for-fibers chan
(seq [[i thunk] :pairs thunks]
(ev/go (fiber/new (fn [] (put res i (thunk))) :tp) nil chan)))
res)
(defmacro ev/gather
``
Run a number of fibers in parallel on the event loop, and join when they complete.

3
src/core/ev.c
View File

@ -697,6 +697,7 @@ static int janet_channel_push(JanetChannel *channel, Janet x, int mode) {
} else if (janet_q_count(&channel->items) > channel->limit) {
/* No root fiber, we are in completion on a root fiber. Don't block. */
if (mode == 2) return 0;
if (mode == 3) return 1;
/* Pushed successfully, but should block. */
JanetChannelPending pending;
pending.fiber = janet_vm_root_fiber,
@ -2223,7 +2224,7 @@ static const JanetReg ev_cfuns[] = {
"Resume a (copy of a) `fiber` in a new operating system thread, optionally passing `value` "
"to resume with. "
"Unlike `ev/go`, this function will suspend the current fiber until the thread is complete. "
"The the final result.")
"Return the final result.")
},
{
"ev/give-supervisor", cfun_ev_give_supervisor,

347
src/jpm/cc.janet Normal file
View File

@ -0,0 +1,347 @@
###
### C and C++ compiler rule utilties
###
(use ./config)
(use ./rules)
(use ./shutil)
(def- entry-replacer
"Convert url with potential bad characters into an entry-name"
(peg/compile ~(% (any (+ '(range "AZ" "az" "09" "__") (/ '1 ,|(string "_" ($ 0) "_")))))))
(defn entry-replace
"Escape special characters in the entry-name"
[name]
(get (peg/match entry-replacer name) 0))
(defn embed-name
"Rename a janet symbol for embedding."
[path]
(->> path
(string/replace-all "\\" "___")
(string/replace-all "/" "___")
(string/replace-all ".janet" "")))
(defn out-path
"Take a source file path and convert it to an output path."
[path from-ext to-ext]
(->> path
(string/replace-all "\\" "___")
(string/replace-all "/" "___")
(string/replace-all from-ext to-ext)
(string "build/")))
(defn make-define
"Generate strings for adding custom defines to the compiler."
[define value]
(if value
(string "-D" define "=" value)
(string "-D" define)))
(defn make-defines
"Generate many defines. Takes a dictionary of defines. If a value is
true, generates -DNAME (/DNAME on windows), otherwise -DNAME=value."
[defines]
(seq [[d v] :pairs defines] (make-define d (if (not= v true) v))))
(defn- getflags
"Generate the c flags from the input options."
[opts compiler]
(def flags (if (= compiler :cc) :cflags :cppflags))
@[;(opt opts flags)
(string "-I" (dyn:headerpath))
(string "-I" (dyn:modpath))
(string "-O" (opt opts :optimize))])
(defn entry-name
"Name of symbol that enters static compilation of a module."
[name]
(string "janet_module_entry_" (entry-replace name)))
(defn compile-c
"Compile a C file into an object file."
[compiler opts src dest &opt static?]
(def cc (opt opts compiler))
(def cflags [;(getflags opts compiler) ;(if static? [] (dyn :dynamic-cflags))])
(def entry-defines (if-let [n (and static? (opts :entry-name))]
[(make-define "JANET_ENTRY_NAME" n)]
[]))
(def defines [;(make-defines (opt opts :defines {})) ;entry-defines])
(def headers (or (opts :headers) []))
(rule dest [src ;headers]
(print "compiling " src " to " dest "...")
(create-dirs dest)
(if (dyn :is-msvc)
(shell cc ;defines "/c" ;cflags (string "/Fo" dest) src)
(shell cc "-c" src ;defines ;cflags "-o" dest))))
(defn link-c
"Link C or C++ object files together to make a native module."
[has-cpp opts target & objects]
(def linker (dyn (if has-cpp :c++-link :cc-link)))
(def cflags (getflags opts (if has-cpp :cppflags :cflags)))
(def lflags [;(opt opts :lflags)
;(if (opts :static) [] (dyn:dynamic-lflags))])
(def deplibs (get opts :native-deps []))
(def dep-ldflags (seq [x :in deplibs] (string (dyn:modpath) "/" x (dyn:modext))))
# Use import libs on windows - we need an import lib to link natives to other natives.
(def dep-importlibs (seq [x :in deplibs] (string (dyn:modpath) "/" x ".lib")))
(def ldflags [;(opt opts :ldflags []) ;dep-ldflags])
(rule target objects
(print "linking " target "...")
(create-dirs target)
(if (dyn :is-msvc)
(shell linker ;ldflags (string "/OUT:" target) ;objects
(string (dyn:headerpath) "/janet.lib") ;dep-importlibs ;lflags)
(shell linker ;cflags ;ldflags `-o` target ;objects ;lflags))))
(defn archive-c
"Link object files together to make a static library."
[opts target & objects]
(def ar (opt opts :ar))
(rule target objects
(print "creating static library " target "...")
(create-dirs target)
(if (dyn :is-msvc)
(shell ar "/nologo" (string "/out:" target) ;objects)
(shell ar "rcs" target ;objects))))
#
# Standalone C compilation
#
(defn create-buffer-c-impl
[bytes dest name]
(create-dirs dest)
(def out (file/open dest :w))
(def chunks (seq [b :in bytes] (string b)))
(file/write out
"#include <janet.h>\n"
"static const unsigned char bytes[] = {"
(string/join (interpose ", " chunks))
"};\n\n"
"const unsigned char *" name "_embed = bytes;\n"
"size_t " name "_embed_size = sizeof(bytes);\n")
(file/close out))
(defn create-buffer-c
"Inline raw byte file as a c file."
[source dest name]
(rule dest [source]
(print "generating " dest "...")
(create-dirs dest)
(with [f (file/open source :r)]
(create-buffer-c-impl (:read f :all) dest name))))
(defn modpath-to-meta
"Get the meta file path (.meta.janet) corresponding to a native module path (.so)."
[path]
(string (string/slice path 0 (- (length (dyn :modext)))) "meta.janet"))
(defn modpath-to-static
"Get the static library (.a) path corresponding to a native module path (.so)."
[path]
(string (string/slice path 0 (- -1 (length (dyn :modext)))) (dyn :statext)))
(defn make-bin-source
[declarations lookup-into-invocations no-core]
(string
declarations
```
int main(int argc, const char **argv) {
#if defined(JANET_PRF)
uint8_t hash_key[JANET_HASH_KEY_SIZE + 1];
#ifdef JANET_REDUCED_OS
char *envvar = NULL;
#else
char *envvar = getenv("JANET_HASHSEED");
#endif
if (NULL != envvar) {
strncpy((char *) hash_key, envvar, sizeof(hash_key) - 1);
} else if (janet_cryptorand(hash_key, JANET_HASH_KEY_SIZE) != 0) {
fputs("unable to initialize janet PRF hash function.\n", stderr);
return 1;
}
janet_init_hash_key(hash_key);
#endif
janet_init();
```
(if no-core
```
/* Get core env */
JanetTable *env = janet_table(8);
JanetTable *lookup = janet_core_lookup_table(NULL);
JanetTable *temptab;
int handle = janet_gclock();
```
```
/* Get core env */
JanetTable *env = janet_core_env(NULL);
JanetTable *lookup = janet_env_lookup(env);
JanetTable *temptab;
int handle = janet_gclock();
```)
lookup-into-invocations
```
/* Unmarshal bytecode */
Janet marsh_out = janet_unmarshal(
janet_payload_image_embed,
janet_payload_image_embed_size,
0,
lookup,
NULL);
/* Verify the marshalled object is a function */
if (!janet_checktype(marsh_out, JANET_FUNCTION)) {
fprintf(stderr, "invalid bytecode image - expected function.");
return 1;
}
JanetFunction *jfunc = janet_unwrap_function(marsh_out);
/* Check arity */
janet_arity(argc, jfunc->def->min_arity, jfunc->def->max_arity);
/* Collect command line arguments */
JanetArray *args = janet_array(argc);
for (int i = 0; i < argc; i++) {
janet_array_push(args, janet_cstringv(argv[i]));
}
/* Create enviornment */
temptab = env;
janet_table_put(temptab, janet_ckeywordv("args"), janet_wrap_array(args));
janet_gcroot(janet_wrap_table(temptab));
/* Unlock GC */
janet_gcunlock(handle);
/* Run everything */
JanetFiber *fiber = janet_fiber(jfunc, 64, argc, argc ? args->data : NULL);
fiber->env = temptab;
#ifdef JANET_EV
janet_gcroot(janet_wrap_fiber(fiber));
janet_schedule(fiber, janet_wrap_nil());
janet_loop();
int status = janet_fiber_status(fiber);
janet_deinit();
return status;
#else
Janet out;
JanetSignal result = janet_continue(fiber, janet_wrap_nil(), &out);
if (result != JANET_SIGNAL_OK && result != JANET_SIGNAL_EVENT) {
janet_stacktrace(fiber, out);
janet_deinit();
return result;
}
janet_deinit();
return 0;
#endif
}
```))
(defn create-executable
"Links an image with libjanet.a (or .lib) to produce an
executable. Also will try to link native modules into the
final executable as well."
[opts source dest no-core]
# Create executable's janet image
(def cimage_dest (string dest ".c"))
(def no-compile (opts :no-compile))
(rule (if no-compile cimage_dest dest) [source]
(print "generating executable c source...")
(create-dirs dest)
# Load entry environment and get main function.
(def entry-env (dofile source))
(def main ((entry-env 'main) :value))
(def dep-lflags @[])
(def dep-ldflags @[])
# Create marshalling dictionary
(def mdict1 (invert (env-lookup root-env)))
(def mdict
(if no-core
(let [temp @{}]
(eachp [k v] mdict1
(if (or (cfunction? k) (abstract? k))
(put temp k v)))
temp)
mdict1))
# Load all native modules
(def prefixes @{})
(def static-libs @[])
(loop [[name m] :pairs module/cache
:let [n (m :native)]
:when n
:let [prefix (gensym)]]
(print "found native " n "...")
(put prefixes prefix n)
(array/push static-libs (modpath-to-static n))
(def oldproto (table/getproto m))
(table/setproto m nil)
(loop [[sym value] :pairs (env-lookup m)]
(put mdict value (symbol prefix sym)))
(table/setproto m oldproto))
# Find static modules
(var has-cpp false)
(def declarations @"")
(def lookup-into-invocations @"")
(loop [[prefix name] :pairs prefixes]
(def meta (eval-string (slurp (modpath-to-meta name))))
(if (meta :cpp) (set has-cpp true))
(buffer/push-string lookup-into-invocations
" temptab = janet_table(0);\n"
" temptab->proto = env;\n"
" " (meta :static-entry) "(temptab);\n"
" janet_env_lookup_into(lookup, temptab, \""
prefix
"\", 0);\n\n")
(when-let [lfs (meta :lflags)]
(array/concat dep-lflags lfs))
(when-let [lfs (meta :ldflags)]
(array/concat dep-ldflags lfs))
(buffer/push-string declarations
"extern void "
(meta :static-entry)
"(JanetTable *);\n"))
# Build image
(def image (marshal main mdict))
# Make image byte buffer
(create-buffer-c-impl image cimage_dest "janet_payload_image")
# Append main function
(spit cimage_dest (make-bin-source declarations lookup-into-invocations no-core) :ab)
(def oimage_dest (out-path cimage_dest ".c" ".o"))
# Compile and link final exectable
(unless no-compile
(def ldflags [;dep-ldflags ;(opt opts :ldflags []) ;(dyn :janet-ldflags)])
(def lflags [;static-libs (dyn :libjanet) ;dep-lflags ;(opt opts :lflags) ;(dyn :janet-lflags)])
(def defines (make-defines (opt opts :defines {})))
(def cc (opt opts :cc))
(def cflags [;(getflags opts :cc) ;(dyn :janet-cflags)])
(print "compiling " cimage_dest " to " oimage_dest "...")
(create-dirs oimage_dest)
(if (dyn :is-msvc)
(shell cc ;defines "/c" ;cflags (string "/Fo" oimage_dest) cimage_dest)
(shell cc "-c" cimage_dest ;defines ;cflags "-o" oimage_dest))
(if has-cpp
(let [linker (opt opts (if (dyn :is-msvc) :cpp-linker :cpp-compiler))
cppflags [;(getflags opts :c++) ;(dyn :janet-cflags)]]
(print "linking " dest "...")
(if (dyn :is-msvc)
(shell linker ;ldflags (string "/OUT:" dest) oimage_dest ;lflags)
(shell linker ;cppflags ;ldflags `-o` dest oimage_dest ;lflags)))
(let [linker (opt opts (if (dyn :is-msvc) :linker :compiler))]
(print "linking " dest "...")
(create-dirs dest)
(if (dyn :is-msvc)
(shell linker ;ldflags (string "/OUT:" dest) oimage_dest ;lflags)
(shell linker ;cflags ;ldflags `-o` dest oimage_dest ;lflags)))))))

91
src/jpm/cli.janet Normal file
View File

@ -0,0 +1,91 @@
###
### Command Line interface for jpm.
###
(use ./config)
(import ./commands)
# Import some submodules to create a jpm env.
(import ./declare :prefix "" :export true)
(import ./rules :prefix "" :export true)
(import ./shutil :prefix "" :export true)
(import ./cc :prefix "" :export true)
(import ./pm :prefix "" :export true)
(def- _env (curenv))
(def- argpeg
(peg/compile
'(* "--" '(some (if-not "=" 1)) (+ (* "=" '(any 1)) -1))))
(defn main
"Script entry."
[& argv]
(def- args (tuple/slice argv 1))
(def- len (length args))
(var i :private 0)
# Get env variables
(def JANET_PATH (os/getenv "JANET_PATH"))
(def JANET_HEADERPATH (os/getenv "JANET_HEADERPATH"))
(def JANET_LIBPATH (os/getenv "JANET_LIBPATH"))
(def JANET_MODPATH (os/getenv "JANET_MODPATH"))
(def JANET_BINPATH (os/getenv "JANET_BINPATH"))
(def JANET_PKGLIST (os/getenv "JANET_PKGLIST"))
(def JANET_GIT (os/getenv "JANET_GIT"))
(def JANET_OS_WHICH (os/getenv "JANET_OS_WHICH"))
(def CC (os/getenv "CC"))
(def CXX (os/getenv "CXX"))
(def AR (os/getenv "AR"))
# Set dynamic bindings
(setdyn :gitpath (or JANET_GIT "git"))
(setdyn :pkglist (or JANET_PKGLIST "https://github.com/janet-lang/pkgs.git"))
(setdyn :modpath (or JANET_MODPATH (dyn :syspath)))
(setdyn :headerpath (or JANET_HEADERPATH "/usr/local/include/janet"))
(setdyn :libpath (or JANET_LIBPATH "/usr/local/lib"))
(setdyn :binpath (or JANET_BINPATH "/usr/local/bin"))
(setdyn :use-batch-shell false)
(setdyn :cc (or CC "cc"))
(setdyn :c++ (or CXX "c++"))
(setdyn :cc-link (or CC "cc"))
(setdyn :c++-link (or CXX "c++"))
(setdyn :ar (or AR "ar"))
(setdyn :lflags @[])
(setdyn :ldflags @[])
(setdyn :cflags @["-std=c99" "-Wall" "-Wextra"])
(setdyn :cppflags @["-std=c99" "-Wall" "-Wextra"])
(setdyn :dynamic-lflags @["-shared" "-lpthread"])
(setdyn :dynamic-cflags @[])
(setdyn :optimize 2)
(setdyn :modext ".so")
(setdyn :statext ".a")
(setdyn :is-msvc false)
(setdyn :libjanet (string (dyn :libpath) "/libjanet.a"))
(setdyn :janet-ldflags @[])
(setdyn :janet-lflags @["-lm" "-ldl" "-lrt" "-lpthread"])
(setdyn :janet-cflags @[])
(setdyn :jpm-env _env)
(setdyn :janet (dyn :executable))
(setdyn :auto-shebang true)
# Get flags
(while (< i len)
(if-let [m (peg/match argpeg (args i))]
(if (= 2 (length m))
(let [[key value] m]
(setdyn (keyword key) value))
(setdyn (keyword (m 0)) true))
(break))
(++ i))
# Run subcommand
(if (= i len)
(commands/help)
(do
(if-let [com (get commands/subcommands (args i))]
(com ;(tuple/slice args (+ i 1)))
(do
(print "invalid command " (args i))
(commands/help))))))

236
src/jpm/commands.janet Normal file
View File

@ -0,0 +1,236 @@
###
### All of the CLI sub commands
###
(use ./config)
(use ./declare)
(use ./rules)
(use ./shutil)
(use ./cc)
(use ./pm)
(defn- help
[]
(print `
usage: jpm [--key=value, --flag] ... [subcommand] [args] ...
Run from a directory containing a project.janet file to perform operations
on a project, or from anywhere to do operations on the global module cache (modpath).
Commands that need write permission to the modpath are considered privileged commands - in
some environments they may require super user privileges.
Other project-level commands need to have a ./project.janet file in the current directory.
Unprivileged global subcommands:
help : show this help text
show-paths : prints the paths that will be used to install things.
quickbin entry executable : Create an executable from a janet script with a main function.
Privileged global subcommands:
install (repo or name)... : install artifacts. If a repo is given, install the contents of that
git repository, assuming that the repository is a jpm project. If not, build
and install the current project.
uninstall (module)... : uninstall a module. If no module is given, uninstall the module
defined by the current directory.
clear-cache : clear the git cache. Useful for updating dependencies.
clear-manifest : clear the manifest. Useful for fixing broken installs.
make-lockfile (lockfile) : Create a lockfile based on repositories in the cache. The
lockfile will record the exact versions of dependencies used to ensure a reproducible
build. Lockfiles are best used with applications, not libraries. The default lockfile
name is lockfile.jdn.
load-lockfile (lockfile) : Install modules from a lockfile in a reproducible way. The
default lockfile name is lockfile.jdn.
update-pkgs : Update the current package listing from the remote git repository selected.
Privileged project subcommands:
deps : install dependencies for the current project.
install : install artifacts of the current project.
uninstall : uninstall the current project's artifacts.
Unprivileged project subcommands:
build : build all artifacts
clean : remove any generated files or artifacts
test : run tests. Tests should be .janet files in the test/ directory relative to project.janet.
run rule : run a rule. Can also run custom rules added via (phony "task" [deps...] ...)
or (rule "ouput.file" [deps...] ...).
rules : list rules available with run.
list-installed : list installed packages in the current syspath.
list-pkgs (search) : list packages in the package listing that the contain the string search.
If no search pattern is given, prints the entire package listing.
rule-tree (root rule) (depth) : Print a nice tree to see what rules depend on other rules.
Optionally provide a root rule to start printing from, and a
max depth to print. Without these options, all rules will print
their full dependency tree.
debug-repl : Run a repl in the context of the current project.janet file. This lets you run rules and
otherwise debug the current project.janet file.
Keys are:
--modpath : The directory to install modules to. Defaults to $JANET_MODPATH, $JANET_PATH, or (dyn :syspath)
--headerpath : The directory containing janet headers. Defaults to $JANET_HEADERPATH.
--binpath : The directory to install binaries and scripts. Defaults to $JANET_BINPATH.
--libpath : The directory containing janet C libraries (libjanet.*). Defaults to $JANET_LIBPATH.
--compiler : C compiler to use for natives. Defaults to $CC or cc (cl.exe on windows).
--cpp-compiler : C++ compiler to use for natives. Defaults to $CXX or c++ (cl.exe on windows).
--archiver : C archiver to use for static libraries. Defaults to $AR ar (lib.exe on windows).
--linker : C linker to use for linking natives. Defaults to link.exe on windows, not used on
other platforms.
--pkglist : URL of git repository for package listing. Defaults to $JANET_PKGLIST or https://github.com/janet-lang/pkgs.git
Flags are:
--nocolor : Disable color in the jpm repl.
--verbose : Print shell commands as they are executed.
--test : If passed to jpm install, runs tests before installing. Will run tests recursively on dependencies.
--offline : Prevents jpm from going to network to get dependencies - all dependencies should be in the cache or this command will fail.
`))
(defn- local-rule
[rule &opt no-deps]
(import-rules "./project.janet" no-deps)
(do-rule rule))
(defn show-help
[]
(print help))
(defn show-paths
[]
(print "binpath: " (dyn:binpath))
(print "modpath: " (dyn:modpath))
(print "libpath: " (dyn:libpath))
(print "headerpath: " (dyn:headerpath))
(print "syspath: " (dyn:syspath)))
(defn build
[]
(local-rule "build"))
(defn clean
[]
(local-rule "clean"))
(defn install
[& repo]
(if (empty? repo)
(local-rule "install")
(each rep repo (bundle-install rep))))
(defn test
[]
(local-rule "test"))
(defn- uninstall-cmd
[& what]
(if (empty? what)
(local-rule "uninstall")
(each wha what (uninstall wha))))
(defn deps
[]
(local-rule "install-deps" true))
(defn- print-rule-tree
"Show dependencies for a given rule recursively in a nice tree."
[root depth prefix prefix-part]
(print prefix root)
(when-let [{:inputs root-deps} ((getrules) root)]
(when (pos? depth)
(def l (-> root-deps length dec))
(eachp [i d] (sorted root-deps)
(print-rule-tree
d (dec depth)
(string prefix-part (if (= i l) " └─" " ├─"))
(string prefix-part (if (= i l) " " " │ ")))))))
(defn show-rule-tree
[&opt root depth]
(import-rules "./project.janet")
(def max-depth (if depth (scan-number depth) math/inf))
(if root
(print-rule-tree root max-depth "" "")
(let [ks (sort (seq [k :keys (dyn :rules)] k))]
(each k ks (print-rule-tree k max-depth "" "")))))
(defn list-rules
[&opt ctx]
(import-rules "./project.janet")
(def ks (sort (seq [k :keys (dyn :rules)] k)))
(each k ks (print k)))
(defn list-installed
[]
(def xs
(seq [x :in (os/dir (find-manifest-dir))
:when (string/has-suffix? ".jdn" x)]
(string/slice x 0 -5)))
(sort xs)
(each x xs (print x)))
(defn list-pkgs
[&opt search]
(def [ok _] (module/find "pkgs"))
(unless ok
(eprint "no local package listing found. Run `jpm update-pkgs` to get listing.")
(os/exit 1))
(def pkgs-mod (require "pkgs"))
(def ps
(seq [p :keys (get-in pkgs-mod ['packages :value] [])
:when (if search (string/find search p) true)]
p))
(sort ps)
(each p ps (print p)))
(defn update-pkgs
[]
(bundle-install (dyn:pkglist)))
(defn quickbin
[input output]
(if (= (os/stat output :mode) :file)
(print "output " output " exists."))
(create-executable @{:no-compile (dyn :no-compile)} input output (dyn :no-core))
(do-rule output))
(defn jpm-debug-repl
[]
(def env
(try
(require-jpm "./project.janet")
([err f]
(if (= "cannot open ./project.janet" err)
(put (make-jpm-env) :project {})
(propagate err f)))))
(setdyn :pretty-format (if-not (dyn :nocolor) "%.20Q" "%.20q"))
(setdyn :err-color (if-not (dyn :nocolor) true))
(def p (env :project))
(def name (p :name))
(if name (print "Project: " name))
(if-let [r (p :repo)] (print "Repository: " r))
(if-let [a (p :author)] (print "Author: " a))
(defn getchunk [buf p]
(def [line] (parser/where p))
(getline (string "jpm[" (or name "repl") "]:" line ":" (parser/state p :delimiters) "> ") buf env))
(repl getchunk nil env))
(def subcommands
{"build" build
"clean" clean
"help" show-help
"install" install
"test" test
"help" help
"deps" deps
"debug-repl" jpm-debug-repl
"rule-tree" show-rule-tree
"show-paths" show-paths
"list-installed" list-installed
"list-pkgs" list-pkgs
"clear-cache" clear-cache
"clear-manifest" clear-manifest
"run" local-rule
"rules" list-rules
"update-pkgs" update-pkgs
"uninstall" uninstall-cmd
"make-lockfile" make-lockfile
"load-lockfile" load-lockfile
"quickbin" quickbin})

61
src/jpm/config.janet Normal file
View File

@ -0,0 +1,61 @@
###
### Various defaults that can be set at compile time
### and configure the behavior of the module.
###
(def config-dyns
"A table of all of the dynamic config bindings."
@{})
(defmacro defdyn
"Define a function that wraps (dyn :keyword). This will
allow use of dynamic bindings with static runtime checks."
[kw & meta]
(put config-dyns kw true)
(let [s (symbol "dyn:" kw)]
~(defn ,s ,;meta [&opt dflt]
(def x (,dyn ,kw dflt))
(if (= x nil)
(,errorf "no value found for dynamic binding %v" ,kw)
x))))
(defn opt
"Get an option, allowing overrides via dynamic bindings AND some
default value dflt if no dynamic binding is set."
[opts key &opt dflt]
(def ret (or (get opts key) (dyn key dflt)))
(if (= nil ret)
(error (string "option :" key " not set")))
ret)
# All jpm settings.
(defdyn :ar)
(defdyn :auto-shebang)
(defdyn :binpath)
(defdyn :c++)
(defdyn :c++-link)
(defdyn :cc)
(defdyn :cc-link)
(defdyn :cflags)
(defdyn :cppflags)
(defdyn :dynamic-cflags)
(defdyn :dynamic-lflags)
(defdyn :gitpath)
(defdyn :headerpath)
(defdyn :is-msvc)
(defdyn :janet)
(defdyn :janet-cflags)
(defdyn :janet-ldflags)
(defdyn :janet-lflags)
(defdyn :ldflags)
(defdyn :lflags)
(defdyn :libjanet)
(defdyn :libpath)
(defdyn :modext)
(defdyn :modpath)
(defdyn :offline)
(defdyn :optimize)
(defdyn :pkglist)
(defdyn :statext)
(defdyn :syspath)
(defdyn :use-batch-shell)

71
src/jpm/dagbuild.janet Normal file
View File

@ -0,0 +1,71 @@
###
### dagbuild.janet
###
### A module for building files / running commands in an order.
### Building blocks for a Make-like build system.
###
#
# DAG Execution
#
(defn pmap
"Function form of `ev/gather`. If any of the
sibling fibers error, all other siblings will be canceled. Returns the gathered
results in an array."
[f data]
(def chan (ev/chan))
(def res @[])
(def fibers
(seq [[i x] :pairs data]
(ev/go (fiber/new (fn [] (put res i (f x))) :tp) nil chan)))
(repeat (length fibers)
(def [sig fiber] (ev/take chan))
(unless (= sig :ok)
(each f fibers (ev/cancel f "sibling canceled"))
(propagate (fiber/last-value fiber) fiber)))
res)
(defn pdag
"Executes a dag by calling f on every node in the graph.
Can set the number of workers
for parallel execution. The graph is represented as a table
mapping nodes to arrays of child nodes. Each node will only be evaluated
after all children have been evaluated. Returns a table mapping each node
to the result of `(f node)`."
[f dag &opt n-workers]
# preprocess
(def res @{})
(def seen @{})
(def q (ev/chan math/int32-max))
(def dep-counts @{})
(def inv @{})
(defn visit [node]
(if (seen node) (break))
(put seen node true)
(def depends-on (get dag node []))
(if (empty? depends-on)
(ev/give q node))
(each r depends-on
(put inv r (array/push (get inv r @[]) node))
(visit r)))
(eachk r dag (visit r))
# run n workers in parallel
(default n-workers (max 1 (length seen)))
(assert (> n-workers 0))
(defn worker [&]
(while (next seen)
(def node (ev/take q))
(if-not node (break))
(when (in seen node)
(put seen node nil)
(put res node (f node)))
(each r (get inv node [])
(when (zero? (set (dep-counts r) (dec (get dep-counts r 1))))
(ev/give q r))))
(ev/give q nil))
(pmap worker (range n-workers))
res)

271
src/jpm/declare.janet Normal file
View File

@ -0,0 +1,271 @@
###
### Rule generation for adding native source code
###
(use ./config)
(use ./rules)
(use ./shutil)
(use ./cc)
(use ./pm)
(defn declare-native
"Declare a native module. This is a shared library that can be loaded
dynamically by a janet runtime. This also builds a static libary that
can be used to bundle janet code and native into a single executable."
[&keys opts]
(def sources (opts :source))
(def name (opts :name))
(def path (dyn:modpath))
(def modext (dyn:modext))
(def statext (dyn:statext))
# Make dynamic module
(def lname (string "build/" name modext))
# Get objects to build with
(var has-cpp false)
(def objects
(seq [src :in sources]
(def suffix
(cond
(string/has-suffix? ".cpp" src) ".cpp"
(string/has-suffix? ".cc" src) ".cc"
(string/has-suffix? ".c" src) ".c"
(errorf "unknown source file type: %s, expected .c, .cc, or .cpp" src)))
(def op (out-path src suffix ".o"))
(if (= suffix ".c")
(compile-c :cc opts src op)
(do (compile-c :c++ opts src op)
(set has-cpp true)))
op))
(when-let [embedded (opts :embedded)]
(loop [src :in embedded]
(def c-src (out-path src ".janet" ".janet.c"))
(def o-src (out-path src ".janet" ".janet.o"))
(array/push objects o-src)
(create-buffer-c src c-src (embed-name src))
(compile-c :cc opts c-src o-src)))
(link-c has-cpp opts lname ;objects)
(add-dep "build" lname)
(install-rule lname path)
# Add meta file
(def metaname (modpath-to-meta lname))
(def ename (entry-name name))
(rule metaname []
(print "generating meta file " metaname "...")
(os/mkdir "build")
(spit metaname (string/format
"# Metadata for static library %s\n\n%.20p"
(string name statext)
{:static-entry ename
:cpp has-cpp
:ldflags ~',(opts :ldflags)
:lflags ~',(opts :lflags)})))
(add-dep "build" metaname)
(install-rule metaname path)
# Make static module
(unless (dyn :nostatic)
(def sname (string "build/" name statext))
(def opts (merge @{:entry-name ename} opts))
(def sobjext ".static.o")
(def sjobjext ".janet.static.o")
# Get static objects
(def sobjects
(seq [src :in sources]
(def suffix
(cond
(string/has-suffix? ".cpp" src) ".cpp"
(string/has-suffix? ".cc" src) ".cc"
(string/has-suffix? ".c" src) ".c"
(errorf "unknown source file type: %s, expected .c, .cc, or .cpp" src)))
(def op (out-path src suffix sobjext))
(compile-c (if (= ".c" suffix) :cc :c++) opts src op true)
op))
(when-let [embedded (opts :embedded)]
(loop [src :in embedded]
(def c-src (out-path src ".janet" ".janet.c"))
(def o-src (out-path src ".janet" sjobjext))
(array/push sobjects o-src)
# Buffer c-src is already declared by dynamic module
(compile-c :cc opts c-src o-src true)))
(archive-c opts sname ;sobjects)
(add-dep "build" sname)
(install-rule sname path)))
(defn declare-source
"Create Janet modules. This does not actually build the module(s),
but registers them for packaging and installation. :source should be an
array of files and directores to copy into JANET_MODPATH or JANET_PATH.
:prefix can optionally be given to modify the destination path to be
(string JANET_PATH prefix source)."
[&keys {:source sources :prefix prefix}]
(def path (string (dyn:modpath) "/" (or prefix "")))
(if (bytes? sources)
(install-rule sources path)
(each s sources
(install-rule s path))))
(defn declare-headers
"Declare headers for a library installation. Installed headers can be used by other native
libraries."
[&keys {:headers headers :prefix prefix}]
(def path (string (dyn:modpath) "/" (or prefix "")))
(if (bytes? headers)
(install-rule headers path)
(each h headers
(install-rule h path))))
(defn declare-bin
"Declare a generic file to be installed as an executable."
[&keys {:main main}]
(install-rule main (dyn:binpath)))
(defn declare-executable
"Declare a janet file to be the entry of a standalone executable program. The entry
file is evaluated and a main function is looked for in the entry file. This function
is marshalled into bytecode which is then embedded in a final executable for distribution.\n\n
This executable can be installed as well to the --binpath given."
[&keys {:install install :name name :entry entry :headers headers
:cflags cflags :lflags lflags :deps deps :ldflags ldflags
:no-compile no-compile :no-core no-core}]
(def name (if (= (os/which) :windows) (string name ".exe") name))
(def dest (string "build/" name))
(create-executable @{:cflags cflags :lflags lflags :ldflags ldflags :no-compile no-compile} entry dest no-core)
(if no-compile
(let [cdest (string dest ".c")]
(add-dep "build" cdest))
(do
(add-dep "build" dest)
(when headers
(each h headers (add-dep dest h)))
(when deps
(each d deps (add-dep dest d)))
(when install
(install-rule dest (dyn:binpath))))))
(defn declare-binscript
``Declare a janet file to be installed as an executable script. Creates
a shim on windows. If hardcode is true, will insert code into the script
such that it will run correctly even when JANET_PATH is changed. if auto-shebang
is truthy, will also automatically insert a correct shebang line.
``
[&keys {:main main :hardcode-syspath hardcode :is-janet is-janet}]
(def binpath (dyn:binpath))
(def auto-shebang (and is-janet (dyn:auto-shebang)))
(if (or auto-shebang hardcode)
(let [syspath (dyn:modpath)]
(def parts (peg/match path-splitter main))
(def name (last parts))
(def path (string binpath "/" name))
(array/push (dyn :installed-files) path)
(task "install" []
(def contents
(with [f (file/open main)]
(def first-line (:read f :line))
(def second-line (string/format "(put root-env :syspath %v)\n" syspath))
(def rest (:read f :all))
(string (if auto-shebang
(string "#!" (dyn:binpath) "/janet\n"))
first-line (if hardcode second-line) rest)))
(create-dirs path)
(spit path contents)
(unless (= :windows (os/which)) (shell "chmod" "+x" path))))
(install-rule main binpath))
# Create a dud batch file when on windows.
(when (dyn:use-batch-shell)
(def name (last (peg/match path-splitter main)))
(def fullname (string binpath "/" name))
(def bat (string "@echo off\r\njanet \"" fullname "\" %*"))
(def newname (string binpath "/" name ".bat"))
(array/push (dyn :installed-files) newname)
(task "install" []
(spit newname bat))))
(defn declare-archive
"Build a janet archive. This is a file that bundles together many janet
scripts into a janet image. This file can the be moved to any machine with
a janet vm and the required dependencies and run there."
[&keys opts]
(def entry (opts :entry))
(def name (opts :name))
(def iname (string "build/" name ".jimage"))
(rule iname (or (opts :deps) [])
(create-dirs iname)
(spit iname (make-image (require entry))))
(def path (dyn:modpath))
(add-dep "build" iname)
(install-rule iname path))
(defn run-tests
"Run tests on a project in the current directory."
[&opt root-directory]
(defn dodir
[dir]
(each sub (sort (os/dir dir))
(def ndir (string dir "/" sub))
(case (os/stat ndir :mode)
:file (when (string/has-suffix? ".janet" ndir)
(print "running " ndir " ...")
(def result (os/execute [(dyn:janet) ndir] :p))
(when (not= 0 result)
(errorf "non-zero exit code in %s: %d" ndir result)))
:directory (dodir ndir))))
(dodir (or root-directory "test"))
(print "All tests passed."))
(defn declare-project
"Define your project metadata. This should
be the first declaration in a project.janet file.
Also sets up basic task targets like clean, build, test, etc."
[&keys meta]
(setdyn :project meta)
(def installed-files @[])
(def manifests (find-manifest-dir))
(def manifest (find-manifest (meta :name)))
(setdyn :manifest manifest)
(setdyn :manifest-dir manifests)
(setdyn :installed-files installed-files)
(task "build" [])
(task "manifest" [manifest])
(rule manifest []
(print "generating " manifest "...")
(os/mkdir manifests)
(def sha (pslurp (string "\"" (dyn:gitpath) "\" rev-parse HEAD")))
(def url (pslurp (string "\"" (dyn:gitpath) "\" remote get-url origin")))
(def man
{:sha (if-not (empty? sha) sha)
:repo (if-not (empty? url) url)
:dependencies (array/slice (get meta :dependencies []))
:paths installed-files})
(spit manifest (string/format "%j\n" man)))
(task "install" ["uninstall" "build" manifest]
(when (dyn :test)
(run-tests))
(print "Installed as '" (meta :name) "'."))
(task "install-deps" []
(if-let [deps (meta :dependencies)]
(each dep deps
(bundle-install dep))
(print "no dependencies found")))
(task "uninstall" []
(uninstall (meta :name)))
(task "clean" []
(when (os/stat "./build" :mode)
(rm "build")
(print "Deleted build directory.")))
(task "test" ["build"]
(run-tests)))

4
src/jpm/jpm Executable file
View File

@ -0,0 +1,4 @@
#!/usr/bin/env janet
(import "jpm/cli")
(defn main [& argv]
(cli/main ;argv))

207
src/jpm/pm.janet Normal file
View File

@ -0,0 +1,207 @@
###
### Package management functionality
###
(use ./config)
(use ./shutil)
(use ./rules)
(defn- proto-flatten
[into x]
(when x
(proto-flatten into (table/getproto x))
(merge-into into x))
into)
(defn make-jpm-env
"Create an environment that is preloaded with jpm symbols."
[&opt base-env]
(default base-env (dyn :jpm-env {}))
(def env (make-env))
(loop [k :keys base-env :when (symbol? k)
:let [x (get base-env k)]]
(unless (get x :private) (put env k x)))
(def currenv (proto-flatten @{} (curenv)))
(loop [k :keys currenv :when (keyword? k)]
(put env k (currenv k)))
env)
(defn require-jpm
"Require a jpm file project file. This is different from a normal require
in that code is loaded in the jpm environment."
[path &opt no-deps base-env]
(unless (os/stat path :mode)
(error (string "cannot open " path)))
(def env (make-jpm-env base-env))
(dofile path :env env :exit true)
env)
(defn import-rules
"Import another file that defines more rules. This ruleset
is merged into the current ruleset."
[path &opt no-deps base-env]
(def env (require-jpm path no-deps base-env))
(when-let [rules (get env :rules)] (merge-into (getrules) rules))
env)
(defn git
"Make a call to git."
[& args]
(os/execute [(dyn:gitpath) ;args] :px))
(defn install-rule
"Add install and uninstall rule for moving file from src into destdir."
[src destdir]
(def parts (peg/match path-splitter src))
(def name (last parts))
(def path (string destdir "/" name))
(array/push (dyn :installed-files) path)
(task "install" []
(os/mkdir destdir)
(copy src destdir)))
(var- bundle-install-recursive nil)
(defn resolve-bundle-name
"Convert short bundle names to URLs."
[bname]
(if (string/find ":" bname)
(let [pkgs (try
(require "pkgs")
([err]
(bundle-install-recursive (dyn:pkglist))
(require "pkgs")))
url (get-in pkgs ['packages :value (symbol bname)])]
(unless url
(error (string "bundle " bname " not found.")))
url)
bname))
(defn download-bundle
"Donwload the package source (using git) to the local cache. Return the
path to the downloaded or cached soure code."
[url &opt tag]
(default tag "master")
(def cache (find-cache))
(os/mkdir cache)
(def id (filepath-replace url))
(def bundle-dir (string cache "/" id))
(var fresh false)
(if (dyn :offline)
(if (not= :directory (os/stat bundle-dir :mode))
(error (string "did not find cached repository for dependency " url))
(set fresh true))
(when (os/mkdir bundle-dir)
(set fresh true)
(print "cloning repository " url " to " bundle-dir)
(unless (zero? (git "clone" url bundle-dir))
(rimraf bundle-dir)
(error (string "could not clone git dependency " url)))))
(def gd (string "--git-dir=" bundle-dir "/.git"))
(def wt (string "--work-tree=" bundle-dir))
(unless (or (dyn :offline) fresh)
(git gd wt "pull" "origin" "master" "--ff-only"))
(when tag
(git gd wt "reset" "--hard" tag))
(unless (dyn :offline)
(git gd wt "submodule" "update" "--init" "--recursive"))
bundle-dir)
(defn bundle-install
"Install a bundle from a git repository."
[repotab &opt no-deps]
(def repo (resolve-bundle-name
(if (string? repotab) repotab (repotab :repo))))
(def tag (unless (string? repotab) (repotab :tag)))
(def bdir (download-bundle repo tag))
(def olddir (os/cwd))
(defer (os/cd olddir)
(os/cd bdir)
(with-dyns [:rules @{}
:modpath (abspath (dyn:modpath))
:headerpath (abspath (dyn:headerpath))
:libpath (abspath (dyn:libpath))
:binpath (abspath (dyn:binpath))]
(def dep-env (require-jpm "./project.janet" true))
(def rules
(if no-deps
["build" "install"]
["install-deps" "build" "install"]))
(each r rules
(build-rules (get dep-env :rules {}) r)))))
(set bundle-install-recursive bundle-install)
(defn make-lockfile
[&opt filename]
(default filename "lockfile.jdn")
(def cwd (os/cwd))
(def packages @[])
# Read installed modules from manifests
(def mdir (find-manifest-dir))
(each man (os/dir mdir)
(def package (parse (slurp (string mdir "/" man))))
(if (and (dictionary? package) (package :repo) (package :sha))
(array/push packages package)
(print "Cannot add local or malformed package " mdir "/" man " to lockfile, skipping...")))
# Put in correct order, such that a package is preceded by all of its dependencies
(def ordered-packages @[])
(def resolved @{})
(while (< (length ordered-packages) (length packages))
(var made-progress false)
(each p packages
(def {:repo r :sha s :dependencies d} p)
(def dep-urls (map |(if (string? $) $ ($ :repo)) d))
(unless (resolved r)
(when (all resolved dep-urls)
(array/push ordered-packages {:repo r :sha s})
(set made-progress true)
(put resolved r true))))
(unless made-progress
(error (string/format "could not resolve package order for: %j"
(filter (complement resolved) (map |($ :repo) packages))))))
# Write to file, manual format for better diffs.
(with [f (file/open filename :w)]
(with-dyns [:out f]
(prin "@[")
(eachk i ordered-packages
(unless (zero? i)
(prin "\n "))
(prinf "%j" (ordered-packages i)))
(print "]")))
(print "created " filename))
(defn load-lockfile
"Load packages from a lockfile."
[&opt filename]
(default filename "lockfile.jdn")
(def lockarray (parse (slurp filename)))
(each {:repo url :sha sha} lockarray
(bundle-install {:repo url :tag sha} true)))
(defn uninstall
"Uninstall bundle named name"
[name]
(def manifest (find-manifest name))
(when-with [f (file/open manifest)]
(def man (parse (:read f :all)))
(each path (get man :paths [])
(print "removing " path)
(rm path))
(print "removing manifest " manifest)
(:close f) # I hate windows
(rm manifest)
(print "Uninstalled.")))
(defmacro post-deps
"Run code at the top level if jpm dependencies are installed. Build
code that imports dependencies should be wrapped with this macro, as project.janet
needs to be able to run successfully even without dependencies installed."
[& body]
(unless (dyn :jpm-no-deps)
~',(reduce |(eval $1) nil body)))
(defn do-rule
"Evaluate a given rule in a one-off manner."
[target]
(build-rules (dyn :rules) [target]))

19
src/jpm/project.janet Normal file
View File

@ -0,0 +1,19 @@
(declare-project
:name "jpm")
(declare-source
:source ["cc.janet"
"cli.janet"
"commands.janet"
"config.janet"
"dagbuild.janet"
"declare.janet"
"pm.janet"
"rules.janet"
"shutil.janet"]
:prefix "jpm")
(declare-binscript
:main "jpm"
:hardcode-syspath false
:is-janet true)

191
src/jpm/rules.janet Normal file
View File

@ -0,0 +1,191 @@
###
### Rule implementation
###
### Also contains wrappers to more easily define rules in an
### incremental manner.
###
(import ./dagbuild)
(import ./shutil)
(defn- executor
"How to execute a rule at runtime -
extract the recipe thunk(s) and call them."
[rule]
(if-let [r (get rule :recipe)]
(try
(if (indexed? r)
(each rr r (rr))
(r))
# On errors, ensure that none of the output file for this rule
# are kept.
([err f]
(each o (get rule :outputs [])
(protect (shutil/rm o)))
(propagate err f)))))
(defn- target-not-found
"Creates an error message."
[target]
(errorf "target %v does not exist and no rule exists to build it" target))
(defn- target-already-defined
"Error when an output already has a rule defined to create it."
[target]
(errorf "target %v has multiple rules" target))
(defn- utd
"Check if a target is up to date.
Inputs are guaranteed to already be in the utd-cache."
[target all-targets utd-cache]
(def rule (get all-targets target))
(if (= target (get rule :task)) (break false))
(def mtime (os/stat target :modified))
(if-not rule (break (or mtime (target-not-found target))))
(if (not mtime) (break false))
(var ret true)
(each i (get rule :inputs [])
(if-not (get utd-cache i) (break (set ret false)))
(def s (os/stat i :modified))
(when (or (not s) (< mtime s))
(set ret false)
(break)))
ret)
(defn build-rules
"Given a graph of all rules, extract a work graph that will build out-of-date
files."
[rules targets &opt n-workers]
(def dag @{})
(def utd-cache @{})
(def all-targets @{})
(def seen @{})
(each rule (distinct rules)
(when-let [p (get rule :task)]
(when (get all-targets p) (target-already-defined p))
(put all-targets p rule))
(each o (get rule :outputs [])
(when (get all-targets o) (target-already-defined o))
(put all-targets o rule)))
(defn utd1
[target]
(def u (get utd-cache target))
(if (not= nil u)
u
(set (utd-cache target) (utd target all-targets utd-cache))))
(defn visit [target]
(if (in seen target) (break))
(put seen target true)
(def rule (get all-targets target))
(def inputs (get rule :inputs []))
(each i inputs
(visit i))
(def u (utd1 target))
(unless u
(def deps (set (dag rule) (get dag rule @[])))
(each i inputs
(unless (utd1 i)
(if-let [r (get all-targets i)]
(array/push deps r))))))
(each t targets (visit t))
(dagbuild/pdag executor dag n-workers))
#
# Convenience wrappers for defining a rule graph.
# Must be mostly compatible with old jpm interface.
# Main differences are multiple outputs for a rule are allowed,
# and a rule cannot have both phony and non-phony thunks.
#
(defn getrules []
(if-let [targets (dyn :rules)] targets (setdyn :rules @{})))
(defn- gettarget [target]
(def item ((getrules) target))
(unless item (error (string "no rule for target '" target "'")))
item)
(defn- target-append
[target key v]
(def item (gettarget target))
(def vals (get item key))
(unless (find |(= v $) vals)
(array/push vals v))
item)
(defn add-input
"Add a dependency to an existing rule. Useful for extending phony
rules or extending the dependency graph of existing rules."
[target input]
(target-append target :inputs input))
(defn add-dep
"Alias for `add-input`"
[target dep]
(target-append target :inputs dep))
(defn add-output
"Add an output file to an existing rule. Rules can contain multiple
outputs, but are still referred to by a main target name."
[target output]
(target-append target :outputs output))
(defn add-thunk
"Append a thunk to a target's recipe."
[target thunk]
(target-append target :recipe thunk))
(defn- rule-impl
[target deps thunk &opt phony]
(def targets (getrules))
(unless (get targets target)
(def new-rule
@{:task (if phony target)
:inputs @[]
:outputs @[]
:recipe @[]})
(put targets target new-rule))
(each d deps (add-input target d))
(unless phony
(add-output target target))
(add-thunk target thunk))
(defmacro rule
"Add a rule to the rule graph."
[target deps & body]
~(,rule-impl ,target ,deps (fn [] nil ,;body)))
(defmacro task
"Add a task rule to the rule graph. A task rule will always run if invoked
(it is always considered out of date)."
[target deps & body]
~(,rule-impl ,target ,deps (fn [] nil ,;body) true))
(defmacro phony
"Alias for `task`."
[target deps & body]
~(,rule-impl ,target ,deps (fn [] nil ,;body) true))
(defmacro sh-rule
"Add a rule that invokes a shell command, and fails if the command returns non-zero."
[target deps & body]
~(,rule-impl ,target ,deps (fn [] (,shutil/shell (,string ,;body)))))
(defmacro sh-task
"Add a task that invokes a shell command, and fails if the command returns non-zero."
[target deps & body]
~(,rule-impl ,target ,deps (fn [] (,shutil/shell (,string ,;body))) true))
(defmacro sh-phony
"Alias for `sh-task`."
[target deps & body]
~(,rule-impl ,target ,deps (fn [] (,shutil/shell (,string ,;body))) true))
(defmacro add-body
"Add recipe code to an existing rule. This makes existing rules do more but
does not modify the dependency graph."
[target & body]
~(,add-thunk ,target (fn [] ,;body)))

119
src/jpm/shutil.janet Normal file
View File

@ -0,0 +1,119 @@
###
### Utilties for running shell-like commands
###
(use ./config)
(defn is-win
"Check if we should assume a DOS-like shell or default
to posix shell."
[]
(dyn:use-batch-shell))
(defn find-manifest-dir
"Get the path to the directory containing manifests for installed
packages."
[]
(string (dyn:modpath) "/.manifests"))
(defn find-manifest
"Get the full path of a manifest file given a package name."
[name]
(string (find-manifest-dir) "/" name ".jdn"))
(defn find-cache
"Return the path to the global cache."
[]
(def path (dyn:modpath))
(string path "/.cache"))
(defn rm
"Remove a directory and all sub directories."
[path]
(case (os/lstat path :mode)
:directory (do
(each subpath (os/dir path)
(rm (string path "/" subpath)))
(os/rmdir path))
nil nil # do nothing if file does not exist
# Default, try to remove
(os/rm path)))
(defn rimraf
"Hard delete directory tree"
[path]
(if (is-win)
# windows get rid of read-only files
(when (os/stat path :mode)
(os/shell (string `rmdir /S /Q "` path `"`)))
(rm path)))
(defn clear-cache
"Clear the global git cache."
[]
(def cache (find-cache))
(print "clearing cache " cache "...")
(rimraf cache))
(defn clear-manifest
"Clear the global installation manifest."
[]
(def manifest (find-manifest-dir))
(print "clearing manifests " manifest "...")
(rimraf manifest))
(defn pslurp
"Like slurp, but with file/popen instead file/open. Also trims output"
[cmd]
(string/trim (with [f (file/popen cmd)] (:read f :all))))
(def path-splitter
"split paths on / and \\."
(peg/compile ~(any (* '(any (if-not (set `\/`) 1)) (+ (set `\/`) -1)))))
(defn create-dirs
"Create all directories needed for a file (mkdir -p)."
[dest]
(def segs (peg/match path-splitter dest))
(for i 1 (length segs)
(def path (string/join (slice segs 0 i) "/"))
(unless (empty? path) (os/mkdir path))))
(defn shell
"Do a shell command"
[& args]
(if (dyn :verbose)
(print ;(interpose " " args)))
(os/execute args :px))
(defn copy
"Copy a file or directory recursively from one location to another."
[src dest]
(print "copying " src " to " dest "...")
(if (is-win)
(let [end (last (peg/match path-splitter src))
isdir (= (os/stat src :mode) :directory)]
(shell "C:\\Windows\\System32\\xcopy.exe"
(string/replace "/" "\\" src) (string/replace "/" "\\" (if isdir (string dest "\\" end) dest))
"/y" "/s" "/e" "/i"))
(shell "cp" "-rf" src dest)))
(defn abspath
"Create an absolute path. Does not resolve . and .. (useful for
generating entries in install manifest file)."
[path]
(if (if (is-win)
(peg/match '(+ "\\" (* (range "AZ" "az") ":\\")) path)
(string/has-prefix? "/" path))
path
(string (os/cwd) "/" path)))
(def- filepath-replacer
"Convert url with potential bad characters into a file path element."
(peg/compile ~(% (any (+ (/ '(set "<>:\"/\\|?*") "_") '1)))))
(defn filepath-replace
"Remove special characters from a string or path
to make it into a path segment."
[repo]
(get (peg/match filepath-replacer repo) 0))

40
src/jpm/test/testmod.c Normal file
View File

@ -0,0 +1,40 @@
/*
* Copyright (c) 2021 Calvin Rose and contributors
*
* Permission is hereby granted, free of charge, to any person obtaining a copy
* of this software and associated documentation files (the "Software"), to
* deal in the Software without restriction, including without limitation the
* rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
* sell copies of the Software, and to permit persons to whom the Software is
* furnished to do so, subject to the following conditions:
*
* The above copyright notice and this permission notice shall be included in
* all copies or substantial portions of the Software.
*
* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
* IN THE SOFTWARE.
*/
/* A very simple native module */
#include <janet.h>
static Janet cfun_get_five(int32_t argc, Janet *argv) {
(void) argv;
janet_fixarity(argc, 0);
return janet_wrap_number(5.0);
}
static const JanetReg array_cfuns[] = {
{"get5", cfun_get_five, NULL},
{NULL, NULL, NULL}
};
JANET_MODULE_ENTRY(JanetTable *env) {
janet_cfuns(env, NULL, array_cfuns);
}