Commits

Moritz Heidkamp committed 1764f6e

initial commit

Comments (0)

Files changed (6)

+chicken-build
+chicken-select

chicken-belt.meta

+((synopsis "A utility belt for managing your Chicken coop")
+ (author "Christian Kellermann, Moritz Heidkamp")
+ (category tools)
+ (license "BSD")
+ (depends matchable))

chicken-belt.setup

+(compile chicken-select.scm)
+(compile chicken-build.scm)
+
+(install-program 
+ 'chicken-belt
+ '("chicken-select" "chicken-build")
+ '((version "0.0.1")))

chicken-build.scm

+#!/usr/bin/csi -s
+
+(use extras posix matchable)
+(include "chicken-env")
+
+(define (print-error msg . args)
+  (apply fprintf (current-error-port) msg args)
+  (newline (current-error-port)))
+
+(define (usage)
+  (fail "Usage: ~A [OPTION ...] NAME
+Build Chicken in current directory and install it to $CHICKENS/NAME.
+
+Options:
+  -b  build and use a bootstrap Chicken
+  -d  make a debug build
+  -s  use NAME as PROGRAM_SUFFIX
+  -p  use NAME as PORGRAM_PREFIX"
+        (program-name)))
+
+(define build-boot-chicken? #f)
+(define debug-build? #f)
+(define suffix-name? #f)
+(define prefix-name? #f)
+(define chicken-name #f)
+
+(when (null? (command-line-arguments))
+  (usage))
+
+(let loop ((args (command-line-arguments)))
+  (match args
+    (("-b" rest ...)
+     (set! build-boot-chicken? #t)
+     (loop rest))
+    (("-s" rest ...)
+     (set! suffix-name? #t)
+     (loop rest))
+    (("-p" rest ...)
+     (set! prefix-name? #t)
+     (loop rest))
+    (("-d" rest ...)
+     (set! debug-build? #t)
+     (loop rest))
+    ((name)
+     (set! chicken-name name))
+    (rest
+     (print-error "Invalid arguments: ~S" rest)
+     (usage))))
+
+(unless chicken-name
+  (usage))
+
+(when (and suffix-name? prefix-name?)
+  (fail "Only one of -p and -s can be passed"))
+
+(define chicken-path
+  (normalize-pathname (make-pathname chicken-coop chicken-name)))
+
+(define (run name . args)
+  (unless (process-wait (process-run name args))
+    (exit 1)))
+
+(when (file-exists? chicken-path)
+  (printf "Chicken already exists: ~A" chicken-path)
+  (if (yes-or-no? "Purge and continue?" #f #f exit)
+      (run "rm" "-rf" chicken-path)
+      (exit)))
+
+(create-directory chicken-path)
+
+(when build-boot-chicken?
+  (run "make" "boot-chicken")
+  (setenv "CHICKEN" "./chicken-boot"))
+
+(when prefix-name?
+  (setenv "PROGRAM_PREFIX" (string-append chicken-name "-")))
+
+(when suffix-name?
+  (setenv "PROGRAM_SUFFIX" (string-append "-" chicken-name)))
+
+(when debug-build?
+  (setenv "DEBUGBUILD" "1"))
+
+(setenv "PREFIX" chicken-path)
+(run "make")
+(run "make" "install")
+(use extras posix)
+
+(define chicken-coop (or (get-environment-variable "CHICKENS") "~/chickens"))
+(define chicken-link "use-this")
+
+(define (fail msg . args)
+  (apply fprintf (current-error-port) msg args)
+  (newline (current-error-port))
+  (exit 1))
+
+(unless (and (file-exists? chicken-coop) (directory? chicken-coop))
+  (fail "CHICKENS does not exist or is not a directory: ~S" chicken-coop))

chicken-select.scm

+#!/usr/bin/csi -s
+
+(use srfi-1 posix)
+(include "chicken-env")
+
+(define (available-chickens)
+  (filter (lambda (p) (not (equal? chicken-link p)))
+          (directory chicken-coop)))
+
+(define (current-chicken path link)
+  (let ((p (make-pathname path link)))
+    (and (symbolic-link? p)
+         (read-symbolic-link p))))
+
+(define (set-current-chicken chicken link)
+  (let ((symlink (make-pathname chicken-coop link)))
+    (when (file-exists? symlink)
+      (delete-file symlink))
+    (create-symbolic-link chicken symlink)))
+
+(let* ((all-chicks (available-chickens))
+       (current (list-index (cut equal? (current-chicken chicken-coop chicken-link) <>) all-chicks)))
+  (let select ((abort #f))
+    (if (equal? abort #\q)
+        (begin
+          (print "Aborted.")
+          (exit 0))
+        (begin
+          (print "Select a new Chicken, press 'q' to abort:")
+          (for-each (lambda (c n)
+                      (printf "~a ~a: ~a~%"
+                              (if (equal? n current) "*" " ")
+                              n c))
+                    all-chicks
+                    (iota (length all-chicks)))
+          (let* ((choice-raw (read-char))
+                 (num (string->number (string choice-raw))))
+            (if (and 
+                 num
+                 (<= 0 num)
+                 (< num (length all-chicks)))
+                (begin
+                  (print "Setting current Chicken to " (list-ref all-chicks num))
+                  (set-current-chicken (list-ref all-chicks
+                                                 num)
+                                       chicken-link))
+                (select choice-raw)))))))