git.fiddlerwoaroof.com
Browse code

refactor: use the pack CLOS object more

Edward Langley authored on 31/10/2023 05:25:48
Showing 8 changed files
... ...
@@ -20,9 +20,10 @@
20 20
                :serapeum
21 21
                :split-sequence
22 22
                :uiop)
23
-  :in-order-to ((test-op (test-op :data-lens/test)))
23
+  :in-order-to ((test-op (test-op :co.fwoar.cl-git/tests)))
24 24
   :components ((:file "package")
25
-               (:file "util" :depends-on ("package"))
25
+               (:file "types" :depends-on ("package"))
26
+               (:file "util" :depends-on ("types" "package"))
26 27
 
27 28
                ;; data model
28 29
                (:file "model" :depends-on ("package"))
... ...
@@ -34,7 +35,7 @@
34 35
 
35 36
                (:file "extract" :depends-on ("package" "protocol" "commit" "tree" "delta"))
36 37
                (:file "branch" :depends-on ("package" "extract"))
37
-               (:file "git" :depends-on ("package" "util" "model" "branch"))
38
+               (:file "git" :depends-on ("package" "types" "util" "model" "branch"))
38 39
 
39 40
                ;; stable programmer interface
40 41
                (:file "porcelain" :depends-on ("package" "git" "commit"))))
... ...
@@ -4,6 +4,12 @@
4 4
   ((%metadata :initarg :metadata :reader metadata)
5 5
    (%data :initarg :data :reader data)))
6 6
 
7
+(defun git-commit (hash metadata data)
8
+  (fw.lu:new 'git-commit hash metadata data))
9
+
10
+(defun clamp-string (s len)
11
+  (subseq s 0 (min len (length s))))
12
+
7 13
 (defmethod print-object ((o git-commit) s)
8 14
   (if *print-readably*
9 15
       (format s "#.(git-commit ~<~s~_~s~_~s~:>)"
... ...
@@ -11,10 +17,7 @@
11 17
                     (metadata o)
12 18
                     (data o)))
13 19
       (print-unreadable-object (o s :type t :identity t)
14
-        (format s "~a" (subseq (hash o) 0 6)))))
15
-
16
-(defun git-commit (hash metadata data)
17
-  (fw.lu:new 'git-commit hash metadata data))
20
+        (format s "~a" (format nil "~7,1,1,'x@a" (clamp-string (hash o) 7))))))
18 21
 
19 22
 (defun parse-commit (commit)
20 23
   (destructuring-bind (metadata message)
... ...
@@ -25,11 +25,11 @@
25 25
                (find-sha-between-terms toc s (1+ mid) end sha))
26 26
               (t (values mid sha-at-mid)))))))
27 27
 
28
-(defun find-pack-containing (pack-file id)
28
+(defun find-sha-in-pack (pack-file id)
29 29
   (with-open-file (s (index-file pack-file)
30 30
                      :element-type '(unsigned-byte 8))
31 31
     (let ((binary-sha (ironclad:hex-string-to-byte-array id))
32
-          (toc (idx-toc s)))
32
+          (toc (idx-toc pack-file)))
33 33
       (multiple-value-bind (_ end) (edges-in-fanout toc s binary-sha)
34 34
         (declare (ignore _))
35 35
         (multiple-value-bind (midpoint sha)
... ...
@@ -41,7 +41,7 @@
41 41
 
42 42
 (defun find-object-in-pack-files (repo id)
43 43
   (dolist (pack-file (pack-files repo))
44
-    (multiple-value-bind (pack mid sha) (find-pack-containing pack-file id)
44
+    (multiple-value-bind (pack mid sha) (find-sha-in-pack pack-file id)
45 45
       (when pack
46 46
         (return-from find-object-in-pack-files
47 47
           (values pack mid sha))))))
... ...
@@ -86,14 +86,18 @@
86 86
                            (repository pack)
87 87
                            ref)))
88 88
 
89
+(defun read-4-byte-offset (pack obj-number)
90
+  (with-pack-streams (s _) pack
91
+    (file-position s
92
+                   (pack-offset-for-object (idx-toc pack)
93
+                                           obj-number))
94
+    (read-bytes 4 'fwoar.bin-parser:be->int s)))
95
+
89 96
 (defun extract-object-from-pack (pack obj-number ref)
90
-  (with-open-file (s (index-file pack) :element-type '(unsigned-byte 8))
91
-    (file-position s (pack-offset-for-object (idx-toc s)
92
-                                             obj-number))
93
-    (let ((object-offset-in-pack (read-bytes 4 'fwoar.bin-parser:be->int s)))
94
-      (extract-object-at-pos pack
95
-                             object-offset-in-pack
96
-                             ref))))
97
+  (let ((object-offset-in-pack (read-4-byte-offset pack obj-number)))
98
+    (extract-object-at-pos pack
99
+                           object-offset-in-pack
100
+                           ref)))
97 101
 
98 102
 (defun extract-loose-object (repo file ref)
99 103
   (with-open-file (s file :element-type '(unsigned-byte 8))
... ...
@@ -1,26 +1,21 @@
1 1
 (in-package :fwoar.cl-git)
2 2
 
3
-(defun seek-to-object-in-pack (idx-stream pack-stream obj-number)
4
-  (let* ((toc (idx-toc idx-stream))
3
+(defmacro with-pack-streams ((idx-sym pack-sym) pack &body body)
4
+  (alexandria:once-only (pack)
5
+    `(with-open-file (,idx-sym (index-file ,pack) :element-type 'fwoar.cl-git.types:octet)
6
+       (with-open-file (,pack-sym (pack-file ,pack) :element-type 'fwoar.cl-git.types:octet)
7
+         ,@body))))
8
+
9
+(defun seek-to-object-in-pack (pack idx-stream pack-stream obj-number)
10
+  (let* ((toc (idx-toc pack))
5 11
          (offset-offset (getf toc :4-byte-offsets)))
6 12
     (file-position idx-stream (+ offset-offset (* 4 obj-number)))
7 13
     (let ((object-offset-in-pack (read-bytes 4 'fwoar.bin-parser:be->int idx-stream)))
8 14
       (file-position pack-stream object-offset-in-pack))))
9 15
 
10
-(deftype octet ()
11
-  '(unsigned-byte 8))
12
-
13
-(defmacro with-open-files* ((&rest bindings) &body body)
14
-  `(uiop:nest ,@(mapcar (serapeum:op
15
-                          `(with-open-file ,_1))
16
-                        bindings)
17
-              (progn
18
-                ,@body)))
19
-
20 16
 (defun extract-object-metadata-from-pack (pack obj-number)
21
-  (with-open-files* ((s (index-file pack) :element-type 'octet)
22
-                     (p (pack-file pack) :element-type 'octet))
23
-    (seek-to-object-in-pack s p obj-number)
17
+  (with-pack-streams (s p) pack
18
+    (seek-to-object-in-pack pack s p obj-number)
24 19
     (read-object-metadata-from-pack p)))
25 20
 
26 21
 (defun turn-read-object-to-string (object)
... ...
@@ -67,38 +62,40 @@
67 62
   (fwoar.bin-parser:extract '((offset 4 fwoar.bin-parser:be->int))
68 63
                             s))
69 64
 
70
-(defun idx-toc (idx-stream)
71
-  (let* ((object-count (progn (file-position idx-stream 1028)
72
-                              (let ((buf (make-array 4)))
73
-                                (read-sequence buf idx-stream)
74
-                                (fwoar.bin-parser:be->int buf))))
75
-         (signature 0)
76
-         (version 4)
77
-         (fanout 8)
78
-         (shas (+ fanout
79
-                  #.(* 4 256)))
80
-         (packed-crcs (+ shas
81
-                         (* 20 object-count)))
82
-         (4-byte-offsets (+ packed-crcs
83
-                            (* 4 object-count)))
84
-         (8-byte-offsets-pro (+ 4-byte-offsets
85
-                                (* object-count 4)))
86
-         (pack-sha (- (file-length idx-stream)
87
-                      40))
88
-         (8-byte-offsets (when (/= 8-byte-offsets-pro pack-sha)
89
-                           8-byte-offsets-pro))
90
-         (idx-sha (- (file-length idx-stream)
91
-                     20)))
92
-    (values (sym->plist signature
93
-                        version
94
-                        fanout
95
-                        shas
96
-                        packed-crcs
97
-                        4-byte-offsets
98
-                        8-byte-offsets
99
-                        pack-sha
100
-                        idx-sha)
101
-            object-count)))
65
+(defgeneric idx-toc (pack)
66
+  (:method ((pack pack))
67
+    (with-pack-streams (idx-stream _) pack
68
+      (let* ((object-count (progn (file-position idx-stream 1028)
69
+                                  (let ((buf (make-array 4)))
70
+                                    (read-sequence buf idx-stream)
71
+                                    (fwoar.bin-parser:be->int buf))))
72
+             (signature 0)
73
+             (version 4)
74
+             (fanout 8)
75
+             (shas (+ fanout
76
+                      #.(* 4 256)))
77
+             (packed-crcs (+ shas
78
+                             (* 20 object-count)))
79
+             (4-byte-offsets (+ packed-crcs
80
+                                (* 4 object-count)))
81
+             (8-byte-offsets-pro (+ 4-byte-offsets
82
+                                    (* object-count 4)))
83
+             (pack-sha (- (file-length idx-stream)
84
+                          40))
85
+             (8-byte-offsets (when (/= 8-byte-offsets-pro pack-sha)
86
+                               8-byte-offsets-pro))
87
+             (idx-sha (- (file-length idx-stream)
88
+                         20)))
89
+        (values (sym->plist signature
90
+                            version
91
+                            fanout
92
+                            shas
93
+                            packed-crcs
94
+                            4-byte-offsets
95
+                            8-byte-offsets
96
+                            pack-sha
97
+                            idx-sha)
98
+                object-count)))))
102 99
 
103 100
 (defun collect-data (idx-toc s num)
104 101
   (let ((sha-idx (getf idx-toc :shas))
... ...
@@ -125,15 +122,16 @@
125 122
     (values (cons :type type)
126 123
             (cons :decompressed-size size))))
127 124
 
128
-(defun get-first-commits-from-pack (idx pack n)
129
-  (let ((toc (idx-toc idx))
125
+(defun get-first-commits-from-pack (pack n)
126
+  (let ((toc (idx-toc pack))
130 127
         (result ()))
131
-    (dotimes (i n (reverse result))
132
-      (multiple-value-bind (_ sha __ offset) (collect-data toc idx i)
133
-        (declare (ignore _ __))
134
-        (file-position pack offset)
135
-        (push `((:sha . ,sha)
136
-                ,@(multiple-value-list
137
-                   (read-object-metadata-from-pack pack))
138
-                (:offset . ,offset))
139
-              result)))))
128
+    (with-pack-streams (idx pack-s) pack
129
+      (dotimes (i n (reverse result))
130
+        (multiple-value-bind (_ sha __ offset) (collect-data toc idx i)
131
+          (declare (ignore _ __))
132
+          (file-position pack-s offset)
133
+          (push `((:sha . ,sha)
134
+                  ,@(multiple-value-list
135
+                     (read-object-metadata-from-pack pack-s))
136
+                  (:offset . ,offset))
137
+                result))))))
... ...
@@ -7,6 +7,11 @@
7 7
    #:repository
8 8
    #:component))
9 9
 
10
+(defpackage :fwoar.cl-git.types
11
+  (:use :cl )
12
+  (:export
13
+   #:octet))
14
+
10 15
 (defpackage :cl-git-user
11 16
   (:use :cl :fwoar.cl-git))
12 17
 
... ...
@@ -20,11 +20,11 @@
20 20
               'tree-entry
21 21
               (te-name o)
22 22
               (te-mode o)
23
-              (te-hash o))
23
+              (hash o))
24 24
       (print-unreadable-object (o s :type t :identity t)
25 25
         (format s "(~a: ~a)"
26 26
                 (te-name o)
27
-                (subseq (te-hash o) 0 7)))))
27
+                (subseq (hash o) 0 7)))))
28 28
 
29 29
 (defun parse-tree-entry (data)
30 30
   (values-list (partition 0 data :with-offset 20)))
... ...
@@ -66,4 +66,4 @@
66 66
   (te-mode object))
67 67
 (defmethod component ((component (eql :ref)) (object tree-entry))
68 68
   (ref (repository object)
69
-       (te-hash object)))
69
+       (hash object)))
70 70
new file mode 100644
... ...
@@ -0,0 +1,4 @@
1
+(in-package :fwoar.cl-git.types)
2
+
3
+(deftype octet ()
4
+  '(unsigned-byte 8))
... ...
@@ -66,7 +66,7 @@
66 66
                  'batch-20))
67 67
 
68 68
 (defun read-bytes (count format stream)
69
-  (let ((seq (make-array count :element-type 'serapeum:octet)))
69
+  (let ((seq (make-array count :element-type 'fwoar.cl-git.types:octet)))
70 70
     (read-sequence seq stream)
71 71
     (funcall format
72 72
              seq)))
... ...
@@ -86,6 +86,9 @@
86 86
               (list type
87 87
                     (parse-integer length))))))
88 88
 
89
-(defun behead (data)
90
-  (elt (partition 0 data)
91
-       1))
89
+(defmacro with-open-files* ((&rest bindings) &body body)
90
+  `(uiop:nest ,@(mapcar (serapeum:op
91
+                          `(with-open-file ,_1))
92
+                        bindings)
93
+              (progn
94
+                ,@body)))