Add handling of tar archives. Improved documentation.

[rrq/newlisp/packnl.git] / incore.lsp

diff --git a/incore.lsp b/incore.lsp
index fb099516a7c83a9f2ea632c0539eab8862e86831..8f24187ef6b449daeaf2f27e404c40c80ed4aef4 100644 (file)
--- a/incore.lsp
+++ b/incore.lsp
@@ -19,36 +19,54 @@
 ;; Use (archive pathname) to register all members of the nominated ar
 ;; style archive.
 
 ;; Use (archive pathname) to register all members of the nominated ar
 ;; style archive.
 

+;; This is a hashmap of loaded files

 (new Tree 'archives)
 
 (new Tree 'archives)
 

-(define core:core (read-file (main-args 0)))
+;; A copy of the executable
+(define core:core (read-file "/proc/self/exe"))

 
 (context 'archive)
 
 (setf main nil)
 
 
 (context 'archive)
 
 (setf main nil)
 

-(constant 'AR "/usr/bin/ar")
+(constant 'AR "/usr/bin/ar" 'TAR "/bin/tar" 'FILE "/usr/bin/file")

 
 

+(define (tar-able PATH)
+  (when (file? FILE)
+    (if (exec (format "%s -Z %s" FILE PATH))
+        (find " tar archive" ($it 0)))))
+
+;; Install indexes for all members of the given archive file

 (define (archive:archive PATH)
   ;;(write-line 2 (string (list 'archive PATH)))
   (map (fn (F) (archives F PATH) F)
 (define (archive:archive PATH)
   ;;(write-line 2 (string (list 'archive PATH)))
   (map (fn (F) (archives F PATH) F)

-       (exec (format "%s t %s" AR PATH))))
+       (if (directory? PATH) (directory PATH "^[^.]")
+         (ends-with PATH ".a") (exec (format "%s t %s" AR PATH))
+         (tar-able PATH) (exec (format "%s tf %s" TAR PATH))
+         '()
+         )))

 
 

-(define (get-ar PATH MEMBER)
-  ;;(write-line 2 (string (list 'get-ar PATH MEMBER)))
+;; Read a member of an external archive
+(define (get-stdin CMD)

   (let ((I (pipe)) (O (pipe)) (DATA "") (ALL "")
         (SUB (fn (I O)
   (let ((I (pipe)) (O (pipe)) (DATA "") (ALL "")
         (SUB (fn (I O)

-               (close (I 1)) (close (O 0)) (close 0)
-               (process (format "%s p %s %s" AR PATH MEMBER) (I 0) (O 1)))))
+               (map close (list (I 1) (O 0) 0))
+               (process CMD (I 0) (O 1)))))

     (fork (SUB I O))
     (close (O 1)) (close (I 0)) (close (I 1))
     (while (> (or (read (O 0) DATA 1000000) 0)) (extend ALL DATA))
     (close (I 0))
     ALL))
 
     (fork (SUB I O))
     (close (O 1)) (close (I 0)) (close (I 1))
     (while (> (or (read (O 0) DATA 1000000) 0)) (extend ALL DATA))
     (close (I 0))
     ALL))
 

+;; Read an archive member. The given PATH is either a string path for
+;; an external archive file or the (position length) list for an
+;; incore packaged member.

 (define (get PATH MEMBER)
   (if (list? PATH) ((PATH 0) (PATH 1) core)
 (define (get PATH MEMBER)
   (if (list? PATH) ((PATH 0) (PATH 1) core)

-    (ends-with PATH ".a") (get-ar PATH MEMBER)))
+    (directory? PATH) (read-file (format "%s/%s" PATH MEMBER))
+    (ends-with PATH ".a") (get-stdin (format "%s p %s %s" AR PATH MEMBER))
+    (tar-able PATH) (get-stdin (format "%s xOf %s %s" TAR PATH MEMBER))
+    ))

 
 ;; Discover and load an in-core archive by means of a marker row of 40
 ;; "x", and then a series of pathname\nsize\nbytes[size] members.
 
 ;; Discover and load an in-core archive by means of a marker row of 40
 ;; "x", and then a series of pathname\nsize\nbytes[size] members.


@@ -67,15 +85,15 @@
 
 (constant
    'load
 
 (constant
    'load

-   (letex (LOAD load)
+   (letex ((LOAD load) (CTX '(or (and (1 (args)) (args 1)) MAIN)))

      (fn () (if (archives (args 0))
      (fn () (if (archives (args 0))

-                (eval-string (archive:get $it (args 0)) MAIN)
-              (LOAD (args 0)))))
+                (eval-string (archive:get $it (args 0)) CTX)
+              (LOAD (args 0) CTX))))

    'read-file
    (letex (READ-FILE read-file)
      (fn ()
        (if (archives (args 0)) (archive:get $it (args 0))
    'read-file
    (letex (READ-FILE read-file)
      (fn ()
        (if (archives (args 0)) (archive:get $it (args 0))

-              (READ-FILE (args 0)))))
+         (READ-FILE (args 0)))))

    'file?
    (letex (FILE? file?)
      (fn () (if (archives (args 0)) true (FILE? (args 0)))))
    'file?
    (letex (FILE? file?)
      (fn () (if (archives (args 0)) true (FILE? (args 0)))))