@@ -42,18 +42,55 @@

         (return-from find-object-in-pack-files

           (values pack mid))))))

-(defgeneric extract-object-of-type (type s)

-  (:method ((type integer) s)

+(defun behead (data)

+  (elt (partition 0 data)

+       1))

+

+(defun tree-entry (data)

+  (values-list (partition 0 data :with-offset 20)))

+

+(defun format-tree-entry (entry)

+  (destructuring-bind (info sha) (partition 0 entry)

+    (concatenate 'vector

+                 (apply #'concatenate 'vector

+                        (serapeum:intersperse (vector (char-code #\tab))

+                                              (reverse

+                                               (partition (char-code #\space)

+                                                          info))))

+                 (list (char-code #\tab))

+                 (babel:string-to-octets (elt (->sha-string sha) 0) :encoding *git-encoding*))))

+

+(defun tree-entries (data &optional accum)

+  (if (<= (length data) 0)

+      (apply #'concatenate 'vector

+             (serapeum:intersperse (vector (char-code #\newline))

+                                   (nreverse accum)))

+      (multiple-value-bind (next rest) (tree-entry data) 

+        (tree-entries rest

+                      (list* (format-tree-entry next)

+                             accum)))))

+

+(defgeneric extract-object-of-type (type s repository)

+  (:method ((type integer) s repository)

     (extract-object-of-type (object-type->sym type)

-                            s))

-  (:method ((type (eql :commit)) (s stream))

-    (chipz:decompress nil (chipz:make-dstate 'chipz:zlib) s)))

+                            s

+                            repository))

+

+  (:method ((type (eql :commit)) (s stream) repository)

+    (chipz:decompress nil (chipz:make-dstate 'chipz:zlib) s))

+

+  (:method ((type (eql :blob)) (s stream) repository)

+    (chipz:decompress nil (chipz:make-dstate 'chipz:zlib) s))

+

+  (:method ((type (eql :tree)) (s stream) repository)

+    (let* ((data (chipz:decompress nil (chipz:make-dstate 'chipz:zlib) s)))

+      (tree-entries data))))

-(defun read-object-from-pack (s)

+(defun read-object-from-pack (s repository)

   (let* ((metadata (fwoar.bin-parser:extract-high s))

          (type (get-object-type metadata))

          (size (get-object-size metadata))

-         (object-data (extract-object-of-type type s)))

+         (object-data (extract-object-of-type type s repository)))

     (list (cons :type (object-type->sym type))

           (cons :decompressed-size size)

           (cons :object-data object-data)

@@ -67,7 +104,7 @@

         (file-position s (+ offset-offset (* 4 obj-number)))

         (let ((object-offset-in-pack (read-bytes 4 'fwoar.bin-parser:be->int s)))

           (file-position p object-offset-in-pack)

-          (read-object-from-pack p))))))

+          (read-object-from-pack p (repository pack)))))))

 (defun extract-loose-object (repo id)

   (with-open-file (s (object repo id)

@@ -21,6 +21,8 @@

   (fw.lu:new 'git-graph repo))

 (defun get-commit-parents (repository commit)

+  #+lispworks

+  (declare (notinline mismatch serapeum:string-prefix-p))

   (map 'list 

        (serapeum:op (second (partition #\space _)))

        (remove-if-not (lambda (it)

@@ -5,7 +5,8 @@

 (defclass pack ()

   ((%pack :initarg :pack :reader pack-file)

-   (%index :initarg :index :reader index-file)))

+   (%index :initarg :index :reader index-file)

+   (%repository :initarg :repository :reader repository)))

 (defclass repository ()

   ((%root :initarg :root :reader root)))

@@ -25,8 +26,11 @@

     (6 :ofs-delta)

     (7 :ref-delta)))

-(defun repository (root)

-  (fw.lu:new 'repository root))

+(defgeneric repository (root)

+  (:method ((root string))

+   (fw.lu:new 'repository root))

+  (:method ((root pathname))

+   (fw.lu:new 'repository root)))

 (defun get-local-branches (root)

   (append (get-local-unpacked-branches root)

@@ -36,11 +40,12 @@

   (let ((obj-path (fwoar.string-utils:insert-at 2 #\/ sha)))

     (merge-pathnames obj-path ".git/objects/")))

-(defun pack (index pack)

-  (fw.lu:new 'pack index pack))

+(defun pack (index pack repository)

+  (fw.lu:new 'pack index pack repository))

 (defun pack-files (repo)

-  (mapcar 'pack

+  (mapcar (serapeum:op

+            (pack _ _ (repository repo)))

           (uiop:directory*

            (merge-pathnames ".git/objects/pack/*.idx"

                             repo))

@@ -10,4 +10,4 @@

 (defpackage :git

   (:use)

   (:export #:show #:branch #:branches #:commit-parents #:in-repository

-           #:current-repository #:show-repository))

+           #:current-repository #:show-repository #:git))

@@ -12,13 +12,34 @@

 (defun git:show-repository ()

   *git-repository*)

+(defmacro git:git (&rest commands)

+  `(uiop:nest ,@(reverse

+                 (mapcar (serapeum:op (case (car _1)

+                                        ((<<=) (list* 'mapcan

+                                                      (list 'quote

+                                                            (intern (symbol-name (cadadr _1))

+                                                                    :git))

+                                                      (cddr _1)))

+                                        ((map) (list* 'mapcar

+                                                      (list 'quote

+                                                            (intern (symbol-name (cadadr _1))

+                                                                    :git))

+                                                      (cddr _1)))

+                                        (t (cons (intern (symbol-name (car _1))

+                                                         :git)

+                                                 (cdr _1)))))

+                         commands))))

+

 (defun git:show (object)

   (babel:octets-to-string

-   (extract-object (repository *git-repository*)

-                   object)

+   (coerce (extract-object (repository *git-repository*)

+                           object)

+           '(vector serapeum:octet))

    :encoding *git-encoding*))

 (defun git:branch (&optional (branch "master"))

+  #+lispworks

+  (declare (notinline serapeum:assocadr))

   (let ((branches (branches (repository *git-repository*))))

     (nth-value 0 (serapeum:assocadr branch branches

                                     :test 'equal))))

@@ -28,11 +28,14 @@

     (inspect- *trace-output*

               (apply fn args))))

-(defun partition (char string &key from-end)

+(defun partition (char string &key from-end (with-offset nil wo-p))

   (let ((pos (position char string :from-end from-end)))

     (if pos

-        (list (subseq string 0 pos)

-              (subseq string (1+ pos)))

+        (if wo-p 

+            (list (subseq string 0 (+ pos with-offset 1))

+                  (subseq string (+ pos 1 with-offset)))

+            (list (subseq string 0 pos)

+                  (subseq string (1+ pos))))

       (list string

             nil))))