1 ! Copyright (C) 2017 Doug Coleman.
2 ! See https://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays combinators.short-circuit
4 concurrency.combinators concurrency.semaphores io io.directories
5 io.encodings.utf8 io.files io.files.info io.launcher
6 io.pathnames kernel math namespaces sequences splitting
10 SYMBOL: cli-git-num-parallel
11 cli-git-num-parallel [ cpus 2 * ] initialize
13 : git-command>string ( desc -- string )
14 utf8 <process-reader> stream-contents [ blank? ] trim-tail ;
16 : git-clone-no-checkout-as ( uri path -- process ) [ { "git" "clone" "--no-checkout" } ] 2dip 2array append run-process ;
17 : git-clone-no-checkout ( uri -- process ) [ { "git" "clone" "--no-checkout" } ] dip suffix run-process ;
18 : git-clone-bare-as ( uri path -- process ) [ { "git" "clone" "--bare" } ] 2dip 2array append run-process ;
19 : git-clone-bare ( uri -- process ) [ { "git" "clone" "--bare" } ] dip suffix run-process ;
20 : git-clone-as ( uri path -- process ) [ { "git" "clone" } ] 2dip 2array append run-process ;
21 : git-clone ( uri -- process ) [ { "git" "clone" } ] dip suffix run-process ;
22 : git-worktree-add ( path branch -- process ) '{ "git" "worktree" "add" _ _ } run-process ;
23 : git-worktree-force-add ( path branch -- process ) '{ "git" "worktree" "add" "-f" _ _ } run-process ;
24 : git-pull* ( -- process ) { "git" "pull" } run-process ;
25 : git-pull ( path -- process ) [ git-pull* ] with-directory ;
26 : git-fetch-all-desc ( -- process ) { "git" "fetch" "--all" } ;
27 : git-fetch-all* ( -- process ) git-fetch-all-desc run-process ;
28 : git-fetch-all ( path -- process ) [ git-fetch-all* ] with-directory ;
29 : git-reset-hard-desc ( branch -- process ) '{ "git" "reset" "--hard" _ } ;
30 : git-reset-hard ( branch -- process ) git-reset-hard-desc run-process ;
31 : git-reset-hard-HEAD ( -- process ) "HEAD" git-reset-hard-desc ;
32 : git-fetch-and-reset-hard ( path branch -- processes ) '[ git-fetch-all-desc _ git-reset-hard-desc 2array run-processes ] with-directory ;
33 : git-fetch-and-reset-hard-HEAD ( path -- processes ) [ git-fetch-all-desc "HEAD" git-reset-hard-desc 2array run-processes ] with-directory ;
34 : git-fetch-tags* ( -- process ) { "git" "fetch" "--tags" } run-process ;
35 : git-fetch-tags ( path -- process ) [ git-fetch-tags* ] with-directory ;
36 : git-tag* ( -- process ) { "git" "tag" } process-lines ;
37 : git-tag ( path -- process ) [ git-tag* ] with-directory ;
38 : git-switch-new-branch* ( branch -- process ) [ { "git" "switch" "-c" } ] dip suffix run-process ;
39 : git-switch-new-branch ( path branch -- process ) '[ _ git-switch-new-branch* ] with-directory ;
40 : git-checkout-new-branch* ( branch -- process ) [ { "git" "checkout" "-b" } ] dip suffix run-process ;
41 : git-checkout-new-branch ( path branch -- process ) '[ _ git-checkout-new-branch* ] with-directory ;
42 : git-checkout-existing* ( branch/checksum -- process ) [ { "git" "checkout" } ] dip suffix run-process ;
43 : git-checkout-existing ( path branch/checksum -- process ) '[ _ git-checkout-existing* ] with-directory ;
44 : git-change-remote* ( remote uri -- process ) [ { "git" "remote" "set-url" } ] 2dip 2array append run-process ;
45 : git-change-remote ( path remote uri -- process ) '[ _ _ git-change-remote* ] with-directory ;
46 : git-remote-add* ( remote uri -- process ) [ { "git" "remote" "add" } ] 2dip 2array append run-process ;
47 : git-remote-add ( path remote uri -- process ) '[ _ _ git-remote-add* ] with-directory ;
48 : git-remote-get-url* ( remote -- process ) [ { "git" "remote" "get-url" } ] dip suffix run-process ;
49 : git-remote-get-url ( path remote -- process ) '[ _ git-remote-get-url* ] with-directory ;
50 : git-rev-parse* ( branch -- string ) [ { "git" "rev-parse" } ] dip suffix git-command>string ;
51 : git-rev-parse ( path branch -- string ) '[ _ git-rev-parse* ] with-directory ;
52 : git-diff-name-only* ( from to -- lines )
53 [ { "git" "diff" "--name-only" } ] 2dip 2array append process-lines ;
54 : git-diff-name-only ( path from to -- lines )
55 '[ _ _ git-diff-name-only* ] with-directory ;
57 : git-directory? ( directory -- ? )
58 ".git" append-path current-directory get prepend-path
59 ?file-info dup [ directory? ] when ;
61 : git-no-checkout-directory? ( directory -- ? )
62 current-directory get prepend-path file-exists? ;
64 : git-current-branch* ( -- name )
65 { "git" "rev-parse" "--abbrev-ref" "HEAD" } git-command>string ;
67 : git-current-branch ( directory -- name )
68 [ git-current-branch* ] with-directory ;
70 : git-directory-name ( string -- string' )
71 file-name ".git" ?tail drop ;
73 : git-is-bare-repository* ( -- ? )
74 { "git" "rev-parse" "--is-bare-repository" } git-command>string "true" = ;
76 : git-is-bare-repository ( path -- ? )
77 '[ git-is-bare-repository* ] with-directory ;
79 : git-bare-directory? ( directory -- ? )
81 [ ?file-info [ directory? ] [ f ] if* ]
82 [ git-is-bare-repository ]
85 : sync-no-checkout-repository ( url -- process )
86 dup git-directory-name git-no-checkout-directory?
87 [ git-directory-name git-fetch-all ] [ git-clone-no-checkout ] if ;
89 : sync-no-checkout-repository-as ( url path -- processes )
90 dup git-no-checkout-directory?
91 [ nip git-fetch-all ] [
92 [ git-clone-no-checkout-as ]
93 [ "factor-build-from-source" git-switch-new-branch ] bi 2array
96 : sync-bare-repository ( url -- process )
97 dup git-directory-name git-bare-directory?
98 [ git-directory-name git-fetch-all ] [ git-clone-bare ] if ;
100 : sync-bare-repository-as ( url path -- processes )
101 dup git-bare-directory?
102 [ nip git-fetch-all ] [ git-clone-bare-as ] if ;
104 : sync-repository ( url -- process )
105 dup git-directory-name git-directory?
106 [ git-directory-name git-pull ] [ git-clone ] if ;
108 : sync-repository-as ( url path -- processes )
110 [ nip git-fetch-and-reset-hard-HEAD ] [ git-clone-as ] if ;
112 : sync-repositories ( directory urls -- )
114 _ cli-git-num-parallel get <semaphore> '[
115 _ [ sync-repository ] with-semaphore
117 ] with-ensure-directory ;
119 : directory-entries-without-git ( directory -- entries )
120 recursive-directory-entries
121 [ name>> "/.git/" subseq-of? ] reject ;