[430] | 1 | #!/usr/bin/perl |
---|
| 2 | |
---|
| 3 | # trigger build and test if the following condition is satisfied: |
---|
| 4 | # (1) find-out if the latest tag of the form 'madX_3_04_22' |
---|
| 5 | # is located below the last 'madX_test' tag, which means |
---|
| 6 | # some release occured after the last test of the code. |
---|
| 7 | # (2) tag the CVS with 'madX_test'. |
---|
| 8 | |
---|
| 9 | # ... then issue a trigger to the do following: |
---|
| 10 | # (3) do the build when extracting for the last release tag, ignoring |
---|
| 11 | # all changes that occured in between. |
---|
| 12 | # (4) run the test suite |
---|
| 13 | |
---|
| 14 | use MIME::Lite; # to send e-mail |
---|
| 15 | |
---|
| 16 | use File::Path; # to remove directory trees |
---|
| 17 | |
---|
| 18 | |
---|
| 19 | my $trigger; |
---|
| 20 | |
---|
| 21 | |
---|
| 22 | @extractedPackages = ('madX'); |
---|
| 23 | |
---|
| 24 | $pwd = `pwd`; |
---|
| 25 | chop $pwd; |
---|
| 26 | $extractDir = $pwd . "/MadCvsExtract_trigger" ; |
---|
| 27 | rmtree($extractDir); |
---|
| 28 | mkdir($extractDir, 0777); |
---|
| 29 | chdir($extractDir); |
---|
| 30 | |
---|
| 31 | |
---|
| 32 | $cvsDir = ":gserver:isscvs.cern.ch:/local/reps/madx" ; |
---|
| 33 | |
---|
| 34 | |
---|
| 35 | # Do we need to do the check-out or do we rely on FesaBuild.pl instead? |
---|
| 36 | foreach(@extractedPackages) { |
---|
| 37 | my $pack = $_; |
---|
| 38 | # print "Extract package $pack from CVS\n"; |
---|
| 39 | `cvs -d $cvsDir checkout $pack`; |
---|
| 40 | } |
---|
| 41 | |
---|
| 42 | # find-out the latest release |
---|
| 43 | chdir('./madX'); |
---|
| 44 | my $representative = 'madxd.h'; |
---|
| 45 | my @log = `cvs log $representative`; |
---|
| 46 | |
---|
| 47 | @releases = (); |
---|
| 48 | @tests = (); |
---|
| 49 | foreach $line (@log){ |
---|
| 50 | if ($line =~/^[\s\t]*madX-(\d+)_(\d+)_(\d+)[\s\t]*:[\s\t]*([\d\.]+)[\s\t]*$/){ |
---|
| 51 | my $release = "$1_$2_$3"; |
---|
| 52 | $release_revision{$release}=$4; |
---|
| 53 | @releases = (@releases, $release); |
---|
| 54 | # print "found release $1_$2_$3, with revision $4\n"; |
---|
| 55 | } |
---|
| 56 | if ($line =~/^[\s\t]*test-(\d+)_(\d+)_(\d+)[\s\t]*:[\s\t]*([\d\.]+)[\s\t]*$/){ |
---|
| 57 | my $test = "$1_$2_$3"; |
---|
| 58 | $test_revision{$test}=$4; |
---|
| 59 | @tests = (@tests, $test); |
---|
| 60 | # print "found test $1_$2_$3, with revision $4\n"; |
---|
| 61 | } |
---|
| 62 | |
---|
| 63 | } |
---|
| 64 | |
---|
| 65 | my @sortedReleases = sort byDecreasingReleaseNumber @releases; |
---|
| 66 | my @sortedTests = sort byDecreasingReleaseNumber @tests; |
---|
| 67 | |
---|
| 68 | my $lastRelease = @sortedReleases[0]; |
---|
| 69 | my $beforeLastRelease = @sortedReleases[1]; |
---|
| 70 | my $lastTest = @sortedTests[0]; |
---|
| 71 | |
---|
| 72 | # decide whether a new release took place, in which case we shall |
---|
| 73 | # trigger the build and test procedure. |
---|
| 74 | |
---|
| 75 | if ($lastTest eq $lastRelease) { |
---|
| 76 | # there's no need to run the test again. |
---|
| 77 | $trigger = 'do-nothing'; |
---|
| 78 | } else { |
---|
| 79 | # also account for the very first time |
---|
| 80 | my $newTest = $lastRelease; |
---|
| 81 | my $newTestTag = "test-" . $newTest; |
---|
| 82 | # tag the CVS repository |
---|
| 83 | # ... |
---|
| 84 | `cvs tag $newTestTag $representative`; |
---|
| 85 | |
---|
| 86 | # now find-out all the work from the contributors |
---|
| 87 | # that went into the CVS in between the two last releases |
---|
| 88 | |
---|
| 89 | @authors = (); # global variable modified by recordWork |
---|
| 90 | recordWork("madX-$beforeLastRelease", "madX-$lastRelease"); |
---|
| 91 | |
---|
| 92 | # sort @authors by alphabetical order |
---|
| 93 | @authors = sort @authors; |
---|
| 94 | |
---|
| 95 | my $workReport = ""; |
---|
| 96 | $workReport .= "The MAD Build & Test script has detected a tentative candidate release for $lastRelease.\n\n"; |
---|
| 97 | $workReport .= "Since last candidate release, the following changes have been made:\n"; |
---|
| 98 | $workReport .= "\t-Lines-of-code added/deleted between $beforeLastRelease and $lastRelease:\n"; |
---|
| 99 | foreach $auth (@authors){ |
---|
| 100 | $workReport .= "\t\t$auth: +$linesAdded{$auth} -$linesDeleted{$auth}\n"; |
---|
| 101 | } |
---|
| 102 | $workReport .= "\nSee detailed work report on:\n"; |
---|
| 103 | $workReport .= "http://test-mad-automation.web.cern.ch/test-mad-automation/workReport.html\n"; |
---|
| 104 | $workReport .= "\nFrom now on, the test procedure will start and may take several days.\n"; |
---|
| 105 | $workReport .= "\nAt the end of the test procedure, module keepers will be informed "; |
---|
| 106 | $workReport .= "in case of discrepancy between the test's outcome and the reference. \n"; |
---|
| 107 | |
---|
| 108 | # ... and send a summary to the list of watchers by e-mail |
---|
| 109 | |
---|
| 110 | $msg = MIME::Lite->new( |
---|
| 111 | From => 'Jean-Luc.Nougaret@cern.ch', |
---|
| 112 | 'Reply-To' => 'mad-automation-admin@cern.ch', |
---|
| 113 | To => 'mad-module-keepers@cern.ch', |
---|
| 114 | Subject => "MAD $lastRelease release candidate ready for testing.", |
---|
| 115 | Data => $workReport |
---|
| 116 | ); |
---|
| 117 | $msg->send; |
---|
| 118 | $trigger = 'run-test'; |
---|
| 119 | # will cause the MadTest.pl script to run. |
---|
| 120 | |
---|
| 121 | } |
---|
| 122 | chdir($pwd); # back to the top menu |
---|
| 123 | rmtree($extractDir); |
---|
| 124 | |
---|
| 125 | # returned strings for MadBuildAndTest.pl |
---|
| 126 | print "releaseTag=madX-$lastRelease\n"; # \n-terminated |
---|
| 127 | print "trigger=$trigger\n"; # \n-terminated |
---|
| 128 | exit 0; |
---|
| 129 | |
---|
| 130 | sub byDecreasingReleaseNumber { |
---|
| 131 | # sort always assumes $a is to be compared with $b, such as '$f{$a} <=> f{$b}' |
---|
| 132 | # here, all numbers are of the form x+_x+_x+ |
---|
| 133 | my @aNumbers = split /_/, $a; |
---|
| 134 | my @bNumbers = split /_/, $b; |
---|
| 135 | my $counter = 0; |
---|
| 136 | my $result = 0; # default |
---|
| 137 | foreach $aNumber (@aNumbers){ |
---|
| 138 | if ($aNumber<@bNumbers[$counter]){ |
---|
| 139 | $result = 1; |
---|
| 140 | return $result; |
---|
| 141 | } |
---|
| 142 | if ($aNumber>@bNumbers[$counter]){ |
---|
| 143 | $result = -1; |
---|
| 144 | return $result; |
---|
| 145 | } |
---|
| 146 | $counter++; |
---|
| 147 | } |
---|
| 148 | return $result; |
---|
| 149 | } |
---|
| 150 | |
---|
| 151 | sub recordWork { |
---|
| 152 | $rel1 = $_[0]; # first release |
---|
| 153 | $rel2 = $_[1]; # second release |
---|
| 154 | @files = `ls *.*`; |
---|
| 155 | @makefiles = `ls Make*`; |
---|
| 156 | @files = (@files, @makefiles); |
---|
| 157 | # print "rel1 is $rel1, rel2 is $rel2\n"; |
---|
| 158 | foreach $file (@files){ |
---|
| 159 | chop $file; |
---|
| 160 | my @logs = `cvs log $file`; |
---|
| 161 | # first look for the revisions associated to the first and second releases |
---|
| 162 | foreach $log (@logs){ |
---|
| 163 | |
---|
| 164 | my $pattern1 = "^[\\s\\t]*$rel1\[\\s\\t]*:[\\s\\t]*([\\d\\.]+)[\\s\\t]*\$"; |
---|
| 165 | # print "pattern is $pattern\n"; |
---|
| 166 | if ($log =~/$pattern1/){ |
---|
| 167 | $rev1 = $1; |
---|
| 168 | # print "$file: $rel1 -> revision 1 is $rev1\n"; |
---|
| 169 | } |
---|
| 170 | my $pattern2 = "^[\\s\\t]*$rel2\[\\s\\t]*:[\\s\\t]*([\\d\\.]+)[\\s\\t]*\$"; |
---|
| 171 | if ($log =~ /$pattern2/){ |
---|
| 172 | $rev2 = $1; |
---|
| 173 | # print "$file: $rel2 -> revision 2 is $rev2\n"; |
---|
| 174 | } |
---|
| 175 | } |
---|
| 176 | |
---|
| 177 | # now look for the authors having modified the code between release 1 and 2 |
---|
| 178 | # (including the latter). |
---|
| 179 | # to this end, check all revisions located between $rev1 and $rev2 for given file |
---|
| 180 | |
---|
| 181 | my @numbers1 = split /\./, $rev1; |
---|
| 182 | my @numbers2 = split /\./, $rev2; |
---|
| 183 | |
---|
| 184 | # re-scan log for this file in order to find-out revision work |
---|
| 185 | # in a CVS log info looks like the following: |
---|
| 186 | # revision: 1.2.3 |
---|
| 187 | # date: ... author: ... |
---|
| 188 | my $retreiveDetailedWorkInfoMode = 0 ; # some state-variable |
---|
| 189 | |
---|
| 190 | LOG_SCAN: foreach $log (@logs){ |
---|
| 191 | if ($retreiveDetailedWorkInfoMode == 1){ |
---|
| 192 | #print "Mode: retreive detailed work info\n"; |
---|
| 193 | #print "Process line $log\n"; |
---|
| 194 | if ($log =~ /author[\s\t]*:[\s\t]*(\w+);/){ |
---|
| 195 | my $candidate = $1; |
---|
| 196 | # print "found work-unit carried-out by $candidate\n"; |
---|
| 197 | # make sure author is not already in the list |
---|
| 198 | my $alreadyRecorded = 0; |
---|
| 199 | foreach $auth (@authors){ |
---|
| 200 | if ($auth eq $candidate) { |
---|
| 201 | $alreadyRecorded = 1; |
---|
| 202 | } |
---|
| 203 | } |
---|
| 204 | |
---|
| 205 | $log =~ /;[\s\t]+lines:[\s\t]+\+(\d+)[\s\t]+\-(\d+)[\s\t]*;/; |
---|
| 206 | # print "work is +$1 -$2 LOC\n"; |
---|
| 207 | if ($alreadyRecorded == 0 ) { |
---|
| 208 | @authors = ( @authors, $candidate ); |
---|
| 209 | $linesAdded{$candidate} = $1; |
---|
| 210 | $linesDeleted{$candidate} = $2; |
---|
| 211 | } else { |
---|
| 212 | $linesAdded{$candidate} += $1; |
---|
| 213 | $linesDeleted{$candidate} += $2; |
---|
| 214 | |
---|
| 215 | } |
---|
| 216 | } |
---|
| 217 | $retreiveDetailedWorkInfoMode = 0; |
---|
| 218 | } |
---|
| 219 | if ($log =~ /^[\s\t]*revision[\s\t]+([\d\.]+)[\s\t]*$/){ |
---|
| 220 | # same number of dots? |
---|
| 221 | my $rev = $1; |
---|
| 222 | my @numbers = split /\./, $rev; |
---|
| 223 | # print "about to compare $rev1 < $rev < $rev2 ?\n"; |
---|
| 224 | if (scalar(@numbers) == scalar(@numbers2)) { |
---|
| 225 | # now check that $rev1 < $rev <= $rev2 |
---|
| 226 | # and record the author & work in this case |
---|
| 227 | # print "compare $rev1 < $rev < $rev2 ?\n"; |
---|
| 228 | my $counter = 0; |
---|
| 229 | foreach $number (@numbers){ |
---|
| 230 | if ($number<@numbers1[$counter]) { next LOG_SCAN; } |
---|
| 231 | if ($number>@numbers2[$counter]) { next LOG_SCAN; } |
---|
| 232 | $counter++; |
---|
| 233 | } |
---|
| 234 | |
---|
| 235 | # special case: $rev = $ rev1 => of no interest |
---|
| 236 | if ($rev eq $rev1) { next LOG_SCAN; } |
---|
| 237 | |
---|
| 238 | # if we reach this point, the comparison was succesful |
---|
| 239 | # =>advance to the next log line contains the author |
---|
| 240 | $retreiveDetailedWorkInfoMode = 1; |
---|
| 241 | # print "$file: contribution found $rev1 < $rev <= $rev2\n"; |
---|
| 242 | |
---|
| 243 | } else { |
---|
| 244 | next LOG_SCAN; |
---|
| 245 | } |
---|
| 246 | |
---|
| 247 | } |
---|
| 248 | } |
---|
| 249 | |
---|
| 250 | |
---|
| 251 | |
---|
| 252 | } |
---|
| 253 | } |
---|