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_\Q$branch\E$/} @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 in $target:\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;