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