9b006cd1b899b07b9bd46f2c2560cadc15beb6bf
[buildfarm-client.git] / EximBuild / SCM.pm
1 use strict;
2
3 use File::Find;
4 use Cwd;
5
6 =comment
7
8 Copyright (c) 2003-2010, Andrew Dunstan
9
10 See accompanying License file for license details
11
12 =cut
13
14 ##########################################################################
15 #
16 # SCM Class and subclasses for specific SCMs (currently CVS and git).
17 #
18 #########################################################################
19
20 package EximBuild::SCM;
21
22 use vars qw($VERSION); $VERSION = 'REL_0.1';
23
24 # factory function to return the right subclass
25 sub new
26 {
27     my $class = shift;
28     my $conf = shift;
29     my $target = shift || 'exim';
30     if (defined($conf->{scm}) &&  $conf->{scm} =~ /^git$/i)
31     {
32         $conf->{scm} = 'git';
33         return new EximBuild::SCM::Git $conf, $target;
34     }
35     #elsif ((defined($conf->{scm}) &&  $conf->{scm} =~ /^cvs$/i )
36     #    ||$conf->{csvrepo}
37     #    ||$conf->{cvsmethod})
38     #{
39     #    $conf->{scm} = 'cvs';
40     #    return new EximBuild::SCM::CVS $conf, $target;
41     #}
42     die "only Git currently supported";
43 }
44
45 # common routine use for copying the source, called by the
46 # SCM objects (directly, not as class methods)
47 sub copy_source
48 {
49     my $using_msvc = shift;
50     my $target = shift;
51     my $build_path = shift;
52
53     # annoyingly, there isn't a standard perl module to do a recursive copy
54     # and I don't want to require use of the non-standard File::Copy::Recursive
55     system("cp -r $target $build_path 2>&1");
56     my $status = $? >> 8;
57     die "copying directories: $status" if $status;
58
59 }
60
61 # required operations in each subclass:
62 # new()
63 # copy_source_required()
64 # copy_source()
65 # check_access()
66 # get_build_path()
67 # checkout()
68 # cleanup()
69 # find_changed()
70 # get_versions()
71 # log_id()
72
73 ##################################
74 #
75 # SCM for git
76 #
77 ##################################
78
79 package EximBuild::SCM::Git;
80
81 use File::Copy;
82 use Cwd;
83
84 sub new
85 {
86     my $class = shift;
87     my $conf = shift;
88     my $target = shift;
89     my $self = {};
90     $self->{gitrepo} = $conf->{scmrepo} ||
91                        "git://git.exim.org/exim.git";
92     $self->{reference} = $conf->{git_reference}
93       if defined($conf->{git_reference});
94     $self->{mirror} =(
95         $target eq 'exim'
96         ? "$conf->{build_root}/exim.git"
97         :"$conf->{build_root}/$target-exim.git"
98     )if $conf->{git_keep_mirror};
99     $self->{ignore_mirror_failure} = $conf->{git_ignore_mirror_failure};
100     $self->{target} = $target;
101     return bless $self, $class;
102 }
103
104 sub copy_source_required
105 {
106     my $self = shift;
107
108     # always copy git
109     return 1;
110 }
111
112 sub copy_source
113 {
114     my $self = shift;
115     my $using_msvc = shift;
116     my $target = $self->{target};
117     my $build_path = $self->{build_path};
118     die "no build path" unless $build_path;
119
120     # we don't want to copy the (very large) .git directory
121     # so we just move it out of the way during the copy
122     # there might be better ways of doing this, but this should do for now
123
124     move "$target/.git", "./git-save";
125     EximBuild::SCM::copy_source($using_msvc,$target,$build_path);
126     move "./git-save","$target/.git";
127 }
128
129 sub get_build_path
130 {
131     my $self = shift;
132     my $use_vpath = shift; # irrelevant for git
133     my $target = $self->{target};
134     $self->{build_path} = "$target.$$";
135     return      $self->{build_path};
136 }
137
138 sub check_access
139 {
140
141     # no login required?
142     return;
143 }
144
145 sub log_id
146 {
147     my $self = shift;
148     main::writelog('githead',[$self->{headref}])
149       if $self->{headref};
150 }
151
152 sub checkout
153 {
154
155     my $self = shift;
156     my $branch = shift;
157     my $gitserver = $self->{gitrepo};
158     my $target = $self->{target};
159     my $status;
160
161     # Msysgit does some horrible things, especially when it expects a drive
162     # spec and doesn't get one.  So we extract it if it exists and use it
163     # where necessary.
164     my $drive = "";
165     my $cwd = getcwd();
166     $drive = substr($cwd,0,2) if $cwd =~ /^[A-Z]:/;
167
168     my @gitlog;
169     if ($self->{mirror})
170     {
171
172         my $mirror = $target eq 'exim' ? 'exim.git' : "$target-exim.git";
173
174         if (-d $self->{mirror})
175         {
176             @gitlog = `git --git-dir="$self->{mirror}" fetch 2>&1`;
177             $status = $self->{ignore_mirror_failure} ? 0 : $? >> 8;
178         }
179         else
180         {
181             my $char1 = substr($gitserver,0,1);
182             $gitserver = "$drive$gitserver"
183               if ( $char1 eq '/' or $char1 eq '\\');
184
185             # this will fail on older git versions
186             # workaround is to do this manually in the buildroot:
187             #   git clone --bare $gitserver exim.git
188             #   (cd exim.git && git remote add --mirror origin $gitserver)
189             # or equivalent for other targets
190             @gitlog = `git clone --mirror $gitserver $self->{mirror} 2>&1`;
191             $status = $? >>8;
192         }
193         if ($status)
194         {
195             unshift(@gitlog,"Git mirror failure:\n");
196             print @gitlog if ($main::verbose);
197             main::send_result('Git-mirror',$status,\@gitlog);
198         }
199     }
200
201     push @gitlog, "Git arguments:\n".
202                   "  branch=$branch gitserver=$gitserver target=$target\n\n";
203
204     if (-d $target)
205     {
206         # First check and see if git is in path
207         `which git 2>&1`;
208         if ($? != 0)
209         {
210             my @ret = `env`;
211             unshift @ret, "git not found in path\n";
212             main::send_result("$target-Git",$status,\@ret);
213         }
214
215         chdir $target;
216         my @branches = `git branch 2>&1`;
217         unless (grep {/^\* bf_\Q$branch\E$/} @branches)
218         {
219             chdir '..';
220             print "Missing checked out branch bf_$branch:\n",@branches
221               if ($main::verbose);
222             unshift @branches,"Missing checked out branch bf_$branch in " . cwd() . ":\n";
223             main::send_result("$target-Git",$status,\@branches);
224         }
225         my @pulllog = `git pull 2>&1`;
226         push(@gitlog,@pulllog);
227         chdir '..';
228     }
229     else
230     {
231         my $reference =
232           defined($self->{reference}) ?"--reference $self->{reference}" : "";
233
234         my $base = $self->{mirror} || $gitserver;
235
236         my $char1 = substr($base,0,1);
237         $base = "$drive$base"
238           if ( $char1 eq '/' or $char1 eq '\\');
239
240         my @clonelog = `git clone -q $reference $base $target 2>&1`;
241         push(@gitlog,@clonelog);
242         $status = $? >>8;
243         if (!$status)
244         {
245             chdir $target;
246
247             # make sure we don't name the new branch HEAD
248             # also, safer to checkout origin/master than origin/HEAD, I think
249             my $rbranch = $branch eq 'HEAD' ? 'master' : $branch;
250             my @colog =
251               `git checkout -b bf_$branch --track origin/$rbranch 2>&1`;
252             push(@gitlog,@colog);
253             chdir "..";
254         }
255     }
256     $status = $? >>8;
257     print "================== git log =====================\n",@gitlog
258       if ($main::verbose > 1);
259
260     # can't call writelog here because we call cleanlogs after the
261     # checkout stage, since we only clear out the logs if we find we need to
262     # do a build run.
263     # consequence - we don't save the git log if we don't do a run
264     # doesn't matter too much because if git fails we exit anyway.
265
266     # Don't call git clean here. If the user has left stuff lying around it
267     # might be important to them, so instead of blowing it away just bitch
268     # loudly.
269
270     chdir "$target";
271     my @gitstat = `git status --porcelain 2>&1`;
272     chdir "..";
273
274     my ($headref,$refhandle);
275     if (open($refhandle,"$target/.git/refs/heads/bf_$branch"))
276     {
277         $headref = <$refhandle>;
278         chomp $headref;
279         close($refhandle);
280         $self->{headref} = $headref;
281     }
282
283     main::send_result("$target-Git",$status,\@gitlog)   if ($status);
284     unless ($main::nosend && $main::nostatus)
285     {
286         push(@gitlog,"===========",@gitstat);
287         main::send_result("$target-Git-Dirty",99,\@gitlog)
288           if (@gitstat);
289     }
290
291     # if we were successful, however, we return the info so that
292     # we can put it in the newly cleaned logdir  later on.
293     return \@gitlog;
294 }
295
296 sub cleanup
297 {
298     my $self = shift;
299     my $target = $self->{target};
300     chdir $target;
301     system("git clean -dfxq");
302     chdir "..";
303 }
304
305 # private Class level routine for getting changed file data
306 sub parse_log
307 {
308     my $cmd = shift;
309     my @lines = `$cmd`;
310     chomp(@lines);
311     my $commit;
312     my $list = {};
313     foreach my $line (@lines)
314     {
315         next if $line =~ /^(Author:|Date:|\s)/;
316         next unless $line;
317         if ($line =~ /^commit ([0-9a-zA-Z]+)/)
318         {
319             $commit = $1;
320         }
321         else
322         {
323
324             # anything else should be a file name
325             $line =~ s/\s+$//; # make sure all trailing space is trimmed
326             $list->{$line} ||= $commit; # keep most recent commit
327         }
328     }
329     return $list;
330 }
331
332 sub find_changed
333 {
334     my $self = shift;
335     my $target = $self->{target};
336     my $current_snap = shift;
337     my $last_run_snap = shift;
338     my $last_success_snap = shift || 0;
339     my $changed_files = shift;
340     my $changed_since_success = shift;
341
342     my $cmd = qq{git --git-dir=$target/.git log -n 1 "--pretty=format:%ct"};
343     $$current_snap = `$cmd` +0;
344
345     # get the list of changed files and stash the commit data
346
347     if ($last_run_snap)
348     {
349         if ($last_success_snap > 0 && $last_success_snap < $last_run_snap)
350         {
351             $last_success_snap++;
352             my $lrsscmd ="git  --git-dir=$target/.git log --name-only "
353               ."--since=$last_success_snap --until=$last_run_snap";
354             $self->{changed_since_success} = parse_log($lrsscmd);
355         }
356         else
357         {
358             $self->{changed_since_success} = {};
359         }
360         $last_run_snap++;
361         my $lrscmd ="git  --git-dir=$target/.git log --name-only "
362           ."--since=$last_run_snap";
363         $self->{changed_since_last_run} = parse_log($lrscmd);
364         foreach my $file (keys %{$self->{changed_since_last_run}})
365         {
366             delete $self->{changed_since_success}->{$file};
367         }
368     }
369     else
370     {
371         $self->{changed_since_last_run} = {};
372     }
373
374     @$changed_files = sort keys %{$self->{changed_since_last_run}};
375     @$changed_since_success = sort keys %{$self->{changed_since_success}};
376 }
377
378 sub get_versions
379 {
380     my $self = shift;
381     my $flist = shift;
382     return unless @$flist;
383     my @repoversions;
384
385     # for git we have already collected and stashed the info, so we just
386     # extract it from the stash.
387
388     foreach my $file (@$flist)
389     {
390         if (exists $self->{changed_since_last_run}->{$file})
391         {
392             my $commit = $self->{changed_since_last_run}->{$file};
393             push(@repoversions,"$file $commit");
394         }
395         elsif (exists $self->{changed_since_success}->{$file})
396         {
397             my $commit = $self->{changed_since_success}->{$file};
398             push(@repoversions,"$file $commit");
399         }
400     }
401     @$flist = @repoversions;
402 }
403
404 1;