incore.lsp

   1 ;; This code is intended for an embedded binary with an "archive" of
   2 ;; files appended to it. The appended archive is marked by a array of
   3 ;; 40 "x", and consists by archive elements the format of
   4 ;; "pathname\nsize\nbytes[size]".
   5 ;;
   6 ;; When there is an in-core archive, then the first member will be
   7 ;; invoked as "main script".
   8 ;;
   9 ;; archives:archives is a hashmap for loadable files
  10 ;; core:core is the running binary file
  11 ;;
  12 ;; The "archive" context holds utility code.
  13 ;; archive:main is the name of the first in-core member.
  14 ;; archive:incore is the byte position into core for the archive.
  15 ;;
  16 ;; Use (archives member pathname) to register that the file "member"
  17 ;; should be looked up in the ar style archive of the given pathname.
  18 ;;
  19 ;; Use (archive pathname) to register all members of the nominated ar
  20 ;; style archive.
  21
  22 ;; This is a hashmap of loaded files
  23 (new Tree 'archives)
  24
  25 ;; A copy of the executable (file descriptor 3)
  26 (define core:core
  27   (letn ((FD 3) (SZ (seek FD)) (BUFFER (dup "" SZ)))
  28     (seek FD 0) (read FD BUFFER SZ) BUFFER))
  29 (map delete '(FD SZ BUFFER GNU GNU))
  30
  31 (context 'archive)
  32 (setf main nil)
  33 (constant
  34  'AR "/usr/bin/ar"
  35  'TAR (exists file? '("/bin/tar" "/usr/bin/tar"))
  36  'FILE "/usr/bin/file" )
  37
  38 (define (tar-able PATH)
  39   (when (file? FILE)
  40     (if (exec (format "%s -Z %s" FILE PATH))
  41         (find " tar archive" ($it 0)))))
  42
  43 ;; Install indexes for all members of the given archive file
  44 (define (archive:archive PATH)
  45   ;;(write-line 2 (string (list 'archive PATH)))
  46   (map (fn (F) (archives F PATH) F)
  47        (if (directory? PATH) (directory PATH "^[^.]")
  48          (ends-with PATH ".a") (exec (format "%s t %s" AR PATH))
  49          (tar-able PATH) (exec (format "%s tf %s" TAR PATH))
  50          '()
  51          )))
  52
  53 ;; Read a member of an external archive
  54 (define (get-stdout CMD)
  55   (let ((I (pipe)) (O (pipe)) (DATA "") (ALL "")
  56         (SUB (fn (I O)
  57                (map close (list (I 1) (O 0) 0))
  58                (process CMD (I 0) (O 1)))))
  59     (fork (SUB I O))
  60     (close (O 1)) (close (I 0)) (close (I 1))
  61     (while (> (or (read (O 0) DATA 1000000) 0)) (extend ALL DATA))
  62     (close (I 0))
  63     ALL))
  64
  65 ;; Read an archive member. The given PATH is either a string path for
  66 ;; an external archive file or the (position length) list for an
  67 ;; incore packaged member.
  68 (define (get PATH MEMBER)
  69   (if (list? PATH) ((PATH 0) (PATH 1) core)
  70     (directory? PATH) (read-file (format "%s/%s" PATH MEMBER))
  71     (ends-with PATH ".a") (get-stdout (format "%s p %s %s" AR PATH MEMBER))
  72     (tar-able PATH) (get-stdout (format "%s xOf %s %s" TAR PATH MEMBER))
  73     ))
  74
  75 ;; Discover and load an in-core archive by means of a marker row of 40
  76 ;; "x", and then a series of pathname\nsize\nbytes[size] members.
  77 (if (find (dup "x" 40) core nil 300000)
  78     (let ((P (+ $it 41))) ; skip marker and newline
  79       (constant 'incore P)
  80       (while (regex "([^\n]+)\n([^\n]+)\n" core 0 P)
  81         (let ((N $1) (S (int $2)) (L (length $0)))
  82           (inc P L)
  83           (unless main (setf main N))
  84           (archives N (list P S))
  85           (inc P S))))
  86   (write-line 2 (string "not packed")))
  87
  88 (context MAIN)
  89
  90 (constant
  91    'load
  92    (letex ((LOAD load) (CTX '(if (1 (args)) (args 1) MAIN)))
  93      (fn () (if (archives (args 0))
  94                 (eval-string (archive:get $it (args 0)) CTX)
  95               (LOAD (args 0) (eval CTX)))))
  96    'read-file
  97    (letex ((READ-FILE read-file) (CTX '(if (1 (args)) (args 1) MAIN)))
  98      (fn ()
  99        (if (archives (args 0)) (archive:get $it (args 0) CTX)
 100          (READ-FILE (args 0)))))
 101    'file?
 102    (letex ((FILE? file?))
 103      (fn () (if (archives (args 0)) true (FILE? (args 0)))))
 104    )
 105
 106 (when archive:main (load archive:main) (exit 0))