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: -w binary ( member | -a archive | -A archive | -C dir )*
   6 ;;        -t binary
   7 ;;        -u binary directory
   8 ;;
   9 ;; The script processes the arguments from left to right to form then
  10 ;; named binary with the named members appended.
  11 ;;
  12 ;; Use '-a archive' to make the nominated ar style archive members
  13 ;; available subsequently for embedding.
  14 ;;
  15 ;; Use '-A archive' to embed all members of the nominated ar style
  16 ;; archive.
  17 ;;
  18 ;; Use '-C dir' to change source directory
  19 ;;
  20 ;; Use '-w' to overwrite an existing binary
  21
  22 ;; The first embedded member will be the "main script".
  23 ;;
  24
  25 (constant
  26  'OPTIONS
  27  '(("-w" ?) ; write new file
  28    ("-u" ? ?) ; unpack members to given directory
  29    ("-t" ?) ; merely list packed members of
  30    ))
  31
  32 (load "main-args.lsp")
  33
  34 (define (compile-file M (D (read-file M)))
  35   (unless D
  36     (write-line 2 (format "*** Cannot read %s .. aborting" M))
  37     (when (and (archives M) (not (ends-with (archives M) ".a")))
  38       (write-line 2 (format "*** (Archive filename %s must end with \".a\")"
  39                             (archives M))))
  40     (exit 1))
  41   (append-file BINARY (format "%s\n%d\n" M (length D)))
  42   (append-file BINARY D))
  43
  44 (define (compile-ar A M)
  45   (let ((MEMBERS (archive M)))
  46     (dolist (X MEMBERS)
  47       ;;(write-line 2 (format "including %s from %s" X M))
  48       (when (= A "-A") (compile-file X))
  49       )))
  50
  51 (define (compile BINARY MEMBERS)
  52   (unless (starts-with BINARY "/")
  53     (setf BINARY (format "%s/%s" (real-path) BINARY)))
  54   (write-file BINARY (0 archive:incore core)) ; includes the marker
  55   (exec (format "chmod a+x %s" BINARY))
  56   (let ((A nil) (C nil))
  57     (dolist (M MEMBERS)
  58       (case M
  59         ("-a" (setf A "-a"))
  60         ("-A" (setf A "-A"))
  61         ("-C" (setf C "-C"))
  62         (true (if A (compile-ar A M)
  63                 C (unless (change-dir M)
  64                     (write-line 2 (string "** directory is " (real-path)))
  65                     (write-line 2 (string "Cannot change to " M))
  66                     (exit 1))
  67                 (compile-file M))
  68               (setf A nil)
  69               (setf C nil)
  70               )))
  71     ))
  72
  73 (define (decompile BINARY DIR)
  74   (let ((D (read-file BINARY)))
  75     (when D
  76       (let ((P (find (dup "x" 40) D)))
  77         (when P
  78           (inc P 41)
  79           (while (regex "([^\n]+)\n([^\n]+)\n" D 0 P)
  80             (let ((N $1) (S (int $2)) (L (length $0)))
  81               (inc P L)
  82               (if DIR (write-file (string DIR "/" N) (P S D)) (println N))
  83               (inc P S))))))))
  84
  85 ;; clear the compiler archive index, to be used for source archives
  86 (dolist (M (map first (archives))) (archives M nil))
  87
  88 (when (or (!= 1 (length (clean null? OPTIONS)))
  89           (!= 2 (length ((clean null? OPTIONS) 0))))
  90   (write-line 2 "Please use one of -w -u or -t")
  91   (exit 1))
  92
  93 (cond
  94  ((OPTIONS 0) (compile (OPTIONS 0 1 0) ARGS))
  95  ((OPTIONS 1) (decompile (OPTIONS 1 1 0) (OPTIONS 1 1 1)))
  96  ((OPTIONS 2) (decompile (OPTIONS 2 1 0) nil)))
  97
  98 (exit 0)