steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

git: Add repo that can do some git things in native Factor.

modern-harvey2
Doug Coleman 2017-08-31 20:43:33 -05:00
parent c457c019bb
commit a372224e9b
5 changed files with 730 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
extra/assocs/extras/extras.factor
View File

@ -1,8 +1,7 @@
! Copyright (C) 2012 John Benediktsson, Doug Coleman
! See http://factorcode.org/license.txt for BSD license
USING: arrays assocs assocs.private kernel math sequences ;
USING: arrays assocs assocs.private generalizations kernel math
sequences ;
IN: assocs.extras
: deep-at ( assoc seq -- value/f )
@ -52,3 +51,29 @@ ERROR: key-exists value key assoc ;
] [
drop set-at
] if ;
<PRIVATE
: (sequence>assoc) ( seq map-quot insert-quot assoc -- assoc )
[ swap curry compose each ] keep ; inline
: (sequence-index>assoc) ( seq map-quot insert-quot assoc -- assoc )
[ swap curry compose each-index ] keep ; inline
PRIVATE>
: sequence>assoc! ( assoc seq map-quot: ( x -- ..y ) insert-quot: ( ..y assoc -- ) -- assoc )
4 nrot (sequence>assoc) ; inline
: sequence>assoc ( seq map-quot insert-quot exemplar -- assoc )
clone (sequence>assoc) ; inline
: sequence-index>assoc ( seq map-quot insert-quot exemplar -- assoc )
clone (sequence-index>assoc) ; inline
: sequence-index>hashtable ( seq map-quot insert-quot -- hashtable )
H{ } sequence-index>assoc ; inline
: sequence>hashtable ( seq map-quot insert-quot -- hashtable )
H{ } sequence>assoc ; inline

1
extra/git/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

42
extra/git/git-tests.factor Normal file
View File

@ -0,0 +1,42 @@
! Copyright (C) 2015 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: fry git io io.directories io.encodings.utf8 io.files.temp
io.files.unique io.launcher kernel sequences tools.test ;
IN: git.tests
: run-process-stdout ( process -- string )
>process utf8 [ contents ] with-process-reader ;
: with-empty-test-git-repo ( quot -- )
'[
[
{ "git" "init" } run-process drop
@
] cleanup-unique-directory
] with-temp-directory ; inline
: with-zero-byte-file-repo ( quot -- )
'[
"empty-file" touch-file
{ "git" "add" "empty-file" } run-process drop
{ "git" "commit" "-m" "initial commit of empty file" } run-process drop
@
] with-empty-test-git-repo ; inline
{ "refs/heads/master" } [
[ git-head-ref ] with-empty-test-git-repo
] unit-test
{ } [
[
! "." t recursive-directory-files
git-log [ commit. ] each
] with-zero-byte-file-repo
] unit-test
{ } [
[
{ "git" "log" } run-process-stdout print
] with-zero-byte-file-repo
] unit-test

513
extra/git/git.factor Normal file
View File

@ -0,0 +1,513 @@
! Copyright (C) 2015 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs assocs.extras calendar
calendar.format checksums checksums.sha combinators
combinators.smart compression.zlib constructors fry grouping io
io.binary io.directories io.directories.search
io.encodings.binary io.encodings.string io.encodings.utf8
io.files io.files.info io.pathnames io.streams.byte-array
io.streams.peek kernel math math.bitwise math.parser
math.statistics memoize namespaces random sequences
sequences.extras splitting strings ;
IN: git
ERROR: byte-expected offset ;
: read1* ( -- n )
read1 [ tell-input byte-expected ] unless* ;
ERROR: separator-expected expected-one-of got ;
: read-until* ( separators -- data )
dup read-until [ nip ] [ separator-expected ] if ;
: find-git-directory ( path -- path' )
[ ".git" tail? ] find-up-to-root ; inline
ERROR: not-a-git-directory path ;
: current-git-directory ( -- path )
current-directory get find-git-directory [
current-directory get not-a-git-directory
] unless* ;
: make-git-path ( str -- path )
current-git-directory prepend-path ;
: make-refs-path ( str -- path )
[ "refs/" make-git-path ] dip append-path ;
: make-object-path ( str -- path )
[ "objects/" make-git-path ] dip 2 cut append-path append-path ;
: make-idx-path ( sha -- path )
"objects/pack/pack-" ".idx" surround make-git-path ;
: make-pack-path ( sha -- path )
"objects/pack/pack-" ".pack" surround make-git-path ;
: git-binary-contents ( str -- contents )
make-git-path binary file-contents ;
: git-utf8-contents ( str -- contents )
make-git-path utf8 file-contents ;
: git-lines ( str -- contents )
make-git-path utf8 file-lines ;
ERROR: expected-one-line lines ;
: git-line ( str -- contents )
git-lines dup length 1 =
[ first ] [ expected-one-line ] if ;
: git-unpacked-object-exists? ( hash -- ? )
make-object-path exists? ;
TUPLE: index-entry ctime mtime dev ino mode uid gid size sha1 flags name ;
CONSTRUCTOR: <index-entry> index-entry ( ctime mtime dev ino mode uid gid size sha1 flags name -- obj ) ;
: read-index-entry-v2 ( -- seq )
4 read be> 4 read be> 2array
4 read be> 4 read be> 2array
4 read be>
4 read be>
4 read be>
4 read be>
4 read be>
4 read be>
20 read bytes>hex-string
2 read be> { 0 } read-until drop [ utf8 decode ] [ length ] bi
7 + 8 mod dup zero? [ 8 swap - ] unless read drop
<index-entry> ;
TUPLE: git-index magic version entries checksum ;
CONSTRUCTOR: <git-index> git-index ( magic version entries checksum -- obj ) ;
ERROR: unhandled-git-version n ;
ERROR: unhandled-git-index-trailing-bytes bytes ;
: git-index-contents ( -- git-index )
"index" make-git-path binary [
4 read utf8 decode
4 read be>
4 read be> over {
{ 2 [ [ read-index-entry-v2 ] replicate ] }
[ unhandled-git-version ]
} case
20 read bytes>hex-string
<git-index>
] with-file-reader ;
: make-git-object ( str -- obj )
[
[ "blob " ] dip [ length number>string "\0" ] [ ] bi
] B{ } append-outputs-as ;
: path>git-object ( path -- bytes )
binary file-contents make-git-object sha1 checksum-bytes ;
: git-hash-object ( str -- hash )
make-git-object sha1 checksum-bytes ;
: changed-index-by-sha1 ( -- seq )
git-index-contents entries>>
[ [ sha1>> ] [ name>> path>git-object bytes>hex-string ] bi = not ] filter ;
: changed-index-by-mtime ( -- seq )
git-index-contents entries>>
[
[ mtime>> first ]
[ name>> file-info modified>> timestamp>unix-time >integer ] bi = not
] filter ;
TUPLE: commit hash tree parents author committer message ;
CONSTRUCTOR: <commit> commit ( tree parents author committer -- obj ) ;
TUPLE: tree hash tree parents author committer message ;
CONSTRUCTOR: <tree> tree ( -- obj ) ;
: last2 ( seq -- penultimate ultimate ) 2 tail* first2 ;
: gmt-offset>duration ( string -- duration )
3 cut [ string>number ] bi@
[ hours ] [ minutes ] bi* time+ ;
: date>string ( seq -- string )
last2
[ string>number unix-time>timestamp ]
[ gmt-offset>duration [ time+ ] [ >>gmt-offset ] bi ] bi*
timestamp>git-time ;
: commit. ( commit -- )
{
[ hash>> "commit " prepend print ]
[ author>> "Author: " prepend " " split 2 head* " " join print ]
[ author>> " " split date>string "Date: " prepend print ]
[ message>> "\n" split [ " " prepend ] map "\n" join nl print nl ]
} cleave ;
ERROR: unknown-commit-line line name ;
ERROR: string-expected got expected ;
: expect-string ( string expected -- )
2dup = [ 2drop ] [ string-expected ] if ;
ERROR: eof-too-early ;
ERROR: unknown-field field ;
: parse-commit-field ( obj parameter -- obj )
[ "\r\n" read-until [ eof-too-early ] unless ] dip {
{ "tree" [ >>tree ] }
{ "parent" [ >>parents ] }
{ "author" [ >>author ] }
{ "committer" [ >>committer ] }
[ unknown-field ]
} case ;
ERROR: unexpected-text text ;
: parse-commit-lines ( obj -- obj )
" \n" read-until {
{ CHAR: \s [ parse-commit-field parse-commit-lines ] }
{ CHAR: \n [ drop contents >>message ] }
[ unexpected-text ]
} case ;
: parse-commit ( bytes -- commit )
" " split1 [ "commit" expect-string ] [ string>number read ] bi*
utf8 [
commit new parse-commit-lines
] with-byte-reader ;
: parse-tree-field ( obj parameter -- obj )
[ "\r\n" read-until* ] dip {
{ "tree" [ >>tree ] }
{ "parent" [ >>parents ] }
{ "author" [ >>author ] }
{ "committer" [ >>committer ] }
[ unknown-field ]
} case ;
: parse-tree-lines ( obj -- obj )
"\s\n" read-until {
{ CHAR: \s [ parse-tree-field parse-tree-lines ] }
{ CHAR: \n [ drop contents >>message ] }
[ unexpected-text ]
} case ;
ERROR: key-already-set value key assoc ;
: set-at-once ( value key assoc -- )
2dup key? [ key-already-set ] [ set-at ] if ;
: parse-object-line>assoc ( hashtable -- hashtable )
"\s\n" read-until {
{ CHAR: \s [ [ "\r\n" read-until* ] dip pick over "parent" = [ push-at ] [ set-at-once ] if parse-object-line>assoc ] }
{ CHAR: \n [ drop contents "message" pick set-at ] }
} case ;
: assoc>commit ( assoc -- commit )
[ commit new ] dip {
[ "tree" of >>tree ]
[ "parent" of >>parents ]
[ "author" of >>author ]
[ "committer" of >>committer ]
[ "message" of >>message ]
} cleave ;
ERROR: unknown-git-object obj ;
: assoc>git-object ( assoc -- git-object )
{
{ [ "committer" over key? ] [ assoc>commit ] }
[ unknown-git-object ]
} cond ;
: parse-object-bytes>assoc ( obj -- hashtable )
utf8 [
H{ } clone parse-object-line>assoc assoc>git-object
] with-byte-reader ;
: parse-tree ( bytes -- commit )
[ tree new ] dip
utf8 [
parse-tree-lines
] with-byte-reader ;
: parse-object ( bytes -- git-obj )
utf8 [
{ 0 } read-until 0 = drop dup " " split1 drop {
{ "blob" [ "unimplemented blob parsing" throw ] }
{ "commit" [ parse-commit ] }
{ "tree" [ parse-tree ] }
[ unknown-git-object ]
} case
] with-byte-reader ;
ERROR: idx-v1-unsupported ;
TUPLE: idx version table triples packfile-sha1 idx-sha1 ;
CONSTRUCTOR: <idx> idx ( version table triples packfile-sha1 idx-sha1 -- obj ) ;
! sha1, crc32, offset
: parse-idx-v2 ( -- idx )
4 read be>
256 4 * read 4 group [ be> ] map
dup last
[ [ 20 read bytes>hex-string ] replicate ]
[ [ 4 read ] replicate ]
[ [ 4 read be> ] replicate ] tri 3array flip
20 read bytes>hex-string
20 read bytes>hex-string <idx> ;
: parse-idx ( path -- idx )
binary [
4 read be> {
{ 0xff744f63 [ parse-idx-v2 ] }
[ idx-v1-unsupported ]
} case
] with-file-reader ;
SYMBOL: #bits
: read-type-length ( -- pair )
0 #bits [
read1*
[ -4 shift 3 bits ] [ 4 bits ] [ ] tri
0x80 mask? [
#bits [ 4 + ] change
[
read1* [
7 bits #bits get shift bitor
#bits [ 7 + ] change
] [ 0x80 mask? ] bi
] loop
] when 2array
] with-variable ;
: read-be-length ( -- length )
read1* dup 0x80 mask? [
7 bits [
read1*
[ [ 1 + 7 shift ] [ 7 bits ] bi* bitor ]
[ 0x80 mask? ] bi
] loop
] when ;
: read-le-length ( -- length )
read1* dup 0x80 mask? [
7 bits [
read1*
[ 7 bits 7 shift bitor ]
[ 0x80 mask? ] bi
] loop
] when ;
DEFER: git-object-from-pack
TUPLE: insert bytes ;
CONSTRUCTOR: <insert> insert ( bytes -- insert ) ;
TUPLE: copy offset size ;
CONSTRUCTOR: <copy> copy ( offset size -- copy ) ;
: parse-delta ( -- delta/f )
read1 [
dup 0x80 mask? not [
7 bits read <insert>
] [
[ 0 0 ] dip
dup 0x01 mask? [
[ read1* bitor ] 2dip
] when
dup 0x02 mask? [
[ read1* 8 shift bitor ] 2dip
] when
dup 0x04 mask? [
[ read1* 16 shift bitor ] 2dip
] when
dup 0x08 mask? [
[ read1* 24 shift bitor ] 2dip
] when
dup 0x10 mask? [
[ read1* bitor ] dip
] when
dup 0x20 mask? [
[ read1* 8 shift bitor ] dip
] when
dup 0x40 mask? [
[ read1* 16 shift bitor ] dip
] when
drop [ 65536 ] when-zero
<copy>
] if
] [
f
] if* ;
: parse-deltas ( bytes -- deltas )
binary [
read-le-length
read-le-length
[ parse-delta ] loop>array 3array
] with-byte-reader ;
ERROR: unknown-delta-operation op ;
: apply-delta ( delta -- )
{
{ [ dup insert? ] [ bytes>> write ] }
{ [ dup copy? ] [ [ offset>> seek-absolute seek-input ] [ size>> read write ] bi ] }
[ unknown-delta-operation ]
} cond ;
: do-deltas ( bytes delta-bytes -- bytes' )
[ binary ] 2dip '[
_ binary [
_ parse-deltas third [ apply-delta ] each
] with-byte-reader
] with-byte-writer ;
ERROR: unsupported-packed-raw-type type ;
: read-packed-raw ( -- string )
read-type-length first2 swap {
{ 1 [ 256 + read uncompress ] }
[ unsupported-packed-raw-type ]
} case ;
SYMBOL: initial-offset
: read-offset-delta ( size -- obj )
[ read-be-length neg initial-offset get + ] dip 256 + read uncompress
[ seek-absolute seek-input read-packed-raw ] dip 2array ;
: read-sha1-delta ( size -- obj )
[ 20 read bytes>hex-string git-object-from-pack ] dip read uncompress 2array ;
! XXX: actual length is stored in the gzip header
! We add 256 instead of using it for now.
: read-packed ( -- obj/f )
tell-input initial-offset [
read-type-length first2 swap {
{ 1 [ 256 + read uncompress parse-object ] }
{ 6 [ read-offset-delta first2 do-deltas parse-object-bytes>assoc ] }
! { 7 [ B read-sha1-delta ] }
[ number>string "unknown packed type: " prepend throw ]
} case
] with-variable ;
: parse-packed-object ( sha1 offset -- obj )
[ make-pack-path binary ] dip '[
input-stream [ <peek-stream> ] change
_ seek-absolute seek-input read-packed
] with-file-reader ;
! http://stackoverflow.com/questions/18010820/git-the-meaning-of-object-size-returned-by-git-verify-pack
TUPLE: pack magic version count objects sha1 ;
: parse-pack ( path -- pack )
binary [
input-stream [ <peek-stream> ] change
4 read >string
4 read be>
4 read be> 3array
[ peek1 ] [ read-packed ] produce 2array
] with-file-reader ;
: git-read-idx ( sha -- obj )
make-idx-path parse-idx ;
! Broken for now
! : git-read-pack ( sha -- obj ) make-pack-path parse-pack ;
: parsed-idx>hash ( seq -- hash )
H{ } clone [
'[
[ packfile-sha1>> ]
[ triples>> ] bi
[ first3 rot [ 3array ] dip _ set-at ] with each
] each
] keep ;
MEMO: git-parse-all-idx ( -- seq )
"objects/pack/" make-git-path qualified-directory-files
[ ".idx" tail? ] filter
[ parse-idx ] map
parsed-idx>hash ;
ERROR: no-pack-for sha1 ;
: find-pack-for ( sha1 -- triple )
git-parse-all-idx ?at [ no-pack-for ] unless ;
: git-object-from-pack ( sha1 -- pack )
[ find-pack-for [ first ] [ third ] bi parse-packed-object ] keep >>hash ;
: git-object-contents ( hash -- contents )
make-object-path binary file-contents uncompress ;
: git-read-object ( sha -- obj )
dup git-unpacked-object-exists? [
[ git-object-contents parse-object ] keep >>hash
] [
git-object-from-pack
] if ;
! !: git-object-contents ( hash -- contents )
! make-object-path ! binary file-contents uncompress ;
! [ git-read-object ] [ git-object-from-pack ] if ;
: parsed-idx>hash2 ( seq -- hash )
[
[ triples>> [ [ drop f ] [ first ] bi ] [ set-at ] sequence>hashtable ]
[ packfile-sha1>> ] bi
] [ set-at ] sequence>hashtable ; inline
ERROR: expected-ref got ;
: parse-ref-line ( string -- string' )
" " split1 [
dup "ref:" = [ drop ] [ expected-ref ] if
] dip ;
: list-refs ( -- seq )
current-git-directory "refs/" append-path recursive-directory-files ;
: remote-refs-dirs ( -- seq )
"remotes" make-refs-path directory-files ;
: ref-contents ( str -- line ) make-refs-path git-line ;
: git-stash-ref-sha1 ( -- contents ) "stash" ref-contents ;
: git-ref ( ref -- sha1 ) git-line parse-ref-line ;
: git-head-ref ( -- sha1 ) "HEAD" git-ref ;
: git-log-for-ref ( ref -- log ) git-line git-read-object ;
: git-head-object ( -- commit ) git-head-ref git-log-for-ref ;
: git-config ( -- config )
"config" make-git-path ;
SYMBOL: parents
ERROR: repeated-parent-hash hash ;
: git-log ( -- log )
H{ } clone parents [
git-head-object [
parents>> dup string? [ random ] unless [
! [ parents get 2dup key? [ repeated-parent-hash ] when dupd set-at ] keep
! dup "parent: " prepend print flush yield
dup git-unpacked-object-exists?
[ git-read-object ] [ git-object-from-pack ] if
] [ f ] if*
] follow
] with-variable ;

146
extra/git/notes.txt Normal file
View File

@ -0,0 +1,146 @@
CONSTANT: OBJ_COMMIT 1
CONSTANT: OBJ_TREE 2
CONSTANT: OBJ_BLOB 3
CONSTANT: OBJ_TAG 4
CONSTANT: OBJ_OFS_DELTA 6
CONSTANT: OBJ_REF_DELTA 7
"/Users/erg/factor" set-current-directory
"3dff14e2f3d0c8db662a8c6aeb5dbd427f4258eb" git-read-pack
"/Users/erg/factor" set-current-directory
git-log
"/Users/erg/factor" set-current-directory
"401597a387add5b52111d1dd954d6250ee2b2688" git-object-from-pack
git verify-pack -v .git/objects/pack/pack-816d07912ac9f9b463f89b7e663298e3c8fedda5.pack | grep a6e0867b
a6e0867b2222f3b0976e9aac6539fe8f12a552e2 commit 51 63 12938 1 8000d6670e1abdbaeebc4452c6cccbec68069ca1
! problem: a6e0867b2222f3b0976e9aac6539fe8f12a552e2
! investigate:
http://stackoverflow.com/questions/9478023/is-the-git-binary-diff-algorithm-delta-storage-standardized/9478566#9478566
http://stackoverflow.com/questions/801577/how-to-recover-git-objects-damaged-by-hard-disk-failure
git ls-tree
! eh
http://schacon.github.io/git/technical/pack-format.txt
https://schacon.github.io/gitbook/7_the_packfile.html
! most useful doc:
http://git.rsbx.net/Documents/Git_Data_Formats.txt
! git show:
git show -s --pretty=raw 2ca509a8fe681d58f80d402ea9da2be20b9ab0a0
! git add
git add -p # parts of files
! git reset
git merge --abort is alias for git reset --merge
! Merge strategies:
octopus: git merge fixes enhancements # two branches merging
git merge --no-commit maint # merge maint into current branch, but do not make a commit yet
http://git-scm.com/docs/git-merge
http://stackoverflow.com/questions/161813/fix-merge-conflicts-in-git?rq=1
# common base:
git show :1:_widget.html.erb
# 'ours'
git show :2:_widget.html.erb
# 'theirs'
git show :3:_widget.html.erb
git show :3:_widget.html.erb >_widget.html.erb
git add _widget.html.erb
aka
git checkout --theirs _widget.html.erb
Guys, "ours" and "theirs" is relative to whether or not you are merging or rebasing. If you're merging, then "ours" means the branch you're merging into, and "theirs" is the branch you're merging in. When you're rebasing, then "ours" means the commits you're rebasing onto, while "theirs" refers to the commits that you want to rebase. – Cupcake May 26 '14 at 4:27
! random
https://github.com/libgit2/libgit2/blob/091165c53b2bcd5d41fb71d43ed5a23a3d96bf5d/docs/diff-internals.md
https://github.com/schacon/git-server/blob/master/git-server.rb
https://git-scm.com/blog
https://github.com/gitchain/gitchain/blob/2baefefd1795b358c98335f120738b60966fa09d/git/delta.go
https://www.kernel.org/pub/software/scm/git/docs/user-manual.html#git-concepts
! graphs in terminal:
http://stackoverflow.com/questions/1064361/unable-to-show-a-git-tree-in-terminal
git-daemon:
git daemon --reuseaddr --verbose --base-path=. --export-all
$> export GIT_TRACE_PACKET=1
git ls-remote git://127.0.0.1/git-bottom-up
raw git:
https://schacon.github.io/gitbook/7_raw_git.html
# write object
git hash-object -w myfile.txt
-----------------------------------
Now lets say you want to create a tree from your new objects. The git mktree command makes it pretty simple to generate new tree objects from git ls-tree formatted output. For example, if you write the following to a file named '/tmp/tree.txt' :
100644 blob 6ff87c4664981e4397625791c8ea3bbb5f2279a3 file1
100644 blob 3bb0e8592a41ae3185ee32266c860714980dbed7 file2
$ cat /tmp/tree.txt | git mk-tree
f66a66ab6a7bfe86d52a66516ace212efa00fe1f
100644 blob 6ff87c4664981e4397625791c8ea3bbb5f2279a3 file1-copy
040000 tree f66a66ab6a7bfe86d52a66516ace212efa00fe1f our_files
$ cat /tmp/newtree.txt | git mk-tree
5bac6559179bd543a024d6d187692343e2d8ae83
.
|-- file1-copy
`-- our_files
|-- file1
`-- file2
1 directory, 3 files
---------------------------------------------
$ export GIT_INDEX_FILE=/tmp/index
$ git read-tree --prefix=copy1/ 5bac6559
$ git read-tree --prefix=copy2/ 5bac6559
$ git write-tree
bb2fa6de7625322322382215d9ea78cfe76508c1
$>git ls-tree bb2fa
040000 tree 5bac6559179bd543a024d6d187692343e2d8ae83 copy1
040000 tree 5bac6559179bd543a024d6d187692343e2d8ae83 copy2
-------------------------------
GIT_AUTHOR_NAME
GIT_AUTHOR_EMAIL
GIT_AUTHOR_DATE
GIT_COMMITTER_NAME
GIT_COMMITTER_EMAIL
GIT_COMMITTER_DATE
$ git commit-tree bb2fa < /tmp/message
a5f85ba5875917319471dfd98dfc636c1dc65650
$ git update-ref refs/heads/master a5f85ba5875917319471dfd98dfc636c1dc65650
https://github.com/magit/magit
https://www.kernel.org/pub/software/scm/git/docs/user-manual.html