@@ -1,25 +1,34 @@

 ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Package: ASDF-USER -*-

 (in-package :asdf-user)

-(defsystem :cl-git 

-  :description ""

-  :author "Ed L <edward@elangley.org>"

-  :license "MIT"

-  :pathname #-fw.dev nil #+fw.dev #p"PROJECTS:cl-git;"

-  :depends-on (:alexandria

-               :chipz

-               :cl-dot

-               :data-lens

-               :fwoar-lisputils

-               :fwoar-lisputils/bin-parser

-               :ironclad

-               :serapeum

-               :split-sequence

-               :uiop)

-  :components ((:file "package")

-               (:file "util" :depends-on ("package"))

-               (:file "model" :depends-on ("package"))

-               (:file "extract" :depends-on ("package"))

-               (:file "branch" :depends-on ("package" "extract"))

-               (:file "git" :depends-on ("package" "util" "model" "branch"))

-               (:file "porcelain" :depends-on ("package" "git"))))

+(defsystem :cl-git

+    :description "A pure-Lisp git implementation"

+    :author "Ed L <edward@elangley.org>"

+    :license "MIT"

+    :pathname #-fw.dev nil #+fw.dev #p"PROJECTS:cl-git;"

+    :depends-on (:alexandria

+                 :chipz

+                 :cl-dot

+                 :data-lens

+                 :fwoar-lisputils

+                 :fwoar-lisputils/bin-parser

+                 :ironclad

+                 :serapeum

+                 :split-sequence

+                 :uiop)

+    :components ((:file "package")

+                 (:file "util" :depends-on ("package"))

+

+                 ;; data model

+                 (:file "model" :depends-on ("package"))

+                 (:file "protocol" :depends-on ("package" "model"))

+                 (:file "repository" :depends-on ("package" "model"))

+                 (:file "tree" :depends-on ("package" "model"))

+                 (:file "commit" :depends-on ("package" "model"))

+

+               (:file "extract" :depends-on ("package" "commit" "tree"))

+                 (:file "branch" :depends-on ("package" "extract"))

+                 (:file "git" :depends-on ("package" "util" "model" "branch"))

+

+                 ;; stable programmer interface

+                 (:file "porcelain" :depends-on ("package" "git" "commit"))))

new file mode 100644

@@ -0,0 +1,39 @@

+(in-package :fwoar.cl-git)

+

+(defclass git-commit ()

+  ((%metadata :initarg :metadata :reader metadata)

+   (%data :initarg :data :reader data)))

+

+(defun git-commit (metadata data)

+  (fw.lu:new 'git-commit metadata data))

+

+(defun parse-commit (commit)

+  (destructuring-bind (metadata message)

+      (partition-subseq #(#\newline #\newline)

+                        commit #+(or)(babel:octets-to-string commit :encoding :latin1))

+    (values message

+            (map 'vector (serapeum:op (partition #\space _))

+                 (fwoar.string-utils:split #\newline metadata)))))

+

+(defun make-commit (data)

+  (multiple-value-bind (message metadata)

+      (parse-commit data)

+    (git-commit metadata message)))

+

+(defmethod -extract-object-of-type ((type (eql :commit)) s repository &key)

+  (make-commit (babel:octets-to-string s :encoding *git-encoding*)))

+

+

+(defmethod component ((component (eql :tree)) (object git-commit))

+  (ensure-ref

+   (cadr

+    (fw.lu:v-assoc :tree (metadata object)

+                   :test 'string-equal))))

+(defmethod component ((component (eql :parents)) (object git-commit))

+  (coerce (remove-if-not (serapeum:op

+                           (string= "parent" _))

+                         (metadata object)

+                         :key #'car)

+          'list))

+(defmethod component ((component (eql :message)) (object git-commit))

+  (data object))

@@ -42,69 +42,29 @@

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

           (values pack mid))))))

-(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)))))

-

-(defun extract-object-of-type (type s repository)

-  (with-simple-restart (continue "Skip object of type ~s" type)

-    (%extract-object-of-type type s repository)))

-

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

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

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

-                            s

-                            repository))

-

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

-    s)

-

-  (:method ((type (eql :blob)) s repository)

-    s)

-

-  (:method ((type (eql :tag)) s repository)

-    s)

-

-  (:method ((type (eql :tree)) s repository)

-    (tree-entries s)))

-

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

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

+  (let* ((pos (file-position s))

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

          (type (object-type->sym (get-object-type metadata)))

          (size (get-object-size metadata))

          (decompressed (if (member type '(:ofs-delta :ref-delta))

-                           s

+                           (let ((buffer (make-array size :element-type '(unsigned-byte 8))))

+                             (read-sequence buffer s)

+                             buffer)

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

-         (object-data (extract-object-of-type type decompressed repository)))

+         (object-data (extract-object-of-type type decompressed repository pos)))

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

           (cons :decompressed-size size)

           (cons :object-data object-data)

           (cons :raw-data object-data))))

+(defun extract-object-of-type (type s repository pos)

+  (with-simple-restart (continue "Skip object of type ~s" type)

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

+                             s

+                             repository

+                             :offset-from pos)))

+

 (defun extract-object-from-pack (pack obj-number)

   (with-open-file (s (index-file pack) :element-type '(unsigned-byte 8))

     (with-open-file (p (pack-file pack) :element-type '(unsigned-byte 8))

@@ -115,20 +75,6 @@

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

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

-(defun root-of (repo)

-  (typecase repo

-    (repository (root repo))

-    ((or pathname string) (namestring

-                           (truename repo)))))

-

-(defun object (repo id)

-  (let ((repo-root (root-of repo)))

-    (or (alexandria:when-let ((object-file (loose-object repo id)))

-          (make-instance 'loose-object :repo repo-root :hash id :file object-file))

-        (multiple-value-bind (pack offset) (find-object-in-pack-files repo-root id)

-          (when pack

-            (make-instance 'packed-object :hash id :repo repo-root :offset offset :pack pack))))))

-

 (defun extract-loose-object (repo file)

   (with-open-file (s file :element-type '(unsigned-byte 8))

     (alexandria:when-let ((result (chipz:decompress nil (chipz:make-dstate 'chipz:zlib)

@@ -138,20 +84,14 @@

         (extract-object-of-type (object-type->sym (babel:octets-to-string type))

                                 (elt (partition 0 rest)

                                      1)

-                                repo)))))

-

-(defgeneric extract-object-next (object)

-  (:method ((object loose-object))

-    (extract-loose-object (object-repo object)

-                          (loose-object-file object)))

-  (:method ((object packed-object))

+                                repo

+                                0)))))

+

+(defgeneric extract-object (object)

+  (:method ((object loose-ref))

+    (extract-loose-object (ref-repo object)

+                          (loose-ref-file object)))

+  (:method ((object packed-ref))

     (data-lens.lenses:view *object-data-lens*

-                           (extract-object-from-pack (packed-object-pack object)

-                                                     (packed-object-offset object)))))

-

-(defun extract-object (repo id)

-  (if (loose-object-p repo id)

-      (extract-loose-object repo (loose-object repo id))

-      (data-lens.lenses:view *object-data-lens*

-                             (multiple-value-call 'extract-object-from-pack 

-                               (find-object-in-pack-files (root repo) id)))))

+                           (extract-object-from-pack (packed-ref-pack object)

+                                                     (packed-ref-offset object)))))

@@ -14,9 +14,6 @@

 (defclass git-object ()

   ())

-(defclass commit (git-object)

-  ())

-

 (defgeneric object-type->sym (object-type)

   (:method ((o-t symbol))

     o-t))

@@ -29,6 +26,7 @@

     (4 :tag)

     (6 :ofs-delta)

     (7 :ref-delta)))

+

 (defmethod object-type->sym ((object-type string))

   (string-case:string-case ((string-downcase object-type))

     ("commit" :commit)

@@ -82,19 +80,19 @@

   "Is ID an ID of a loose object?"

   (loose-object repository id))

-(defclass git-object ()

-  ((%repo :initarg :repo :reader object-repo)

-   (%hash :initarg :hash :reader object-hash)))

-(defclass loose-object (git-object)

-  ((%file :initarg :file :reader loose-object-file)))

-(defclass packed-object (git-object)

-  ((%pack :initarg :pack :reader packed-object-pack)

-   (%offset :initarg :offset :reader packed-object-offset)))

-

-(defmethod print-object ((obj git-object) s)

+(defclass git-ref ()

+  ((%repo :initarg :repo :reader ref-repo)

+   (%hash :initarg :hash :reader ref-hash)))

+(defclass loose-ref (git-ref)

+  ((%file :initarg :file :reader loose-ref-file)))

+(defclass packed-ref (git-ref)

+  ((%pack :initarg :pack :reader packed-ref-pack)

+   (%offset :initarg :offset :reader packed-ref-offset)))

+

+(defmethod print-object ((obj git-ref) s)

   (print-unreadable-object (obj s :type t)

     (format s "~a of ~a"

-            (subseq (object-hash obj) 0 7)

+            (subseq (ref-hash obj) 0 7)

             (serapeum:string-replace (namestring (user-homedir-pathname))

-                                     (root-of (object-repo obj))

+                                     (root-of (ref-repo obj))

                                      "~/"))))

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

 (defpackage :git

   (:use)

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

-           #:current-repository #:show-repository #:git #:tree #:contents))

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

+           #:tree #:contents #:component))

new file mode 100644

@@ -0,0 +1,18 @@

+(in-package :fwoar.cl-git)

+

+(defgeneric -extract-object-of-type (type s repository &key &allow-other-keys)

+  (:method ((type (eql :blob)) s repository &key)

+    s)

+

+  (:method ((type (eql :tag)) s repository &key)

+    s))

+

+(defgeneric component (component object)

+  (:argument-precedence-order object component)

+  (:method (component (object git-ref))

+    (component component (extract-object object)))

+  (:method ((component sequence) object)

+    (reduce (lambda (cur next)

+              (component next cur))

+            component

+            :initial-value object)))

new file mode 100644

@@ -0,0 +1,22 @@

+(in-package :fwoar.cl-git)

+

+(defun root-of (repo)

+  (typecase repo

+    (repository (root repo))

+    ((or pathname string) (namestring

+                           (truename repo)))))

+

+(defun ref (repo id)

+  (let ((repo-root (root-of repo)))

+    (or (alexandria:when-let ((object-file (loose-object repo id)))

+          (make-instance 'loose-ref

+                         :repo repo-root

+                         :hash id

+                         :file object-file))

+        (multiple-value-bind (pack offset) (find-object-in-pack-files repo-root id)

+          (when pack

+            (make-instance 'packed-ref

+                           :hash id

+                           :repo repo-root

+                           :offset offset

+                           :pack pack))))))

new file mode 100644

@@ -0,0 +1,66 @@

+(in-package :fwoar.cl-git)

+

+(defclass git-tree (git-object)

+  ((%entries :initarg :entries :reader entries)))

+

+(defun git-tree (entries)

+  (fw.lu:new 'git-tree entries))

+

+(defclass tree-entry ()

+  ((%mode :initarg :mode :reader te-mode)

+   (%name :initarg :name :reader te-name)

+   (%hash :initarg :hash :reader te-hash)))

+

+(defun tree-entry (name mode hash)

+  (fw.lu:new 'tree-entry name mode hash))

+

+(defmethod print-object ((o tree-entry) s)

+  (if *print-readably*

+      (format s "#.(~s ~s ~s ~s)"

+              'tree-entry

+              (te-name o)

+              (te-mode o)

+              (te-hash o))

+      (print-unreadable-object (o s :type t :identity t)

+        (format s "(~a: ~a)"

+                (te-name o)

+                (subseq (te-hash o) 0 7)))))

+

+(defun parse-tree-entry (data)

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

+

+(defun format-tree-entry (entry)

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

+    (destructuring-bind (mode name) (partition #\space

+                                               (babel:octets-to-string info :encoding *git-encoding*))

+      (tree-entry name mode (elt (->sha-string sha) 0)))))

+

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

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

+      (nreverse accum)

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

+        (tree-entries rest

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

+                             accum)))))

+

+(defmethod -extract-object-of-type ((type (eql :tree)) s repository &key)

+  (git-tree (tree-entries s)))

+

+(defmethod component ((component (eql :entries)) (object git-tree))

+  (entries object))

+(defmethod component ((component string) (object git-tree))

+  (remove component (entries object)

+          :test-not #'equal

+          :key 'te-name))

+(defmethod component ((component pathname) (object git-tree))

+  (remove-if-not (lambda (it)

+                   (pathname-match-p it component))

+                 (entries object)

+                 :key 'te-name))

+

+(defmethod component ((component (eql :name)) (object tree-entry))

+  (te-name object))

+(defmethod component ((component (eql :mode)) (object tree-entry))

+  (te-mode object))

+(defmethod component ((component (eql :hash)) (object tree-entry))

+  (te-hash object))

@@ -72,10 +72,6 @@

               (list type

                     (parse-integer length))))))

-(defun parse-commit (commit)

-  (destructuring-bind (metadata message)

-      (partition-subseq #(#\newline #\newline)

-                        commit #+(or)(babel:octets-to-string commit :encoding :latin1))

-    (values message

-            (map 'vector (serapeum:op (partition #\space _))

-                 (fwoar.string-utils:split #\newline metadata)))))

+(defun behead (data)

+  (elt (partition 0 data)

+       1))