packnl.lsp

   1 ;; Utility to "compile" a list of lsp files into a self-contained
   2 ;; binary, which is an embedded newlisp binary with the same embedding
   3 ;; script as binnl itself.
   4 ;;
   5 ;; Usage: [ -r ] binary ( -a archive | member )*
   6 ;;
   7 ;; The script processes the arguments from left to right to form then
   8 ;; named binary with the named members appended.
   9 ;;
  10 ;; Use '-a archive' to make the nominated ar style archive members
  11 ;; available subsequently for embedding.
  12 ;;
  13 ;; Use '-A archive' to embed all members of the nominated ar style
  14 ;; archive.
  15 ;;
  16 ;; Use '-r' to overwrite an existing binary
  17
  18 ;; The first embedded member will be the "main script".
  19 ;;
  20
  21 (constant
  22  'OPTIONS
  23  '(("-w" ?) ; write new file
  24    ("-u" ? ?) ; unpack members to given directory
  25    ("-t" ?) ; merely list packed members of
  26    ))
  27
  28 (load "main-args.lsp")
  29
  30 (define (compile-file M (D (read-file M)))
  31   (unless D
  32     (write-line 2 (format "*** Mising %s .. aborting" M))
  33     (exit 1))
  34   (append-file BINARY (format "%s\n%d\n" M (length D)))
  35   (append-file BINARY D))
  36
  37 (define (compile-ar A M)
  38   (let ((MEMBERS (archive M)))
  39     (if (= A "-A") (dolist (M MEMBERS) (compile-file M)))))
  40
  41 (define (compile BINARY MEMBERS)
  42   (write-file BINARY (0 archive:incore core)) ; includes the marker
  43   (exec (format "chmod a+x %s" BINARY))
  44   (let ((A nil))
  45     (dolist (M MEMBERS)
  46       ;;(write-line 1 (string "[" M "]" (archives)))
  47       (case M
  48         ("-a" (setf A "-a"))
  49         ("-A" (setf A "-A"))
  50         (true (if A (compile-ar A M) (compile-file M))
  51               (setf A nil))))
  52     ))
  53
  54 (define (decompile BINARY DIR)
  55   (let ((D (read-file BINARY)))
  56     (when D
  57       (let ((P (find (dup "x" 40) D)))
  58         (when P
  59           (inc P 41)
  60           (while (regex "([^\n]+)\n([^\n]+)\n" D 0 P)
  61             (let ((N $1) (S (int $2)) (L (length $0)))
  62               (inc P L)
  63               (if DIR (write-file (string DIR "/" N) (P S D)) (println N))
  64               (inc P S))))))))
  65
  66 ;; clear the compiler archive index, to be used for source archives
  67 (dolist (M (map first (archives))) (archives M nil))
  68
  69 (when (or (!= 1 (length (clean null? OPTIONS)))
  70           (!= 2 (length ((clean null? OPTIONS) 0))))
  71   (write-line 2 "Please use one of -w -u or -t")
  72   (exit 1))
  73
  74 (cond
  75  ((OPTIONS 0) (compile (OPTIONS 0 1 0) ARGS))
  76  ((OPTIONS 1) (decompile (OPTIONS 1 1 0) (OPTIONS 1 1 1)))
  77  ((OPTIONS 2) (decompile (OPTIONS 2 1 0) nil)))
  78
  79 (exit 0)