[1980] | 1 | # ------------------------------------------------------------------------------ |
---|
| 2 | # NAME |
---|
| 3 | # Fcm::ExtractFile |
---|
| 4 | # |
---|
| 5 | # DESCRIPTION |
---|
| 6 | # Select/combine a file in different branches and extract it to destination. |
---|
| 7 | # |
---|
| 8 | # COPYRIGHT |
---|
| 9 | # (C) Crown copyright Met Office. All rights reserved. |
---|
| 10 | # For further details please refer to the file COPYRIGHT.txt |
---|
| 11 | # which you should have received as part of this distribution. |
---|
| 12 | # ------------------------------------------------------------------------------ |
---|
| 13 | |
---|
| 14 | use warnings; |
---|
| 15 | use strict; |
---|
| 16 | |
---|
| 17 | package Fcm::ExtractFile; |
---|
| 18 | use base qw{Fcm::Base}; |
---|
| 19 | |
---|
| 20 | use Fcm::Util qw{run_command w_report}; |
---|
| 21 | use File::Basename qw{dirname}; |
---|
| 22 | use File::Compare qw{compare}; |
---|
| 23 | use File::Copy qw{copy}; |
---|
| 24 | use File::Path qw{mkpath}; |
---|
| 25 | use File::Spec; |
---|
| 26 | use File::Temp qw(tempfile); |
---|
| 27 | |
---|
| 28 | # List of property methods for this class |
---|
| 29 | my @scalar_properties = ( |
---|
| 30 | 'conflict', # conflict mode |
---|
| 31 | 'dest', # search path to destination file |
---|
| 32 | 'dest_status', # destination status, see below |
---|
| 33 | 'pkgname', # package name of this file |
---|
| 34 | 'src', # list of Fcm::ExtractSrc, specified for this file |
---|
| 35 | 'src_actual', # list of Fcm::ExtractSrc, actually used by this file |
---|
| 36 | 'src_status', # source status, see below |
---|
| 37 | ); |
---|
| 38 | |
---|
| 39 | # Status code definition for $self->dest_status |
---|
| 40 | our %DEST_STATUS_CODE = ( |
---|
| 41 | '' => 'unchanged', |
---|
| 42 | 'M' => 'modified', |
---|
| 43 | 'A' => 'added', |
---|
| 44 | 'a' => 'added, overridding inherited', |
---|
| 45 | 'D' => 'deleted', |
---|
| 46 | 'd' => 'deleted, overridding inherited', |
---|
| 47 | '?' => 'irrelevant', |
---|
| 48 | ); |
---|
| 49 | |
---|
| 50 | # Status code definition for $self->src_status |
---|
| 51 | our %SRC_STATUS_CODE = ( |
---|
| 52 | 'A' => 'added by a branch', |
---|
| 53 | 'B' => 'from the base', |
---|
| 54 | 'D' => 'deleted by a branch', |
---|
| 55 | 'M' => 'modified by a branch', |
---|
| 56 | 'G' => 'merged from 2+ branches', |
---|
| 57 | 'O' => 'overridden by a branch', |
---|
| 58 | '?' => 'irrelevant', |
---|
| 59 | ); |
---|
| 60 | |
---|
| 61 | # ------------------------------------------------------------------------------ |
---|
| 62 | # SYNOPSIS |
---|
| 63 | # $obj = Fcm::ExtractFile->new (); |
---|
| 64 | # |
---|
| 65 | # DESCRIPTION |
---|
| 66 | # This method constructs a new instance of the Fcm::ExtractFile class. |
---|
| 67 | # ------------------------------------------------------------------------------ |
---|
| 68 | |
---|
| 69 | sub new { |
---|
| 70 | my $this = shift; |
---|
| 71 | my %args = @_; |
---|
| 72 | my $class = ref $this || $this; |
---|
| 73 | |
---|
| 74 | my $self = Fcm::Base->new (%args); |
---|
| 75 | |
---|
| 76 | for (@scalar_properties) { |
---|
| 77 | $self->{$_} = exists $args{$_} ? $args{$_} : undef; |
---|
| 78 | } |
---|
| 79 | |
---|
| 80 | bless $self, $class; |
---|
| 81 | return $self; |
---|
| 82 | } |
---|
| 83 | |
---|
| 84 | # ------------------------------------------------------------------------------ |
---|
| 85 | # SYNOPSIS |
---|
| 86 | # $value = $obj->X; |
---|
| 87 | # $obj->X ($value); |
---|
| 88 | # |
---|
| 89 | # DESCRIPTION |
---|
| 90 | # Details of these properties are explained in @scalar_properties. |
---|
| 91 | # ------------------------------------------------------------------------------ |
---|
| 92 | |
---|
| 93 | for my $name (@scalar_properties) { |
---|
| 94 | no strict 'refs'; |
---|
| 95 | |
---|
| 96 | *$name = sub { |
---|
| 97 | my $self = shift; |
---|
| 98 | |
---|
| 99 | # Argument specified, set property to specified argument |
---|
| 100 | if (@_) { |
---|
| 101 | $self->{$name} = $_[0]; |
---|
| 102 | } |
---|
| 103 | |
---|
| 104 | # Default value for property |
---|
| 105 | if (not defined $self->{$name}) { |
---|
| 106 | if ($name eq 'conflict') { |
---|
| 107 | $self->{$name} = 'merge'; # default to "merge" mode |
---|
| 108 | |
---|
| 109 | } elsif ($name eq 'dest' or $name eq 'src' or $name eq 'src_actual') { |
---|
| 110 | $self->{$name} = []; # default to an empty list |
---|
| 111 | } |
---|
| 112 | } |
---|
| 113 | |
---|
| 114 | return $self->{$name}; |
---|
| 115 | } |
---|
| 116 | } |
---|
| 117 | |
---|
| 118 | # ------------------------------------------------------------------------------ |
---|
| 119 | # SYNOPSIS |
---|
| 120 | # $rc = $obj->run(); |
---|
| 121 | # |
---|
| 122 | # DESCRIPTION |
---|
| 123 | # This method runs only if $self->dest_status is not defined. It updates the |
---|
| 124 | # destination according to the source in the list and the conflict mode |
---|
| 125 | # setting. It updates the file in $self->dest as appropriate and sets |
---|
| 126 | # $self->dest_status. (See above.) This method returns true on success. |
---|
| 127 | # ------------------------------------------------------------------------------ |
---|
| 128 | |
---|
| 129 | sub run { |
---|
| 130 | my ($self) = @_; |
---|
| 131 | my $rc = 1; |
---|
| 132 | |
---|
| 133 | if (not defined ($self->dest_status)) { |
---|
| 134 | # Assume file unchanged |
---|
| 135 | $self->dest_status (''); |
---|
| 136 | |
---|
| 137 | if (@{ $self->src }) { |
---|
| 138 | my $used; |
---|
| 139 | # Determine or set up a file for comparing with the destination |
---|
| 140 | ($rc, $used) = $self->run_get_used(); |
---|
| 141 | |
---|
| 142 | # Attempt to compare the destination with $used. Update on change. |
---|
| 143 | if ($rc) { |
---|
| 144 | $rc = defined ($used) ? $self->run_update($used) : $self->run_delete(); |
---|
| 145 | } |
---|
| 146 | |
---|
| 147 | } else { |
---|
| 148 | # No source, delete file in destination |
---|
| 149 | $self->src_status ('?'); |
---|
| 150 | $rc = $self->run_delete(); |
---|
| 151 | } |
---|
| 152 | } |
---|
| 153 | |
---|
| 154 | return $rc; |
---|
| 155 | } |
---|
| 156 | |
---|
| 157 | # ------------------------------------------------------------------------------ |
---|
| 158 | # SYNOPSIS |
---|
| 159 | # $rc = $obj->run_delete(); |
---|
| 160 | # |
---|
| 161 | # DESCRIPTION |
---|
| 162 | # This method is part of run(). It detects this file in the destination path. |
---|
| 163 | # If this file is in the current destination, it attempts to delete it and |
---|
| 164 | # sets the dest_status to "D". If this file is in an inherited destination, |
---|
| 165 | # it sets the dest_status to "d". |
---|
| 166 | # ------------------------------------------------------------------------------ |
---|
| 167 | |
---|
| 168 | sub run_delete { |
---|
| 169 | my ($self) = @_; |
---|
| 170 | |
---|
| 171 | my $rc = 1; |
---|
| 172 | |
---|
| 173 | $self->dest_status ('?'); |
---|
| 174 | for my $i (0 .. @{ $self->dest } - 1) { |
---|
| 175 | my $dest = File::Spec->catfile ($self->dest->[$i], $self->pkgname); |
---|
| 176 | next unless -f $dest; |
---|
| 177 | if ($i == 0) { |
---|
| 178 | $rc = unlink $dest; |
---|
| 179 | $self->dest_status ('D'); |
---|
| 180 | |
---|
| 181 | } else { |
---|
| 182 | $self->dest_status ('d'); |
---|
| 183 | last; |
---|
| 184 | } |
---|
| 185 | } |
---|
| 186 | |
---|
| 187 | return $rc; |
---|
| 188 | } |
---|
| 189 | |
---|
| 190 | # ------------------------------------------------------------------------------ |
---|
| 191 | # SYNOPSIS |
---|
| 192 | # ($rc, $used) = $obj->run_get_used(); |
---|
| 193 | # |
---|
| 194 | # DESCRIPTION |
---|
| 195 | # This method is part of run(). It attempts to work out or set up the $used |
---|
| 196 | # file. ($used is undef if it is not defined in a branch for this file.) |
---|
| 197 | # ------------------------------------------------------------------------------ |
---|
| 198 | |
---|
| 199 | sub run_get_used { |
---|
| 200 | my ($self) = @_; |
---|
| 201 | my $rc = 1; |
---|
| 202 | my $used; |
---|
| 203 | |
---|
| 204 | my @sources = ($self->src->[0]); |
---|
| 205 | my $src_status = 'B'; |
---|
| 206 | if (defined ($self->src->[0]->cache)) { |
---|
| 207 | # File exists in base branch |
---|
| 208 | for my $i (1 .. @{ $self->src } - 1) { |
---|
| 209 | if (defined ($self->src->[$i]->cache)) { |
---|
| 210 | # Detect changes in this file between base branch and branch $i |
---|
| 211 | push @sources, $self->src->[$i] |
---|
| 212 | if &compare ($self->src->[0]->cache, $self->src->[$i]->cache); |
---|
| 213 | |
---|
| 214 | } else { |
---|
| 215 | # File deleted in branch $i |
---|
| 216 | @sources = ($self->src->[$i]); |
---|
| 217 | last unless $self->conflict eq 'override'; |
---|
| 218 | } |
---|
| 219 | } |
---|
| 220 | |
---|
| 221 | if ($rc) { |
---|
| 222 | if (@sources > 2) { |
---|
| 223 | if ($self->conflict eq 'fail') { |
---|
| 224 | # On conflict, fail in fail mode |
---|
| 225 | w_report 'ERROR: ', $self->pkgname, |
---|
| 226 | ': modified in 2+ branches in fail conflict mode.'; |
---|
| 227 | $rc = undef; |
---|
| 228 | |
---|
| 229 | } elsif ($self->conflict eq 'override') { |
---|
| 230 | $used = $sources[-1]->cache; |
---|
| 231 | $src_status = 'O'; |
---|
| 232 | |
---|
| 233 | } else { |
---|
| 234 | # On conflict, attempt to merge in merge mode |
---|
| 235 | ($rc, $used) = $self->run_get_used_by_merge (@sources); |
---|
| 236 | $src_status = 'G' if $rc; |
---|
| 237 | } |
---|
| 238 | |
---|
| 239 | } else { |
---|
| 240 | # 0 or 1 change, use last source |
---|
| 241 | if (defined $sources[-1]->cache) { |
---|
| 242 | $used = $sources[-1]->cache; |
---|
| 243 | $src_status = 'M' if @sources > 1; |
---|
| 244 | |
---|
| 245 | } else { |
---|
| 246 | $src_status = 'D'; |
---|
| 247 | } |
---|
| 248 | } |
---|
| 249 | } |
---|
| 250 | |
---|
| 251 | } else { |
---|
| 252 | # File does not exist in base branch |
---|
| 253 | @sources = ($self->src->[-1]); |
---|
| 254 | $used = $self->src->[1]->cache; |
---|
| 255 | $src_status = (defined ($used) ? 'A' : 'D'); |
---|
| 256 | if ($self->conflict ne 'override' and defined ($used)) { |
---|
| 257 | for my $i (1 - @{ $self->src } .. -2) { |
---|
| 258 | # Allow this only if files are the same in all branches |
---|
| 259 | my $file = $self->src->[$i]->cache; |
---|
| 260 | if ((not defined ($file)) or &compare ($used, $file)) { |
---|
| 261 | w_report 'ERROR: ', $self->pkgname, ': cannot merge:', |
---|
| 262 | ' not found in base branch,', |
---|
| 263 | ' but differs in subsequent branches.'; |
---|
| 264 | $rc = undef; |
---|
| 265 | last; |
---|
| 266 | |
---|
| 267 | } else { |
---|
| 268 | unshift @sources, $self->src->[$i]; |
---|
| 269 | } |
---|
| 270 | } |
---|
| 271 | } |
---|
| 272 | } |
---|
| 273 | |
---|
| 274 | $self->src_status ($src_status); |
---|
| 275 | $self->src_actual (\@sources); |
---|
| 276 | |
---|
| 277 | return ($rc, $used); |
---|
| 278 | } |
---|
| 279 | |
---|
| 280 | # ------------------------------------------------------------------------------ |
---|
| 281 | # SYNOPSIS |
---|
| 282 | # ($rc, $used) = $obj->run_get_used_by_merge(@soruces); |
---|
| 283 | # |
---|
| 284 | # DESCRIPTION |
---|
| 285 | # This method is part of run_get_used(). It attempts to merge the files in |
---|
| 286 | # @sources and return a temporary file $used. @sources should be an array of |
---|
| 287 | # Fcm::ExtractSrc objects. On success, $rc will be set to true. |
---|
| 288 | # ------------------------------------------------------------------------------ |
---|
| 289 | |
---|
| 290 | sub run_get_used_by_merge { |
---|
| 291 | my ($self, @sources) = @_; |
---|
| 292 | my $rc = 1; |
---|
| 293 | |
---|
| 294 | # Get temporary file |
---|
| 295 | my ($fh, $used) = &tempfile ('fcm.ext.merge.XXXXXX', UNLINK => 1); |
---|
| 296 | close $fh or die $used, ': cannot close'; |
---|
| 297 | |
---|
| 298 | for my $i (2 .. @sources - 1) { |
---|
| 299 | # Invoke the diff3 command to merge |
---|
| 300 | my $mine = ($i == 2 ? $sources[1]->cache : $used); |
---|
| 301 | my $older = $sources[0]->cache; |
---|
| 302 | my $yours = $sources[$i]->cache; |
---|
| 303 | my @command = ( |
---|
| 304 | $self->setting (qw/TOOL DIFF3/), |
---|
| 305 | split (/\s+/, $self->setting (qw/TOOL DIFF3FLAGS/)), |
---|
| 306 | $mine, $older, $yours, |
---|
| 307 | ); |
---|
| 308 | my $code; |
---|
| 309 | my @out = &run_command ( |
---|
| 310 | \@command, |
---|
| 311 | METHOD => 'qx', |
---|
| 312 | ERROR => 'ignore', |
---|
| 313 | PRINT => $self->verbose > 1, |
---|
| 314 | RC => \$code, |
---|
| 315 | TIME => $self->verbose > 2, |
---|
| 316 | ); |
---|
| 317 | |
---|
| 318 | if ($code) { |
---|
| 319 | # Failure, report and return |
---|
| 320 | my $m = ($code == 1) |
---|
| 321 | ? 'cannot resolve conflicts:' |
---|
| 322 | : $self->setting (qw/TOOL DIFF3/) . 'command failed'; |
---|
| 323 | w_report 'ERROR: ', $self->pkgname, ': merge - ', $m; |
---|
| 324 | if ($code == 1 and $self->verbose) { |
---|
| 325 | for (0 .. $i) { |
---|
| 326 | my $src = $sources[$_]->uri eq $sources[$_]->cache |
---|
| 327 | ? $sources[$_]->cache |
---|
| 328 | : ($sources[$_]->uri . '@' . $sources[$_]->rev); |
---|
| 329 | w_report ' source[', $_, ']=', $src; |
---|
| 330 | } |
---|
| 331 | |
---|
| 332 | for (0 .. $i) { |
---|
| 333 | w_report ' cache', $_, '=', $sources[$_]->cache; |
---|
| 334 | } |
---|
| 335 | |
---|
| 336 | w_report @out if $self->verbose > 2; |
---|
| 337 | } |
---|
| 338 | $rc = undef; |
---|
| 339 | last; |
---|
| 340 | |
---|
| 341 | } else { |
---|
| 342 | # Success, write result to temporary file |
---|
| 343 | open FILE, '>', $used or die $used, ': cannot open (', $!, ')'; |
---|
| 344 | print FILE @out; |
---|
| 345 | close FILE or die $used, ': cannot close (', $!, ')'; |
---|
| 346 | |
---|
| 347 | # File permission, use most permissive combination of $mine and $yours |
---|
| 348 | my $perm = ((stat($mine))[2] & 07777) | ((stat($yours))[2] & 07777); |
---|
| 349 | chmod ($perm, $used); |
---|
| 350 | } |
---|
| 351 | } |
---|
| 352 | |
---|
| 353 | return ($rc, $used); |
---|
| 354 | } |
---|
| 355 | |
---|
| 356 | # ------------------------------------------------------------------------------ |
---|
| 357 | # SYNOPSIS |
---|
| 358 | # $rc = $obj->run_update($used_file); |
---|
| 359 | # |
---|
| 360 | # DESCRIPTION |
---|
| 361 | # This method is part of run(). It compares the $used_file with the one in |
---|
| 362 | # the destination. If the file does not exist in the destination or if its |
---|
| 363 | # content is out of date, the destination is updated with the content in the |
---|
| 364 | # $used_file. Returns true on success. |
---|
| 365 | # ------------------------------------------------------------------------------ |
---|
| 366 | |
---|
| 367 | sub run_update { |
---|
| 368 | my ($self, $used_file) = @_; |
---|
| 369 | my ($is_diff, $is_diff_in_perms, $is_in_prev, $rc) = (1, 1, undef, 1); |
---|
| 370 | |
---|
| 371 | # Compare with the previous version if it exists |
---|
| 372 | DEST: |
---|
| 373 | for my $i (0 .. @{$self->dest()} - 1) { |
---|
| 374 | my $prev_file = File::Spec->catfile($self->dest()->[$i], $self->pkgname()); |
---|
| 375 | if (-f $prev_file) { |
---|
| 376 | $is_in_prev = $i; |
---|
| 377 | $is_diff = compare($used_file, $prev_file); |
---|
| 378 | $is_diff_in_perms = (stat($used_file))[2] != (stat($prev_file))[2]; |
---|
| 379 | last DEST; |
---|
| 380 | } |
---|
| 381 | } |
---|
| 382 | if (!$is_diff && !$is_diff_in_perms) { |
---|
| 383 | return $rc; |
---|
| 384 | } |
---|
| 385 | |
---|
| 386 | # Update destination |
---|
| 387 | my $dest_file = File::Spec->catfile($self->dest()->[0], $self->pkgname()); |
---|
| 388 | if ($is_diff) { |
---|
| 389 | my $dir = dirname($dest_file); |
---|
| 390 | if (!-d $dir) { |
---|
| 391 | mkpath($dir); |
---|
| 392 | } |
---|
| 393 | $rc = copy($used_file, $dest_file); |
---|
| 394 | } |
---|
| 395 | $rc &&= chmod((stat($used_file))[2] & oct(7777), $dest_file); |
---|
| 396 | if ($rc) { |
---|
| 397 | $self->dest_status( |
---|
| 398 | $is_in_prev ? 'a' |
---|
| 399 | : defined($is_in_prev) ? 'M' |
---|
| 400 | : 'A' |
---|
| 401 | ); |
---|
| 402 | } |
---|
| 403 | return $rc; |
---|
| 404 | } |
---|
| 405 | |
---|
| 406 | # ------------------------------------------------------------------------------ |
---|
| 407 | |
---|
| 408 | 1; |
---|
| 409 | |
---|
| 410 | __END__ |
---|