File Coverage

blib/lib/Doit/Git.pm
Criterion Covered Total %
statement 267 306 87.2
branch 149 200 74.5
condition 27 36 75.0
subroutine 28 28 100.0
pod 10 12 83.3
total 481 582 82.6


line stmt bran cond sub pod time code
1             # -*- perl -*-
2              
3             #
4             # Author: Slaven Rezic
5             #
6             # Copyright (C) 2017,2018,2019,2022 Slaven Rezic. All rights reserved.
7             # This package is free software; you can redistribute it and/or
8             # modify it under the same terms as Perl itself.
9             #
10             # Mail: slaven@rezic.de
11             # WWW: http://www.rezic.de/eserte/
12             #
13              
14             package Doit::Git; # Convention: all commands here should be prefixed with 'git_'
15              
16 2     2   12 use strict;
  2         4  
  2         62  
17 2     2   10 use warnings;
  2         4  
  2         71  
18             our $VERSION = '0.028';
19              
20 2     2   10 use Doit::Log;
  2         3  
  2         98  
21 2     2   11 use Doit::Util qw(in_directory);
  2         3  
  2         5148  
22              
23             sub _pipe_open (@);
24              
25 2     2 0 17 sub new { bless {}, shift }
26 2     2 0 10 sub functions { qw(git_repo_update git_short_status git_root git_get_commit_hash git_get_commit_files git_get_changed_files git_is_shallow git_current_branch git_config git_get_default_branch) }
27              
28             sub git_repo_update {
29 42     42 1 816 my($self, %opts) = @_;
30 42         233 my $repository = delete $opts{repository};
31 42 100       91 my @repository_aliases = @{ delete $opts{repository_aliases} || [] };
  42         597  
32 42         152 my $directory = delete $opts{directory};
33 42   100     394 my $origin = delete $opts{origin} || 'origin';
34 42         149 my $branch = delete $opts{branch};
35 42         88 my $allow_remote_url_change = delete $opts{allow_remote_url_change};
36 42         73 my $clone_opts = delete $opts{clone_opts};
37 42   100     295 my $refresh = delete $opts{refresh} || 'always';
38 42 100       535 if ($refresh !~ m{^(always|never)$}) { error "refresh may be 'always' or 'never'" }
  1         4  
39 41         112 my $quiet = delete $opts{quiet};
40 41 100       230 error "Unhandled options: " . join(" ", %opts) if %opts;
41              
42 40         229 my $has_changes = 0;
43 40         171 my $do_clone;
44 40 100       1461 if (!-e $directory) {
45 13         102 $do_clone = 1;
46             } else {
47 27 100       499 if (!-d $directory) {
48 1         12 error "'$directory' exists, but is not a directory\n";
49             }
50 26 100       443 if (!-d "$directory/.git") {
51 2 100       29 if (_is_dir_empty($directory)) {
52 1         25 $do_clone = 1;
53             } else {
54 1         11 error "No .git directory found in non-empty '$directory', refusing to clone...\n";
55             }
56             }
57             }
58 38 100       278 if (!$do_clone) {
59             in_directory {
60 24     24   79 my $actual_repository = eval { $self->info_qx({quiet=>1}, qw(git config --get), "remote.$origin.url") };
  24         303  
61 24 100       302 if (!defined $actual_repository) {
62             # Remote does not exist yet --- create it.
63 1         30 $self->system(qw(git remote add), $origin, $repository);
64             } else {
65 23         73 chomp $actual_repository;
66 23 100 100     280 if ($actual_repository ne $repository && !grep { $_ eq $actual_repository } @repository_aliases) {
  2         50  
67 3         75 my @change_cmd = ('git', 'remote', 'set-url', $origin, $repository);
68 3 100       31 if ($allow_remote_url_change) {
69 1         65 info "Need to change remote URL for $origin";
70 1         269 $self->system(@change_cmd);
71             } else {
72 2 100       74 error
73             "In $directory: remote $origin does not point to $repository" . (@repository_aliases ? " (or any of the following aliases: @repository_aliases)" : "") . ", but to $actual_repository\n" .
74             "Please run manually\n" .
75             " @change_cmd\n" .
76             "or specify allow_remote_url_change=>1\n";
77             }
78             }
79             }
80              
81 22         165 my $switch_later;
82 22 100       122 if (defined $branch) { # maybe branch switching necessary?
83 11 100       100 if ($branch =~ m{^refs/remotes/(.*)}) { # extract branch with remote
84 1         23 $branch = $1;
85             }
86 11         164 my $current_branch = $self->git_current_branch;
87 11 100 66     178 if (!defined $current_branch || $current_branch ne $branch) {
88 7 100       43 if (eval { $self->system({show_cwd=>1,quiet=>$quiet}, qw(git checkout), $branch); 1 }) {
  7         188  
  4         230  
89 4         22 $has_changes = 1;
90             } else {
91             # Cannot switch now to the branch. Maybe a
92             # git-fetch has to be done first, as the
93             # branch is not yet in the clone --- try
94             # later.
95 3         33 $switch_later = 1;
96             }
97             }
98 11         150 my %info;
99 11         168 $self->git_current_branch(info_ref => \%info);
100 11 100       700 if ($info{detached}) {
101 5         30 $switch_later = 1; # because a "git pull" wouldn't update a detached branch
102             }
103             }
104              
105 22 100       155 if ($refresh eq 'always') {
106 21         491 $self->system({show_cwd=>1,quiet=>$quiet}, qw(git fetch), $origin);
107 21         1733 my $status = $self->git_short_status(untracked_files => 'no');
108 21 100       390 if ($status =~ m{>$}) {
109             # may actually fail if diverged (status=<>)
110             # or untracked/changed files would get overwritten
111 5         282 $self->system({show_cwd=>1,quiet=>$quiet}, qw(git pull), $origin); # XXX actually would be more efficient to do a merge or rebase, but need to figure out how git does it exactly...
112 4         309 $has_changes = 1;
113             } # else: ahead, diverged, or something else
114             }
115              
116 21 100       475 if ($switch_later) {
117 8         37 my($commit_before, $branch_before);
118 8 100       41 if (!$has_changes) {
119 5         138 $commit_before = $self->git_get_commit_hash;
120 5         92 $branch_before = $self->git_current_branch;
121             }
122 8 100       37 if (!eval { $self->system({show_cwd=>1,quiet=>$quiet}, qw(git checkout), $branch) }) {
  8         289  
123             # Possible reason for the failure: $branch exists
124             # as a remote branch in multiple remotes. Try
125             # again by explicitly specifying the remote.
126             # --track exists since approx git 1.5.1
127 1         55 $self->system({show_cwd=>1,quiet=>$quiet}, qw(git checkout -b), $branch, qw(--track), "$origin/$branch");
128             }
129 8 100 100     405 if ($commit_before
      100        
130             && ( $self->git_get_commit_hash ne $commit_before
131             || $self->git_current_branch ne $branch_before
132             )
133             ) {
134 4         107 $has_changes = 1;
135             }
136             }
137 24         633 } $directory;
138             } else {
139 14         159 my @cmd = (qw(git clone --origin), $origin);
140 14 100       121 if (defined $branch) {
141 2 100       28 if ($branch =~ m{^refs/remotes/[^/]+/(.*)}) { # extract branch without remote
142 1         11 $branch = $1;
143             }
144 2         16 push @cmd, "--branch", $branch;
145             }
146 14 100       98 if ($clone_opts) {
147 1         33 push @cmd, @$clone_opts;
148             }
149 14         56 push @cmd, $repository, $directory;
150 14         229 $self->system(@cmd);
151 14         852 $has_changes = 1;
152             }
153 35         2845 $has_changes;
154             }
155              
156             sub git_short_status {
157 59     59 1 658 my($self, %opts) = @_;
158 59         213 my $directory = delete $opts{directory};
159 59         154 my $untracked_files = delete $opts{untracked_files};
160 59 100       959 if (!defined $untracked_files) {
    100          
161 21         95 $untracked_files = 'normal';
162             } elsif ($untracked_files !~ m{^(normal|no)$}) {
163 1         4 error "only values 'normal' or 'no' supported for untracked_files";
164             }
165 58 100       242 error "Unhandled options: " . join(" ", %opts) if %opts;
166              
167             in_directory {
168 57     57   1013 local $ENV{LC_ALL} = 'C';
169              
170 57         255 my $untracked_marker = '';
171             {
172 57         342 my @cmd = ("git", "status", "--untracked-files=$untracked_files", "--porcelain");
173 57 50       273 my $fh = _pipe_open(@cmd)
174             or error "Can't run '@cmd': $!";
175 57         236 my $has_untracked;
176             my $has_uncommitted;
177 57         142000 while (<$fh>) {
178 13 100       324 if (m{^\?\?}) {
179 6         33 $has_untracked++;
180             } else {
181 7         33 $has_uncommitted++;
182             }
183             # Shortcut, exit as early as possible
184 13 100       429 if ($has_uncommitted) {
185 8 100       600 if ($has_untracked) {
    100          
186 1         334 return '<<*';
187             } elsif ($untracked_files eq 'no') {
188 3         855 return '<<';
189             } # else we have to check further, for possible untracked files
190             }
191             }
192 53 100       459 if ($has_uncommitted) {
    100          
193 3         407 return '<<';
194             } elsif ($has_untracked) {
195 5         55 $untracked_marker = '*'; # will be combined later
196 5         361 last;
197             }
198 45 100       2933 close $fh
199             or error "Error while running '@cmd': $!";
200             }
201              
202             {
203 57         128 my @cmd = ("git", "status", "--untracked-files=no");
  48         305  
  48         610  
204 48 50       422 my $fh = _pipe_open(@cmd)
205             or error "Can't run '@cmd': $!";
206 48         170 my $l;
207 48         131647 $l = <$fh>;
208 48         407 $l = <$fh>;
209 48 100       7925 if ($l =~ m{^(# )?Your branch is ahead}) {
    100          
    100          
210 4         1134 return '<'.$untracked_marker;
211             } elsif ($l =~ m{^(# )?Your branch is behind}) {
212 9         2437 return $untracked_marker.'>';
213             } elsif ($l =~ m{^(# )?Your branch and .* have diverged}) {
214 4         1390 return '<'.$untracked_marker.'>';
215             }
216             }
217              
218 31 50       943 if (-f ".git/svn/.metadata") {
219             # simple-minded heuristics, works only with svn standard branch
220             # layout
221 0         0 my $root_dir = $self->git_root;
222 0 0       0 if (open my $fh_remote, "$root_dir/.git/refs/remotes/trunk") {
223 0 0       0 if (open my $fh_local, "$root_dir/.git/refs/heads/master") {
224 0         0 chomp(my $sha1_remote = <$fh_remote>);
225 0         0 chomp(my $sha1_local = <$fh_local>);
226 0 0       0 if ($sha1_remote ne $sha1_local) {
227 0         0 my $remote_is_newer;
228 0 0       0 if (my $log_fh = _pipe_open('git', 'log', '--pretty=format:%H', 'master..remotes/trunk')) {
229 0 0       0 if (scalar <$log_fh>) {
230 0         0 $remote_is_newer = 1;
231             }
232             }
233 0         0 my $local_is_newer;
234 0 0       0 if (my $log_fh = _pipe_open('git', 'log', '--pretty=format:%H', 'remotes/trunk..master')) {
235 0 0       0 if (scalar <$log_fh>) {
236 0         0 $local_is_newer = 1;
237             }
238             }
239 0 0 0     0 if ($remote_is_newer && $local_is_newer) {
    0          
    0          
240 0         0 return '<'.$untracked_marker.'>';
241             } elsif ($remote_is_newer) {
242 0         0 return $untracked_marker.'>';
243             } elsif ($local_is_newer) {
244 0         0 return '<'.$untracked_marker;
245             } else {
246 0         0 return '?'; # Should never happen
247             }
248             }
249             }
250             }
251             }
252              
253 31         2901 return $untracked_marker;
254              
255 57         1619 } $directory;
256             }
257              
258             sub git_root {
259 62     62 1 186 my($self, %opts) = @_;
260 62         118 my $directory = delete $opts{directory};
261 62 100       153 error "Unhandled options: " . join(" ", %opts) if %opts;
262              
263             in_directory {
264 61     61   571 chomp(my $dir = $self->info_qx({quiet=>1}, 'git', 'rev-parse', '--show-toplevel'));
265 54         2113 $dir;
266 61         966 } $directory;
267             }
268              
269             sub git_get_commit_hash {
270 20     20 1 183 my($self, %opts) = @_;
271 20         59 my $directory = delete $opts{directory};
272 20         44 my $commit = delete $opts{commit};
273 20 100       92 error "Unhandled options: " . join(" ", %opts) if %opts;
274              
275             in_directory {
276 19 100   19   299 chomp(my $commit = $self->info_qx({quiet=>1}, 'git', 'log', '-1', '--format=%H', (defined $commit ? $commit : ())));
277 17         778 $commit;
278 19         399 } $directory;
279             }
280              
281             sub git_get_commit_files {
282 8     8 1 59 my($self, %opts) = @_;
283 8         23 my $directory = delete $opts{directory};
284 8 100       18 my $commit = delete $opts{commit}; if (!defined $commit) { $commit = 'HEAD' }
  8         25  
  6         22  
285 8 100       27 error "Unhandled options: " . join(" ", %opts) if %opts;
286              
287 7         24 my @files;
288             in_directory {
289 6     6   48 my @cmd = ('git', 'show', $commit, '--pretty=format:', '--name-only');
290 6 50       46 my $fh = _pipe_open(@cmd)
291             or error "Error running @cmd: $!";
292 6         10937 my $first = <$fh>;
293 6 100 66     142 if (defined $first && $first ne "\n") { # first line is empty for older git versions (e.g. 1.7.x)
294 3         19 chomp $first;
295 3         34 push @files, $first;
296             }
297 6         456 while(<$fh>) {
298 1         17 chomp;
299 1         94 push @files, $_;
300             }
301 6 100       396 close $fh
302             or error "Error while running @cmd: $!";
303 7         124 } $directory;
304 3         183 @files;
305             }
306              
307             sub git_get_changed_files {
308 11     11 1 75 my($self, %opts) = @_;
309 11         30 my $directory = delete $opts{directory};
310 11         22 my $ignore_untracked = delete $opts{ignore_untracked};
311 11 100       50 error "Unhandled options: " . join(" ", %opts) if %opts;
312              
313 10         24 my @files;
314             in_directory {
315 10     10   34 my @cmd = qw(git status --porcelain);
316 10 50       50 my $fh = _pipe_open(@cmd)
317             or error "Error running @cmd: $!";
318 10         18536 while(<$fh>) {
319 7         38 chomp;
320 7 100 66     150 next if $ignore_untracked && m{^\?\?};
321 6         80 s{^...}{};
322 6         557 push @files, $_;
323             }
324 10 100       599 close $fh
325             or error "Error while running @cmd: $!";
326 10         193 } $directory;
327 8         427 @files;
328             }
329              
330             sub git_is_shallow {
331 5     5 1 57 my($self, %opts) = @_;
332 5         23 my $directory = delete $opts{directory};
333 5 100       31 error "Unhandled options: " . join(" ", %opts) if %opts;
334              
335 4         53 my $git_root = $self->git_root(directory => $directory);
336 2 100       208 -f "$git_root/.git/shallow" ? 1 : 0;
337             }
338              
339             sub git_current_branch {
340 50     50 1 517 my($self, %opts) = @_;
341 50         132 my $directory = delete $opts{directory};
342 50         90 my $info_ref = delete $opts{info_ref};
343 50 100       385 error "Unhandled options: " . join(" ", %opts) if %opts;
344              
345             in_directory {
346 49     49   392 my $git_root = $self->git_root;
347 47         146 my $fh;
348             my $this_head;
349 47 50       2571 if (open $fh, "<", "$git_root/.git/HEAD") {
350 47         716 chomp($this_head = <$fh>);
351 47 100       813 if ($this_head =~ m{refs/heads/(\S+)}) {
352 29         1571 return $1;
353             }
354             }
355              
356             # fallback to git-status
357 18         285 $ENV{LC_ALL} = 'C';
358 18 50       153 if ($fh = _pipe_open(qw(git status))) {
359 18         51948 chomp($_ = <$fh>);
360 18 50       258 if (/^On branch (.*)/) {
361 0 0       0 if ($info_ref) {
362 0         0 $info_ref->{fallback} = 'git-status';
363             }
364 0         0 return $1;
365             }
366 18 50       366 if (/^.* detached at (.*)/) {
367 18 100       74 if ($info_ref) {
368 10         103 $info_ref->{detached} = 1;
369 10         87 $info_ref->{fallback} = 'git-status';
370             }
371 18         3469 return $1;
372             }
373 0 0       0 if (/^\Q# Not currently on any branch./) {
374             # Probably old git (~ 1.5 ... 1.7)
375 0 0       0 if (my $fh2 = _pipe_open(qw(git show-ref))) {
376 0         0 while(<$fh2>) {
377 0         0 chomp;
378 0 0       0 if (my($sha1, $ref) = $_ =~ m{^(\S+)\s+refs/remotes/(.*)$}) {
379 0 0       0 if ($sha1 eq $this_head) {
380 0 0       0 if ($info_ref) {
381 0         0 $info_ref->{detached} = 1;
382 0         0 $info_ref->{fallback} = 'git-show-ref';
383             }
384 0         0 return $ref;
385             }
386             }
387             }
388 0 0       0 close $fh2
389             or warning "Problem while running 'git show-ref': $!";
390             } else {
391 0         0 warning "Error running 'git show-ref': $!";
392             }
393             }
394             }
395              
396 0         0 undef;
397 49         1195 } $directory;
398             }
399              
400             sub git_config {
401 23     23 1 343 my($self, %opts) = @_;
402 23         204 my $directory = delete $opts{directory};
403 23         79 my $key = delete $opts{key};
404 23         54 my $val = delete $opts{val};
405 23         43 my $unset = delete $opts{unset};
406 23 100       79 error "Unhandled options: " . join(" ", %opts) if %opts;
407 22 100 100     177 if (defined $val && $unset) {
408 1         20 error "Don't specify both 'unset' and 'val'";
409             }
410              
411             in_directory {
412 2     2   16 no warnings 'uninitialized'; # $old_val may be undef
  2         4  
  2         1475  
413 21     21   52 chomp(my($old_val) = eval { $self->info_qx({quiet=>1}, qw(git config), $key) });
  21         240  
414 21 100       654 if ($unset) {
415 2 100       123 if ($@) {
416 1 50       15 if ($@->{exitcode} == 1) {
417             # already non-existent (or even invalid)
418 1         54 0;
419             } else {
420 0         0 error "git config $key failed with exitcode $@->{exitcode}";
421             }
422             } else {
423 1 50       38 $self->system(qw(git config --unset), $key, (defined $val ? $val : ()));
424 1         119 1;
425             }
426             } else {
427 19 100       75 if (!defined $val) {
428 12         955 $old_val;
429             } else {
430 7 100 100     62 if (!defined $old_val || $old_val ne $val) {
431 6         170 $self->system(qw(git config), $key, $val);
432 4         544 1;
433             } else {
434 1         98 0;
435             }
436             }
437             }
438 21         398 } $directory;
439             }
440              
441             sub git_get_default_branch {
442 5     5 1 105 my($self, %opts) = @_;
443 5         26 my $directory = delete $opts{directory};
444 5   50     74 my $origin = delete $opts{origin} || 'origin';
445 5         13 my $method = delete $opts{method};
446 5 50       23 error "Unhandled options: " . join(' ', %opts) if %opts;
447              
448 5 100       34 my @methods = (
    100          
449             ref $method eq 'ARRAY' ? @$method :
450             defined $method ? $method :
451             ()
452             );
453 5 100       21 if (!@methods) { @methods = 'remote' }
  1         11  
454              
455 5         15 my @error_msgs;
456             my $res;
457              
458             in_directory {
459 5     5   19 TRY_METHODS: while (@methods) {
460 5         12 my $method = shift @methods;
461 5 100       27 if ($method eq 'remote') {
    100          
462             # from https://stackoverflow.com/questions/28666357/git-how-to-get-default-branch#comment126528129_50056710
463 2         42 chomp(my $info_res = $self->info_qx({quiet=>1}, qw(env LC_ALL=C git remote show), $origin));
464 2 50       102 if ($info_res =~ /^\s*HEAD branch:\s+(.*)/m) {
465 2         53 $res = $1;
466 2         99 last TRY_METHODS;
467             } else {
468 0         0 push @error_msgs, "method $method: Can't get default branch; git-remote output is:\n$res";
469             }
470             } elsif ($method eq 'symbolic-ref') {
471 2         10 my $parent_ref = 'refs/remotes/' . $origin;
472 2         7 chomp(my $info_res = eval { $self->info_qx({quiet=>1}, qw(git symbolic-ref), "$parent_ref/HEAD") });
  2         15  
473 2 50 33     55 if (defined $info_res && $info_res ne '') {
474 2         24 $res = substr($info_res, length($parent_ref)+1);
475 2         70 last TRY_METHODS;
476             } else {
477 0         0 push @error_msgs, "method $method: Can't get default branch ($@)";
478             }
479             } else {
480 1         36 error "Unhandled git_get_default_branch method '$method'";
481             }
482             }
483 5         97 } $directory;
484              
485 4 50       201 if (@error_msgs) {
486 0         0 error join("\n", @error_msgs);
487             }
488              
489 4         214 $res;
490             }
491              
492              
493             # From https://stackoverflow.com/a/4495524/2332415
494             sub _is_dir_empty {
495 2     2   17 my ($dir) = @_;
496              
497 2 50       131 opendir my $h, $dir
498             or error "Cannot open directory: '$dir': $!";
499              
500 2         62 while (defined (my $entry = readdir $h)) {
501 5 100       105 return unless $entry =~ /^[.][.]?\z/;
502             }
503              
504 1         61 return 1;
505             }
506              
507             sub _pipe_open (@) {
508 139     139   812 my(@cmd) = @_;
509 139         278 my $fh;
510 139         219 if (Doit::IS_WIN && $] < 5.022) {
511             open $fh, '-|', Doit::Win32Util::win32_quote_list(@cmd)
512             or return undef;
513             } else {
514 139 50       343140 open $fh, '-|', @cmd
515             or return undef;
516             }
517 139         6576 return $fh;
518             }
519              
520             1;
521              
522             __END__