1# BEGIN BPS TAGGED BLOCK {{{ 2# COPYRIGHT: 3# 4# This software is Copyright (c) 2003-2008 Best Practical Solutions, LLC 5# <clkao@bestpractical.com> 6# 7# (Except where explicitly superseded by other copyright notices) 8# 9# 10# LICENSE: 11# 12# 13# This program is free software; you can redistribute it and/or 14# modify it under the terms of either: 15# 16# a) Version 2 of the GNU General Public License. You should have 17# received a copy of the GNU General Public License along with this 18# program. If not, write to the Free Software Foundation, Inc., 51 19# Franklin Street, Fifth Floor, Boston, MA 02110-1301 or visit 20# their web page on the internet at 21# http://www.gnu.org/copyleft/gpl.html. 22# 23# b) Version 1 of Perl's "Artistic License". You should have received 24# a copy of the Artistic License with this package, in the file 25# named "ARTISTIC". The license is also available at 26# http://opensource.org/licenses/artistic-license.php. 27# 28# This work is distributed in the hope that it will be useful, but 29# WITHOUT ANY WARRANTY; without even the implied warranty of 30# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 31# General Public License for more details. 32# 33# CONTRIBUTION SUBMISSION POLICY: 34# 35# (The following paragraph is not intended to limit the rights granted 36# to you to modify and distribute this software under the terms of the 37# GNU General Public License and is only of importance to you if you 38# choose to contribute your changes and enhancements to the community 39# by submitting them to Best Practical Solutions, LLC.) 40# 41# By intentionally submitting any modifications, corrections or 42# derivatives to this work, or any other work intended for use with SVK, 43# to Best Practical Solutions, LLC, you confirm that you are the 44# copyright holder for those contributions and you grant Best Practical 45# Solutions, LLC a nonexclusive, worldwide, irrevocable, royalty-free, 46# perpetual, license to use, copy, create derivative works based on 47# those contributions, and sublicense and distribute those contributions 48# and any derivatives thereof. 49# 50# END BPS TAGGED BLOCK }}} 51package SVK::XD; 52use strict; 53use SVK::Version; our $VERSION = $SVK::VERSION; 54require SVN::Core; 55require SVN::Repos; 56require SVN::Fs; 57 58use SVK::I18N; 59use SVK::Util qw( get_anchor abs_path abs_path_noexist abs2rel splitdir catdir splitpath $SEP 60 HAS_SYMLINK is_symlink is_executable mimetype mimetype_is_text 61 md5_fh get_prompt traverse_history make_path dirname 62 from_native to_native get_encoder get_depot_anchor ); 63use Data::Hierarchy 0.30; 64use autouse 'File::Find' => qw(find); 65use autouse 'File::Path' => qw(rmtree); 66use autouse 'YAML::Syck' => qw(LoadFile DumpFile); 67use SVK::MirrorCatalog; 68use PerlIO::eol 0.10 qw( NATIVE LF ); 69use PerlIO::via::dynamic; 70use PerlIO::via::symlink; 71use Class::Autouse qw( Path::Class SVK::Editor::Delay ); 72use Fcntl qw(:flock); 73use SVK::Depot; 74use SVK::Config; 75 76use SVK::Logger; 77 78=head1 NAME 79 80SVK::XD - svk depot and checkout handling. 81 82=head1 SYNOPSIS 83 84 use SVK::XD; 85 $xd = SVK::XD->new (depotmap => { '' => '/path/to/repos'}); 86 87=head1 TERMINOLOGY 88 89=over 90 91=item depot 92 93A repository referred by a name. The default depot is '' (the empty string). 94 95=item depotpath 96 97A path referred by a depot name and the path inside the depot. For 98example, F<//foo/bar> means F</foo/bar> in the default depot '', and 99F</test/foo/bar> means F</foo/bar> in the depot B<test>. 100 101=item copath 102 103Checkout path. A path in the file system that has a checked out 104version of a certain depotpath. 105 106=back 107 108=head1 CONSTRUCTOR 109 110Options to C<new>: 111 112=over 113 114=item depotmap 115 116A hash reference for depot name and repository path mapping. 117 118=item checkout 119 120A L<Data::Hierarchy> object for checkout paths mapping. 121 122=item giantlock 123 124A filename for global locking. This file protects all read and write 125accesses to the C<statefile>. 126 127When SVK begins to execute any command, it attempt to get a write lock 128on this "giant lock" file. Once it gets the lock, it writes its PID 129to the file, reads in its C<statefile>, and begins to execute the 130command. Executing the command consists of a "lock" phase and a "run" 131phase. During the lock phase, a command can do one of three things: 132request to keep the giant lock for the entire execution (for commands 133which modify large parts of the C<statefile>), request to lock 134individual checkout paths, or not request a lock. 135 136In the first case, the command sets the C<hold_giant> field on the 137L<SVK::Command> object (this should probably change to a real API), 138and the command does not release the giant lock until it is finished; 139it can rewrite the C<statefile> at the end of its execution without 140waiting on the lock, since it already holds it. 141 142In the second case, the command calls C<lock> on the L<SVK::XD> object 143one or more times; this places a "lock" entry inside the 144L<Data::Hierarchy> object in the statefile next to each locked path, 145unless they are already locked by another process. Between its lock 146phase and its run phase, the C<statefile> is written to disk (with the 147new C<lock> entries) and the giant lock is dropped. After the run 148phase, SVK acquires the giant lock again, reads in the C<statefile>, 149copies all entries from the paths that it has locked into the version 150it just read, clears the lock entries from the hierarchy, writes the 151C<statefile> to disk, and drops the giant lock. Any changes to the 152hierarchy other than in the locked paths will be ignored. 153 154In the third case, SVK just drops the giant lock after the lock phase 155and never tries to read or write the C<statefile> again. 156 157=item statefile 158 159Filename for serializing C<SVK::XD> object. 160 161=item svkpath 162 163Directory name of C<giantlock> and C<statefile>. 164 165=back 166 167=cut 168 169sub new { 170 my $class = shift; 171 my $self = bless {}, $class; 172 %$self = @_; 173 174 if ($self->{svkpath}) { 175 mkdir($self->{svkpath}) 176 or die loc("Cannot create svk-config-directory at '%1': %2\n", 177 $self->{svkpath}, $!) 178 unless -d $self->{svkpath}; 179 $self->{signature} ||= SVK::XD::Signature->new (root => $self->cache_directory, 180 floating => $self->{floating}) 181 } 182 183 $self->{checkout} ||= Data::Hierarchy->new( sep => $SEP ); 184 return $self; 185} 186 187=head1 METHODS 188 189=head2 Serialization and locking 190 191=over 192 193=item load 194 195Load the serialized C<SVK::XD> data from statefile. Initialize C<$self> 196if there's nothing to load. The giant lock is acquired when calling 197C<load>. 198 199=cut 200 201sub load { 202 my ($self) = @_; 203 my $info; 204 205 $self->giant_lock (); 206 207 if (-e $self->{statefile}) { 208 local $@; 209 $info = eval {LoadFile ($self->{statefile})}; 210 if ($@) { 211 rename ($self->{statefile}, "$self->{statefile}.backup"); 212 $logger->warn(loc ("Can't load statefile, old statefile saved as %1", 213 "$self->{statefile}.backup")); 214 } 215 elsif ($info) { 216 $info->{checkout}{sep} = $SEP; 217 $info->{checkout} = $info->{checkout}->to_absolute($self->{floating}) 218 if $self->{floating}; 219 } 220 } 221 222 $info ||= { depotmap => {'' => catdir($self->{svkpath}, 'local') }, 223 checkout => Data::Hierarchy->new( sep => $SEP ) }; 224 $self->{$_} = $info->{$_} for keys %$info; 225 $self->{updated} = 0; 226 $self->create_depots('') if exists $self->{depotmap}{''}; 227} 228 229=item store 230 231=cut 232 233sub create_depots { 234 my $self = shift; 235 my $depotmap = $self->{depotmap}; 236 for my $path (@{$depotmap}{sort (@_ ? @_ : keys %$depotmap)}) { 237 $path =~ s{[$SEP/]+$}{}go; 238 239 next if -d $path; 240 my $ans = get_prompt( 241 loc("Repository %1 does not exist, create? (y/n)", $path), 242 qr/^[yn]/i, 243 ); 244 next if $ans =~ /^n/i; 245 $self->_create_depot($path) 246 } 247 return; 248} 249 250sub _create_depot { 251 my ($self, $path) = @_; 252 make_path(dirname($path)); 253 254 SVN::Repos::create($path, undef, undef, undef, 255 {'fs-type' => $ENV{SVNFSTYPE} || 'fsfs', 256 'bdb-txn-nosync' => '1', 257 'bdb-log-autoremove' => '1'}); 258} 259 260 261=item store 262 263Serialize C<$self> to the statefile. If giant lock is still ours, 264overwrite the file directly. Otherwise load the file again and merge 265the paths we locked into the new state file. After C<store> is called, 266giant is unlocked. 267 268=cut 269 270sub _store_config { 271 my ($self, $hash) = @_; 272 273 $self->{giantlock_handle} or 274 die "Internal error: trying to save config without a lock!\n"; 275 276 local $SIG{INT} = sub { $logger->warn( loc("Please hold on a moment. SVK is writing out a critical configuration file."))}; 277 278 my $file = $self->{statefile}; 279 my $tmpfile = $file."-$$"; 280 my $oldfile = "$file~"; 281 my $ancient_backup = $file.".bak.".$$; 282 283 my $tmphash = { map { $_ => $hash->{$_}} qw/checkout depotmap/ }; 284 $tmphash->{checkout} = $tmphash->{checkout}->to_relative($self->{floating}) 285 if $self->{floating}; 286 DumpFile ($tmpfile, $tmphash); 287 288 if (not -f $tmpfile ) { 289 die loc("Couldn't write your new configuration file to %1. Please try again.", $tmpfile); 290 } 291 292 if (-f $oldfile ) { 293 rename ( $oldfile => $ancient_backup ) || 294 die loc("Couldn't remove your old backup configuration file %1 while writing the new one: %2.\n", $oldfile, $!); 295 } 296 if (-f $file ) { 297 rename ($file => $oldfile) || 298 die loc("Couldn't remove your old configuration file %1 while writing the new one: %2.\n", $file, $!); 299 } 300 rename ($tmpfile => $file) || 301 die loc("Couldn't write your new configuration file %1. A backup has been stored in %2. Please replace %1 with %2 immediately: %3.\n", $file, $tmpfile, $!); 302 303 if (-f $ancient_backup ) { 304 unlink ($ancient_backup) || 305 die loc("Couldn't remove your old backup configuration file %1 while writing the new one.", $ancient_backup); 306 307 } 308} 309 310sub store { 311 my ($self) = @_; 312 $self->{updated} = 1; 313 return unless $self->{statefile}; 314 local $@; 315 if ($self->{giantlock_handle}) { 316 # We never gave up the giant lock, so nobody should have written to 317 # the state file, so we can go ahead and write it out. 318 $self->_store_config ($self); 319 } 320 elsif ($self->{modified}) { 321 # We don't have the giant lock, but we do have something to 322 # change, so get the lock, read in the current state, merge in 323 # the changes from the paths we locked, and write it out. 324 $self->giant_lock (); 325 my $info = LoadFile ($self->{statefile}); 326 $info->{checkout} = $info->{checkout}->to_absolute($self->{floating}) 327 if $self->{floating}; 328 my @paths = $info->{checkout}->find ('', {lock => $$}); 329 $info->{checkout}->merge ($self->{checkout}, $_) 330 for @paths; 331 $self->_store_config($info); 332 } 333 $self->giant_unlock (); 334} 335 336=item lock 337 338Lock the given checkout path, store the state with the lock info to 339prevent other instances from modifying locked paths. 340 341=cut 342 343sub lock { 344 my ($self, $path) = @_; 345 if (my $lock = $self->{checkout}->get ($path, 1)->{lock}) { 346 my @paths = $self->{checkout}->find('', {lock => $lock}); 347 die loc("%1 already locked at %2, use 'svk cleanup' if lock is stalled\n", $path, $paths[0]); 348 } 349 $self->{checkout}->store ($path, {lock => $$}); 350 $self->{modified} = 1; 351} 352 353=item unlock 354 355Unlock all the checkout paths that were locked by this instance. 356 357=cut 358 359sub unlock { 360 my ($self) = @_; 361 my @paths = $self->{checkout}->find ('', {lock => $$}); 362 $self->{checkout}->store ($_, {lock => undef}) 363 for @paths; 364} 365 366=item giant_lock 367 368Lock the statefile globally. All other instances need to wait for the 369lock before they can do anything. 370 371=cut 372 373sub giant_lock { 374 my ($self) = @_; 375 return unless $self->{giantlock}; 376 my $lock_handle; 377 378 my $DIE = sub { my $verb = shift; die "can't $verb giant lock ($self->{giantlock}): $!\n" }; 379 380 LOCKED: { 381 for (1..5) { 382 open($lock_handle, '>>', $self->{giantlock}) or $DIE->('open'); 383 384 # Try to get an exclusive lock; don't block 385 my $success = flock $lock_handle, LOCK_EX | LOCK_NB; 386 last LOCKED if $success; 387 388 # Somebody else has it locked; try again in a second. 389 close($lock_handle); 390 sleep 1; 391 } 392 393 $self->{updated} = 1; 394 die loc("Another svk might be running; remove %1 if not.\n", $self->{giantlock}); 395 } 396 397 # We've got the lock. For diagnostic purposes, write out our PID. 398 seek($lock_handle, 0, 0) or $DIE->('rewind'); 399 truncate($lock_handle, 0) or $DIE->('truncate'); 400 $lock_handle->autoflush(1); 401 (print $lock_handle $$) or $DIE->('write'); 402 403 $self->{giantlock_handle} = $lock_handle; 404} 405 406=item giant_unlock 407 408Release the giant lock. 409 410=back 411 412=cut 413 414sub giant_unlock { 415 my ($self) = @_; 416 return unless $self->{giantlock} and $self->{giantlock_handle}; 417 418 close $self->{giantlock_handle}; 419 unlink ($self->{giantlock}); 420 delete $self->{giantlock_handle}; 421} 422 423=head2 Depot and path translation 424 425=over 426 427=cut 428 429my %REPOS; 430my $REPOSPOOL = SVN::Pool->new; 431 432sub _open_repos { 433 my ($repospath) = @_; 434 $REPOS{$repospath} ||= SVN::Repos::open ($repospath, $REPOSPOOL); 435} 436 437=item find_repos 438 439Given depotpath and an option about if the repository should be 440opened. Returns an array of repository path, the path inside 441repository, and the C<SVN::Repos> object if caller wants the 442repository to be opened. 443 444=cut 445 446# DEPRECATED 447sub find_repos { 448 my ($self, $depotpath, $open) = @_; 449 die loc("no depot spec") unless $depotpath; 450 my ($depot, $path) = $depotpath =~ m|^/([^/]*)(/.*?)/?$| 451 or die loc("%1 is not a depot path.\n", $depotpath); 452 453 $path = Path::Class::foreign_dir('Unix', $path)->stringify; 454 my $repospath = $self->{depotmap}{$depot} or die loc("No such depot: %1.\n", $depot); 455 456 return ($repospath, $path, $open && _open_repos ($repospath)); 457} 458 459sub find_depotpath { 460 my ($self, $depotpath) = @_; 461 die loc("no depot spec") unless $depotpath; 462 my ($depotname, $path) = $depotpath =~ m|^/([^/]*)(/.*?)/?$| 463 or die loc("%1 is not a depot path.\n", $depotpath); 464 $path = Path::Class::foreign_dir('Unix', $path)->stringify; 465 466 return ( $self->find_depot($depotname), $path ); 467} 468 469sub find_depot { 470 my ($self, $depotname) = @_; 471 my $repospath = $self->{depotmap}{$depotname} or die loc("No such depot: %1.\n", $depotname); 472 473 return SVK::Depot->new( { depotname => $depotname, 474 repospath => $repospath, 475 repos => _open_repos($repospath) } ); 476} 477 478=item find_repos_from_co 479 480Given the checkout path and an option about if the repository should 481be opened. Returns an array of repository path, the path inside 482repository, the absolute checkout path, the checkout info, and the 483C<SVN::Repos> object if caller wants the repository to be opened. 484 485=cut 486 487sub find_repos_from_co { 488 my ($self, $copath, $open) = @_; 489 my $report = $copath; 490 $copath = abs_path (File::Spec->canonpath ($copath)); 491 die loc("path %1 is not a checkout path.\n", $report) 492 unless $copath; 493 my ($cinfo, $coroot) = $self->{checkout}->get ($copath); 494 die loc("path %1 is not a checkout path.\n", $copath) unless %$cinfo; 495 my ($repospath, $path, $repos) = $self->find_repos ($cinfo->{depotpath}, $open); 496 497 return ($repospath, abs2rel ($copath, $coroot => $path, '/'), $copath, 498 $cinfo, $repos); 499} 500 501=item find_repos_from_co_maybe 502 503Like C<find_repos_from_co>, but falls back to see if the given path is 504a depotpath. In that case, the checkout paths returned will be undef. 505 506=cut 507 508sub find_repos_from_co_maybe { 509 my ($self, $target, $open) = @_; 510 my ($repospath, $path, $copath, $cinfo, $repos); 511 if (($repospath, $path, $repos) = eval { $self->find_repos ($target, $open) }) { 512 return ($repospath, $path, undef, undef, $repos); 513 } 514 undef $@; 515 return $self->find_repos_from_co ($target, $open); 516} 517 518=item find_depotname 519 520=cut 521 522sub find_depotname { 523 my ($self, $target, $can_be_co) = @_; 524 my ($cinfo); 525 local $@; 526 if ($can_be_co) { 527 (undef, undef, $cinfo) = eval { $self->find_repos_from_co ($target, 0) }; 528 $target = $cinfo->{depotpath} unless $@; 529 } 530 531 $self->find_repos ($target, 0); 532 return ($target =~ m|^/(.*?)/|); 533} 534 535=back 536 537=cut 538 539sub target_condensed { 540 my ($self, @paths) = @_; 541 return unless @paths; 542 my $anchor; 543 for my $path (@paths) { 544 unless (defined $anchor) { 545 $anchor = $path->clone; 546 $anchor->copath_anchor(Path::Class::dir($anchor->copath_anchor)); 547 } 548 my ($cinfo, $schedule) = $self->get_entry($anchor->copath_anchor, 1); 549 while ($cinfo->{scheduleanchor} || !-d $anchor->copath_anchor || 550 $schedule eq 'add' || $schedule eq 'delete' || $schedule eq 'replace' || 551 !( $anchor->copath_anchor->subsumes($path->copath_anchor)) ) { 552 $anchor->anchorify; 553 $anchor->copath_anchor(Path::Class::dir($anchor->copath_anchor)); 554 ($cinfo, $schedule) = $self->get_entry($anchor->copath_anchor, 1); 555 } 556 push @{$anchor->source->{targets}}, abs2rel($path->copath, $anchor->copath => undef, '/') unless $anchor->path eq $path->path; 557 } 558 559 my $root = $anchor->create_xd_root; 560 until ($root->check_path($anchor->path_anchor) == $SVN::Node::dir) { 561 $anchor->anchorify; 562 } 563 564 delete $anchor->{cinfo}; 565 return $anchor; 566} 567 568# simliar to command::arg_copath, but still return a target when 569# basepath doesn't exist, arg_copath should be gradually deprecated 570sub target_from_copath_maybe { 571 my ($self, $arg) = @_; 572 573 my $rev = $arg =~ s/\@(\d+)$// ? $1 : undef; 574 my ($repospath, $path, $depotpath, $copath, $repos, $view); 575 unless (($repospath, $path, $repos) = eval { $self->find_repos ($arg, 1) }) { 576 $arg = File::Spec->canonpath($arg); 577 $copath = abs_path_noexist($arg); 578 my ($cinfo, $coroot) = $self->{checkout}->get ($copath); 579 die loc("path %1 is not a checkout path.\n", $copath) unless %$cinfo; 580 ($repospath, $path, $repos) = $self->find_repos ($cinfo->{depotpath}, 1); 581 my ($view_rev, $subpath); 582 if (($view, $view_rev, $subpath) = $path =~ m{^/\^([\w/\-_]+)(?:\@(\d+)(.*))?$}) { 583 ($path, $view) = SVK::Command->create_view ($repos, $view, $view_rev, $subpath); 584 } 585 586 $path = abs2rel ($copath, $coroot => $path, '/'); 587 588 ($depotpath) = $cinfo->{depotpath} =~ m|^/(.*?)/|; 589 $rev = $cinfo->{revision} unless defined $rev; 590 $depotpath = "/$depotpath$path"; 591 } 592 593 from_native ($path, 'path', $self->{encoding}); 594 undef $@; 595 my $ret = $self->create_path_object 596 ( repos => $repos, 597 repospath => $repospath, 598 depotpath => $depotpath || $arg, 599 copath_anchor => $copath, 600 report => $arg, 601 path => $path, 602 view => $view, 603 revision => $rev, 604 ); 605 $ret = $ret->as_depotpath unless defined $copath; 606 return $ret; 607} 608 609=head2 create_path_object 610 611Creates and returns a new path object. It can be either L<SVK::Path::Checkout>, 612L<SVK::Path::View> or L<SVK::Path>. 613 614Takes a hash with arguments. 615 616If "copath_anchor" argument is defined then L<SVK::Path::Checkout> is created 617and other arguments are used to build its L<SVK::Path::Checkout/source> 618using this method. If "revision" argument is not defined then the one checkout 619path is based on is used. 620 621If "view" argument is defined then L<SVK::Path::View> is created 622and other arguments are used to build its L<SVK::Path::Checkout/source> using 623this method. 624 625Otherwise L<SVK::Path> is created. 626 627Depot can be passed as L<SVK::Depot> object in "depot" argument or using 628"depotname", "repospath" and "repos" arguments. Object takes precendence. 629 630=cut 631 632sub create_path_object { 633 my ($self, %arg) = @_; 634 if (my $depotpath = delete $arg{depotpath}) { 635 ($arg{depotname}) = $depotpath =~ m!^/([^/]*)!; 636 } 637 638 if (defined (my $copath = delete $arg{copath_anchor})) { 639 require SVK::Path::Checkout; 640 my $report = delete $arg{report}; 641 $arg{'revision'} = ($self->get_entry( $copath ))[0]->{'revision'} 642 unless defined $arg{'revision'}; 643 return SVK::Path::Checkout->real_new 644 ({ xd => $self, 645 report => $report, 646 copath_anchor => $copath, 647 source => $self->create_path_object(%arg) }); 648 } 649 650 unless ($arg{depot}) { 651 my $depotname = delete $arg{depotname}; 652 my $repospath = delete $arg{repospath}; 653 my $repos = delete $arg{repos}; 654 $arg{depot} = SVK::Depot->new({ depotname => $depotname, repos => $repos, repospath => $repospath }); 655 } 656 657 my $path; 658 if (defined (my $view = delete $arg{view})) { 659 require SVK::Path::View; 660 $path = SVK::Path::View->real_new 661 ({ source => $self->create_path_object(%arg), 662 view => $view, 663 %arg }); 664 } 665 else { 666 $path = SVK::Path->real_new(\%arg); 667 } 668 669 $path->refresh_revision unless defined $path->revision; 670 return $path; 671} 672 673=head2 Checkout handling 674 675=over 676 677=item auto_prop 678 679Return a hash of properties that should attach to the file 680automatically when added. 681 682=cut 683 684sub _load_svn_autoprop { 685 my $self = shift; 686 $self->{svnautoprop} = {}; 687 local $@; 688 eval { 689 SVK::Config->svnconfig->{config}-> 690 enumerate ('auto-props', 691 sub { $self->{svnautoprop}{compile_apr_fnmatch($_[0])} = $_[1]; 1} ); 692 }; 693 $logger->warn("Your svn is too old, auto-prop in svn config is not supported: $@") if $@; 694} 695 696sub auto_prop { 697 my ($self, $copath) = @_; 698 699 # no other prop for links 700 return {'svn:special' => '*'} if is_symlink($copath); 701 my $prop; 702 $prop->{'svn:executable'} = '*' if is_executable($copath); 703 704 # auto mime-type: binary or text/* but not text/plain 705 if ( my $type = mimetype($copath) ) { 706 $prop->{'svn:mime-type'} = $type 707 if $type ne 'text/plain' 708 && ( $type =~ m/^text/ || !mimetype_is_text($type) ); 709 } 710 711 # svn auto-prop 712 if (SVK::Config->svnconfig && SVK::Config->svnconfig->{config}->get_bool ('miscellany', 'enable-auto-props', 0)) { 713 $self->_load_svn_autoprop unless $self->{svnautoprop}; 714 my (undef, undef, $filename) = splitpath ($copath); 715 while (my ($pattern, $value) = each %{$self->{svnautoprop}}) { 716 next unless $filename =~ m/$pattern/; 717 for (split (/\s*;\s*/, $value)) { 718 my ($propname, $propvalue) = split (/\s*=\s*/, $_, 2); 719 $prop->{$propname} = $propvalue; 720 } 721 } 722 } 723 return $prop; 724} 725 726sub do_delete { 727 my ($self, $target, %arg) = @_; 728 my (@deleted, @modified, @unknown, @scheduled); 729 730 $target->anchorify unless $target->source->{targets}; 731 732 my @paths = grep {is_symlink($_) || -e $_} $target->copath_targets; 733 my @to_schedule = @paths; 734 735 # check for if the file/dir is modified. 736 $self->checkout_delta ( $target->for_checkout_delta, 737 %arg, 738 xdroot => $target->create_xd_root, 739 absent_as_delete => 1, 740 delete_verbose => 1, 741 absent_verbose => 1, 742 editor => SVK::Editor::Status->new 743 ( notify => SVK::Notify->new 744 ( cb_flush => sub { 745 my ($path, $status) = @_; 746 my $copath = $target->copath($path); 747 $target->contains_copath($copath) or return; 748 749 my $st = $status->[0]; 750 if ($st eq 'M') { 751 push @modified, $copath; 752 } 753 elsif ($st eq 'D') { 754 push @to_schedule, $copath 755 unless -e $copath; 756 push @deleted, $copath; 757 } 758 else { 759 push @scheduled, $copath; 760 } 761 })), 762 cb_unknown => sub { 763 push @unknown, $target->copath($_[1]); 764 } 765 ); 766 767 # use Data::Dumper; warn Dumper \@unknown, \@modified, \@scheduled; 768 unless ($arg{force_delete}) { 769 my @reports; 770 push @reports, sort map { loc("%1 is not under version control", $target->report_copath($_)) } @unknown; 771 push @reports, sort map { loc("%1 is modified", $target->report_copath($_)) } @modified; 772 push @reports, sort map { loc("%1 is scheduled", $target->report_copath($_)) } @scheduled; 773 774 die join(",\n", @reports) . "; use '--force' to go ahead.\n" 775 if @reports; 776 } 777 778 # actually remove it from checkout path 779 my $ignore = $self->ignore; 780 find(sub { 781 return if m/$ignore/; 782 my $cpath = catdir($File::Find::dir, $_); 783 no warnings 'uninitialized'; 784 return if $self->{checkout}->get($cpath, 1)->{'.schedule'} 785 eq 'delete'; 786 787 push @deleted, $cpath; 788 }, @paths) if @paths; 789 790 791 my %noschedule = map { $_ => 1 } (@unknown, @scheduled); 792 for (@deleted) { 793 print "D ".$target->report_copath($_)."\n" 794 unless $arg{quiet}; 795 } 796 # don't schedule unknown/added files for deletion as this confuses revert. 797 for (@to_schedule) { 798 $self->{checkout}->store ($_, {'.schedule' => 'delete'}) 799 unless $noschedule{$_}; 800 } 801 802 if (@scheduled) { 803 # XXX - should we report something? 804 require SVK::Command; 805 $self->{checkout}->store ($_, { SVK::Command->_schedule_empty }) 806 for @scheduled; 807 } 808 809 # TODO: perhaps use the information to warn commiting a rename partially 810 $self->{checkout}->store($_, {scheduleanchor => $_}) 811 for $target->copath_targets; 812 813 return if $arg{no_rm}; 814 rmtree (\@paths) if @paths; 815} 816 817sub do_add { 818 my ($self, $target, %arg) = @_; 819 820 $self->checkout_delta( 821 $target->for_checkout_delta, 822 %arg, 823 xdroot => $target->create_xd_root, 824 editor => SVK::Editor::Status->new( 825 notify => SVK::Notify->new( 826 cb_flush => sub { 827 my ($path, $status) = @_; 828 to_native($path, 'path'); 829 my $copath = $target->copath($path); 830 my $report = $target->report ? $target->report->subdir($path) : $path; 831 832 $target->contains_copath ($copath) or return; 833 die loc ("%1 already added.\n", $report) 834 if !$arg{recursive} && ($status->[0] eq 'R' || $status->[0] eq 'A'); 835 836 return unless $status->[0] eq 'D'; 837 lstat ($copath); 838 $self->_do_add('R', $copath, $report, !-d _, %arg) 839 if -e _; 840 }, 841 ), 842 ), 843 cb_unknown => sub { 844 my ($editor, $path) = @_; 845 to_native($path, 'path'); 846 my $copath = $target->copath($path); 847 my $report = $target->_to_pclass($target->report)->subdir($path); 848 lstat ($copath); 849 $self->_do_add('A', $copath, $report, !-d _, %arg); 850 }, 851 ); 852 return; 853} 854 855my %sch = (A => 'add', 'R' => 'replace'); 856 857sub _do_add { 858 my ($self, $st, $copath, $report, $autoprop, %arg) = @_; 859 my $newprop; 860 $newprop = $self->auto_prop($copath) if $autoprop; 861 862 $self->{checkout}->store($copath, { 863 '.schedule' => $sch{$st}, 864 $autoprop ? ('.newprop' => $newprop) : () 865 }); 866 867 return if $arg{quiet}; 868 869 # determine whether the path is binary 870 my $bin = q{}; 871 if ( ref $newprop && $newprop->{'svn:mime-type'} ) { 872 $bin = ' - (bin)' if !mimetype_is_text( $newprop->{'svn:mime-type'} ); 873 } 874 875 $logger->info( "$st $report$bin"); 876} 877 878sub do_propset { 879 my ($self, $target, %arg) = @_; 880 my ($entry, $schedule) = $self->get_entry($target->copath); 881 $entry->{'.newprop'} ||= {}; 882 883 if ( $schedule ne 'add' && !$arg{'adjust_only'} ) { 884 my $xdroot = $target->create_xd_root; 885 my ( $source_path, $source_root ) 886 = $self->_copy_source( $entry, $target->copath, $xdroot ); 887 $source_path ||= $target->path_anchor; 888 $source_root ||= $xdroot; 889 die loc( "%1 is not under version control.\n", $target->report ) 890 if $xdroot->check_path($source_path) == $SVN::Node::none; 891 } 892 893 #XXX: support working on multiple paths and recursive 894 die loc("%1 is already scheduled for delete.\n", $target->report) 895 if $schedule eq 'delete' && !$arg{'adjust_only'}; 896 my %values; 897 %values = %{$entry->{'.newprop'}} if exists $entry->{'.schedule'}; 898 my $pvalue = defined $arg{propvalue} ? $arg{propvalue} : \undef; 899 900 if ( $arg{'adjust_only'} ) { 901 return unless defined $values{ $arg{propname} }; 902 903 if ( defined $arg{propvalue} && $values{$arg{propname}} eq $pvalue ) { 904 delete $values{ $arg{propname} }; 905 } 906 elsif ( !defined $arg{propvalue} && (!defined $values{$arg{propname}} || (ref $values{$arg{propname}} && !defined $values{$arg{propname}}) )) { 907 delete $values{ $arg{propname} }; 908 } else { 909 $values{ $arg{propname} } = $pvalue; 910 } 911 } else { 912 $values{ $arg{propname} } = $pvalue; 913 } 914 915 $self->{checkout}->store ($target->copath, 916 { '.schedule' => $schedule || 'prop', 917 '.newprop' => \%values, }); 918 print " M ".$target->report."\n" unless $arg{quiet}; 919 920 $self->fix_permission($target->copath, $arg{propvalue}) 921 if $arg{propname} eq 'svn:executable'; 922} 923 924sub fix_permission { 925 my ($self, $copath, $value) = @_; 926 my $mode = (stat ($copath))[2]; 927 if (defined $value) { 928 $mode |= 0111; 929 } 930 else { 931 $mode &= ~0111; 932 } 933 chmod ($mode, $copath); 934} 935 936=item depot_delta 937 938Generate C<SVN::Delta::Editor> calls to represent the changes between 939C<(oldroot, oldpath)> and C<(newroot, newpath)>. oldpath is a array 940ref for anchor and target, newpath is just a string. 941 942Options: 943 944=over 945 946=item editor 947 948The editor receiving delta calls. 949 950=item no_textdelta 951 952Don't generate text deltas in C<apply_textdelta> calls. 953 954=item no_recurse 955 956=item notice_ancestry 957 958=back 959 960=cut 961 962sub depot_delta { 963 my ($self, %arg) = @_; 964 my @root = map {$_->isa ('SVK::Root') ? $_->root : $_} @arg{qw/oldroot newroot/}; 965 my $editor = $arg{editor}; 966 SVN::Repos::dir_delta ($root[0], @{$arg{oldpath}}, 967 $root[1], $arg{newpath}, 968 $editor, undef, 969 $arg{no_textdelta} ? 0 : 1, 970 $arg{no_recurse} ? 0 : 1, 971 0, # we never need entry props 972 $arg{notice_ancestry} ? 0 : 1, 973 $arg{pool}); 974} 975 976=item checkout_delta 977 978Generate C<SVN::Delta::Editor> calls to represent the local changes 979made to the checked out revision. 980 981Options: 982 983=over 984 985=item delete_verbose 986 987Generate delete_entry calls for sub-entries within deleted entry. 988 989=item absent_verbose 990 991Generate absent_* calls for sub-entries within absent entry. 992 993=item unknown_verbose 994 995generate cb_unknown calls for sub-entries within absent entry. 996 997=item absent_ignore 998 999Don't generate absent_* calls. 1000 1001=item expand_copy 1002 1003Mimic the behavior like SVN::Repos::dir_delta, lose copy information 1004and treat all copied descendents as added too. 1005 1006=item cb_ignored 1007 1008Called for ignored items if defined. 1009 1010=item cb_unchanged 1011 1012Called for unchanged files if defined. 1013 1014=back 1015 1016=cut 1017 1018# XXX: checkout_delta is getting too complicated and too many options 1019my %ignore_cache; 1020 1021sub ignore { 1022 my $self = shift; 1023 my $more_ignores = shift; 1024 1025 no warnings; 1026 my $ignore = SVK::Config->svnconfig ? 1027 SVK::Config->svnconfig->{config}-> 1028 get ('miscellany', 'global-ignores', '') : ''; 1029 my @ignore = split / /, 1030 ($ignore || "*.o *.lo *.la #*# .*.rej *.rej .*~ *~ .#* .DS_Store"); 1031 push @ignore, 'svk-commit*.tmp'; 1032 push @ignore, @{$self->{ignore}} 1033 if $self->{ignore}; 1034 1035 if (defined $more_ignores) { 1036 push @ignore, split ("\n", $more_ignores); 1037 } 1038 1039 return join('|', map {$ignore_cache{$_} ||= compile_apr_fnmatch($_)} (@ignore)); 1040} 1041 1042# Emulates APR's apr_fnmatch function with flags=0, which is what 1043# Subversion uses. Converts a string in fnmatch format to a Perl regexp. 1044# Code is based on Barrie Slaymaker's Regexp::Shellish. 1045sub compile_apr_fnmatch { 1046 my $re = shift; 1047 1048 $re =~ s@ 1049 ( \\. 1050 | \[ # character class 1051 [!^]? # maybe negation (^ and ! are both supported) 1052 (?: (?:\\.|[^\\\]]) # one item 1053 (?: - # possibly followed by a dash and another 1054 (?:\\.|[^\\\]]))? # item 1055 )* # 0 or more entries (zero case will be checked specially below) 1056 (\]?) # if this ] doesn't match, that means we fell off end of string! 1057 | . 1058 ) 1059 @ 1060 if ( $1 eq '?' ) { 1061 '.' ; 1062 } elsif ( $1 eq '*' ) { 1063 '.*' ; 1064 } elsif ( substr($1, 0, 1) eq '[') { 1065 if ($1 eq '[]') { # should never match 1066 '[^\s\S]'; 1067 } elsif ($1 eq '[!]' or $1 eq '[^]') { # 0-length match 1068 ''; 1069 } else { 1070 my $temp = $1; 1071 my $failed = $2 eq ''; 1072 if ($failed) { 1073 '[^\s\S]'; 1074 } else { 1075 $temp =~ s/(\\.|.)/$1 eq '-' ? '-' : quotemeta(substr($1, -1))/ges; 1076 # the previous step puts in backslashes at beginning and end; remove them 1077 $temp =~ s/^\\\[/[/; 1078 $temp =~ s/\\\]$/]/; 1079 # if it started with [^ or [!, it now starts with [\^ or [\!; fix. 1080 $temp =~ s/^\[ # literal [ 1081 \\ # literal backslash 1082 [!^] # literal ! or ^ 1083 /[^/x; 1084 $temp; 1085 } 1086 } 1087 } else { 1088 quotemeta(substr( $1, -1 ) ); # ie, either quote it, or if it's \x, quote x 1089 } 1090 @gexs ; 1091 1092 return qr/\A$re\Z/s; 1093} 1094 1095# Here be dragon. below is checkout_delta related function. 1096 1097sub _delta_rev { 1098 my ($self, $arg) = @_; 1099 my $entry = $arg->{cinfo}; 1100 my $schedule = $entry->{'.schedule'} || ''; 1101 # XXX: uncomment this as mutation coverage test 1102 # return $entry->{revision}; 1103 1104 # Lookup the copy source rev for the case of open_directory inside 1105 # add_directotry with history. But shouldn't do so for replaced 1106 # items, because the rev here is used for delete_entry 1107 my ($source_path, $source_rev) = $schedule ne 'replace' ? 1108 $self->_copy_source($entry, $arg->{copath}) : (); 1109 ($source_path, $source_rev) = ($arg->{path}, $entry->{revision}) 1110 unless defined $source_path; 1111 return $source_rev; 1112} 1113 1114sub _delta_content { 1115 my ($self, %arg) = @_; 1116 1117 my $handle = $arg{editor}->apply_textdelta ($arg{baton}, $arg{md5}, $arg{pool}); 1118 return unless $handle && $#{$handle} > 0; 1119 1120 if ($arg{send_delta} && $arg{base}) { 1121 my $spool = SVN::Pool->new_default ($arg{pool}); 1122 my $source = $arg{base_root}->file_contents ($arg{base_path}, $spool); 1123 my $txstream = SVN::TxDelta::new 1124 ($source, $arg{fh}, $spool); 1125 SVN::TxDelta::send_txstream ($txstream, @$handle, $spool); 1126 } 1127 else { 1128 SVN::TxDelta::send_stream ($arg{fh}, @$handle, SVN::Pool->new ($arg{pool})) 1129 } 1130} 1131 1132sub _unknown_verbose { 1133 my ($self, %arg) = @_; 1134 my $ignore = $self->ignore; 1135 # The caller should have processed the entry already. 1136 my %seen = ($arg{copath} => 1); 1137 my @new_targets; 1138 if ($arg{targets}) { 1139ENTRY: for my $entry (@{$arg{targets}}) { 1140 my $now = ''; 1141 for my $dir (splitdir ($entry)) { 1142 $now .= $now ? "/$dir" : $dir; 1143 my $copath = SVK::Path::Checkout->copath ($arg{copath}, $now); 1144 next if $seen{$copath}; 1145 $seen{$copath} = 1; 1146 lstat $copath; 1147 unless (-e _) { 1148 $logger->warn( loc ("Unknown target: %1.", $copath)); 1149 next ENTRY; 1150 } 1151 unless (-r _) { 1152 $logger->warn( loc ("Warning: %1 is unreadable.", $copath)); 1153 next ENTRY; 1154 } 1155 $arg{cb_unknown}->($arg{editor}, catdir($arg{entry}, $now), $arg{baton}); 1156 } 1157 push @new_targets, SVK::Path::Checkout->copath ($arg{copath}, $entry); 1158 } 1159 1160 return unless @new_targets; 1161 } 1162 my $nentry = $arg{entry}; 1163 to_native($nentry, 'path', $arg{encoder}); 1164 find ({ preprocess => sub { sort @_ }, 1165 wanted => 1166 sub { 1167 $File::Find::prune = 1, return if m/$ignore/; 1168 my $copath = catdir($File::Find::dir, $_); 1169 return if $seen{$copath}; 1170 my $schedule = $self->{checkout}->get ($copath)->{'.schedule'} || ''; 1171 return if $schedule eq 'delete'; 1172 my $dpath = abs2rel($copath, $arg{copath} => $nentry, '/'); 1173 from_native($dpath, 'path'); 1174 $arg{cb_unknown}->($arg{editor}, $dpath, $arg{baton}); 1175 }}, defined $arg{targets} ? @new_targets : $arg{copath}); 1176} 1177 1178sub _node_deleted { 1179 my ($self, %arg) = @_; 1180 $arg{rev} = $self->_delta_rev(\%arg); 1181 $arg{editor}->delete_entry (@arg{qw/entry rev baton pool/}); 1182 if ($arg{kind} == $SVN::Node::dir && $arg{delete_verbose}) { 1183 my @paths; 1184 $self->depot_delta( oldroot => $arg{base_root}->fs->revision_root(0), 1185 newroot => $arg{base_root}, 1186 oldpath => ['/', ''], 1187 newpath => $arg{path}, 1188 no_textdela => 1, 1189 editor => SVK::Editor::Status->new 1190 ( notify => SVK::Notify->new 1191 ( cb_flush => sub { 1192 my ($path, $status) = @_; 1193 push @paths, $path 1194 if $status->[0] eq 'A'; 1195 })) 1196 ); 1197 $arg{editor}->delete_entry("$arg{entry}/$_", @arg{qw/rev baton pool/}) 1198 for sort @paths; 1199 } 1200} 1201 1202sub _node_deleted_or_absent { 1203 my ($self, %arg) = @_; 1204 my $schedule = $arg{cinfo}{'.schedule'} || ''; 1205 1206 if ($schedule eq 'delete' || $schedule eq 'replace') { 1207 my $should_do_delete = (!$arg{_really_in_copy} && !$arg{base}) 1208 || $arg{copath} eq ($arg{cinfo}{scheduleanchor} || ''); 1209 $self->_node_deleted (%arg) 1210 if $should_do_delete; 1211 # when doing add over deleted entry, descend into it 1212 if ($schedule eq 'delete') { 1213 $self->_unknown_verbose (%arg) 1214 if $arg{cb_unknown} && $arg{unknown_verbose}; 1215 return $should_do_delete; 1216 } 1217 } 1218 1219 if ($arg{type}) { 1220 if ($arg{kind} && !$schedule && 1221 (($arg{type} eq 'file') xor ($arg{kind} == $SVN::Node::file))) { 1222 if ($arg{obstruct_as_replace}) { 1223 $self->_node_deleted (%arg); 1224 } 1225 else { 1226 $arg{cb_obstruct}->($arg{editor}, $arg{entry}, $arg{baton}) 1227 if $arg{cb_obstruct}; 1228 return 1; 1229 } 1230 } 1231 } 1232 else { 1233 # deleted during base_root -> xdroot 1234 if (!$arg{base_root_is_xd} && $arg{kind} == $SVN::Node::none) { 1235 $self->_node_deleted (%arg); 1236 return 1; 1237 } 1238 return 1 if $arg{absent_ignore}; 1239 # absent 1240 my $type = $arg{kind} == $SVN::Node::dir ? 'directory' : 'file'; 1241 1242 if ($arg{absent_as_delete}) { 1243 $arg{rev} = $self->_delta_rev(\%arg); 1244 $self->_node_deleted (%arg); 1245 } 1246 else { 1247 my $func = "absent_$type"; 1248 $arg{editor}->$func (@arg{qw/entry baton pool/}); 1249 } 1250 return 1 unless $type ne 'file' && $arg{absent_verbose}; 1251 } 1252 return 0; 1253} 1254 1255sub _prop_delta { 1256 my ($baseprop, $newprop) = @_; 1257 return $newprop unless $baseprop && keys %$baseprop; 1258 return { map {$_ => undef} keys %$baseprop } unless $newprop && keys %$newprop; 1259 my $changed; 1260 for my $propname (keys %{ { %$baseprop, %$newprop } }) { 1261 # deref propvalue 1262 my @value = map { $_ ? ref ($_) ? '' : $_ : '' } 1263 map {$_->{$propname}} ($baseprop, $newprop); 1264 $changed->{$propname} = $newprop->{$propname} 1265 unless $value[0] eq $value[1]; 1266 } 1267 return $changed; 1268} 1269 1270sub _prop_changed { 1271 my ($root1, $path1, $root2, $path2) = @_; 1272 ($root1, $root2) = map {$_->isa ('SVK::Root') ? $_->root : $_} ($root1, $root2); 1273 return SVN::Fs::props_changed ($root1, $path1, $root2, $path2); 1274} 1275 1276sub _node_props { 1277 my ($self, %arg) = @_; 1278 my $schedule = $arg{cinfo}{'.schedule'} || ''; 1279 my $props = $arg{kind} ? $schedule eq 'replace' ? {} : $arg{xdroot}->node_proplist ($arg{path}) : 1280 $arg{base_kind} ? $arg{base_root}->node_proplist ($arg{base_path}) : {}; 1281 my $newprops = (!$schedule && $arg{auto_add} && $arg{kind} == $SVN::Node::none && $arg{type} eq 'file') 1282 ? $self->auto_prop ($arg{copath}) : $arg{cinfo}{'.newprop'}; 1283 my $fullprop = _combine_prop ($props, $newprops); 1284 if (!$arg{base} or $arg{in_copy}) { 1285 $newprops = $fullprop; 1286 } 1287 elsif (!$arg{base_root_is_xd} && $arg{base}) { 1288 $newprops = _prop_delta ($arg{base_root}->node_proplist ($arg{base_path}), $fullprop) 1289 if $arg{kind} && $arg{base_kind} && _prop_changed (@arg{qw/base_root base_path xdroot path/}); 1290 } 1291 return ($newprops, $fullprop) 1292} 1293 1294sub _node_type { 1295 my $copath = shift; 1296 my $st = [lstat ($copath)]; 1297 return '' if !-e _; 1298 unless (-r _) { 1299 $logger->warn( loc ("Warning: %1 is unreadable.", $copath)); 1300 return; 1301 } 1302 return ('file', $st) if -f _ or is_symlink; 1303 return ('directory', $st) if -d _; 1304 $logger->warn( loc ("Warning: unsupported node type %1.", $copath)); 1305 return ('', $st); 1306} 1307 1308use Fcntl ':mode'; 1309 1310sub _delta_file { 1311 my ($self, %arg) = @_; 1312 my $pool = SVN::Pool->new_default (undef); 1313 my $cinfo = $arg{cinfo} ||= $self->{checkout}->get ($arg{copath}); 1314 my $schedule = $cinfo->{'.schedule'} || ''; 1315 my $modified; 1316 1317 if ($arg{cb_conflict} && $cinfo->{'.conflict'}) { 1318 ++$modified; 1319 $arg{cb_conflict}->($arg{editor}, $arg{entry}, $arg{baton}, $cinfo->{'.conflict'}); 1320 } 1321 1322 return 1 if $self->_node_deleted_or_absent (%arg, pool => $pool); 1323 1324 my ($newprops, $fullprops) = $self->_node_props (%arg); 1325 if (HAS_SYMLINK && (defined $fullprops->{'svn:special'} xor S_ISLNK($arg{st}[2]))) { 1326 # special case obstructure for links, since it's not standard 1327 return 1 if $self->_node_deleted_or_absent (%arg, 1328 type => 'link', 1329 pool => $pool); 1330 if ($arg{obstruct_as_replace}) { 1331 $schedule = 'replace'; 1332 $fullprops = $newprops = $self->auto_prop($arg{copath}) || {}; 1333 } 1334 else { 1335 return 1; 1336 } 1337 } 1338 $arg{add} = 1 if $arg{auto_add} && $arg{base_kind} == $SVN::Node::none || 1339 $schedule eq 'replace'; 1340 1341 my $fh = get_fh ($arg{xdroot}, '<', $arg{path}, $arg{copath}, $fullprops); 1342 my $mymd5 = md5_fh ($fh); 1343 my ($baton, $md5); 1344 1345 $arg{base} = 0 if $arg{in_copy} || $schedule eq 'replace'; 1346 1347 unless ($schedule || $arg{add} || 1348 ($arg{base} && $mymd5 ne ($md5 = $arg{base_root}->file_md5_checksum ($arg{base_path})))) { 1349 $arg{cb_unchanged}->($arg{editor}, $arg{entry}, $arg{baton}, 1350 $self->_delta_rev(\%arg) 1351 ) if ($arg{cb_unchanged} && !$modified); 1352 return $modified; 1353 } 1354 1355 $baton = $arg{editor}->add_file ($arg{entry}, $arg{baton}, 1356 $cinfo->{'.copyfrom'} ? 1357 ($arg{cb_copyfrom}->(@{$cinfo}{qw/.copyfrom .copyfrom_rev/})) 1358 : (undef, -1), $pool) 1359 if $arg{add}; 1360 1361 $baton ||= $arg{editor}->open_file ($arg{entry}, $arg{baton}, $self->_delta_rev(\%arg), $pool) 1362 if keys %$newprops; 1363 1364 $arg{editor}->change_file_prop ($baton, $_, ref ($newprops->{$_}) ? undef : $newprops->{$_}, $pool) 1365 for sort keys %$newprops; 1366 1367 if (!$arg{base} || 1368 $mymd5 ne ($md5 ||= $arg{base_root}->file_md5_checksum ($arg{base_path}))) { 1369 seek $fh, 0, 0; 1370 $baton ||= $arg{editor}->open_file ($arg{entry}, $arg{baton}, $self->_delta_rev(\%arg), $pool); 1371 $self->_delta_content (%arg, baton => $baton, pool => $pool, 1372 fh => $fh, md5 => $arg{base} ? $md5 : undef); 1373 } 1374 1375 $arg{editor}->close_file ($baton, $mymd5, $pool) if $baton; 1376 return 1; 1377} 1378 1379sub _delta_dir { 1380 my ($self, %arg) = @_; 1381 if ($arg{entry} && $arg{exclude} && exists $arg{exclude}{$arg{entry}}) { 1382 $arg{cb_exclude}->($arg{path}, $arg{copath}) if $arg{cb_exclude}; 1383 return; 1384 } 1385 my $pool = SVN::Pool->new_default (undef); 1386 my $cinfo = $arg{cinfo} ||= $self->{checkout}->get ($arg{copath}); 1387 my $schedule = $cinfo->{'.schedule'} || ''; 1388 $arg{add} = 1 if $arg{auto_add} && $arg{base_kind} == $SVN::Node::none || 1389 $schedule eq 'replace'; 1390 1391 # compute targets for children 1392 my $targets; 1393 for (@{$arg{targets} || []}) { 1394 my ($volume, $directories, $file) = splitpath ($_); 1395 if ( my @dirs = splitdir($directories) ) { 1396 my $path = $volume . shift(@dirs); 1397 $file = catdir(grep length, @dirs, $file); 1398 push @{$targets->{$path}}, $file 1399 } 1400 else { 1401 $targets->{$file} = undef; 1402 } 1403 } 1404 my $thisdir; 1405 if ($targets) { 1406 if (exists $targets->{''}) { 1407 delete $targets->{''}; 1408 $thisdir = 1; 1409 } 1410 } 1411 else { 1412 $thisdir = 1; 1413 } 1414 # don't use depth when we are still traversing through targets 1415 my $descend = defined $targets || !(defined $arg{depth} && $arg{depth} == 0); 1416 # XXX: the top level entry is undefined, which should be fixed. 1417 $arg{cb_conflict}->($arg{editor}, defined $arg{entry} ? $arg{entry} : '', $arg{baton}, $cinfo->{'.conflict'}) 1418 if $thisdir && $arg{cb_conflict} && $cinfo->{'.conflict'}; 1419 1420 return 1 if $self->_node_deleted_or_absent (%arg, pool => $pool); 1421 # if a node is replaced, it has no base, unless it was replaced with history. 1422 $arg{base} = 0 if $schedule eq 'replace' && !$cinfo->{'.copyfrom'}; 1423 my ($entries, $baton) = ({}); 1424 if ($arg{add}) { 1425 $baton = $arg{root} ? $arg{baton} : 1426 $arg{editor}->add_directory ($arg{entry}, $arg{baton}, 1427 $cinfo->{'.copyfrom'} ? 1428 ($arg{cb_copyfrom}->(@{$cinfo}{qw/.copyfrom .copyfrom_rev/})) 1429 : (undef, -1), $pool); 1430 } 1431 1432 $entries = $arg{base_root}->dir_entries ($arg{base_path}) 1433 if $arg{base} && $arg{base_kind} == $SVN::Node::dir; 1434 1435 $baton ||= $arg{root} ? $arg{baton} 1436 : $arg{editor}->open_directory ($arg{entry}, $arg{baton}, 1437 $self->_delta_rev(\%arg), $pool); 1438 1439 # check scheduled addition 1440 # XXX: does this work with copied directory? 1441 my ($newprops, $fullprops) = $self->_node_props (%arg); 1442 1443 if ($descend) { 1444 1445 my $signature; 1446 if ($self->{signature} && $arg{base_root_is_xd}) { 1447 $signature = $self->{signature}->load ($arg{copath}); 1448 # if we are not iterating over all entries, keep the old signatures 1449 $signature->{keepold} = 1 if defined $targets 1450 } 1451 1452 # XXX: Merge this with @direntries so we have single entry to descendents 1453 for my $entry (sort keys %$entries) { 1454 my $newtarget; 1455 my $copath = $entry; 1456 if (defined $targets) { 1457 next unless exists $targets->{$copath}; 1458 $newtarget = delete $targets->{$copath}; 1459 } 1460 to_native ($copath, 'path', $arg{encoder}); 1461 my $kind = $entries->{$entry}->kind; 1462 my $unchanged = ($kind == $SVN::Node::file && $signature && !$signature->changed ($entry)); 1463 $copath = SVK::Path::Checkout->copath ($arg{copath}, $copath); 1464 my ($ccinfo, $ccschedule) = $self->get_entry($copath, 1); 1465 # a replace with history node requires handling the copy anchor in the 1466 # latter direntries loop. we should really merge the two. 1467 if ($ccschedule eq 'replace') {# && $ccinfo->{'.copyfrom'}) { 1468# if ($ccschedule eq 'replace' && $ccinfo->{'.copyfrom'}) { 1469 delete $entries->{$entry}; 1470 $targets->{$entry} = $newtarget if defined $targets; 1471 next; 1472 } 1473 my $newentry = defined $arg{entry} ? "$arg{entry}/$entry" : $entry; 1474 my $newpath = $arg{path} eq '/' ? "/$entry" : "$arg{path}/$entry"; 1475 if ($unchanged && !$ccschedule && !$ccinfo->{'.conflict'}) { 1476 $arg{cb_unchanged}->($arg{editor}, $newentry, $baton, 1477 $self->_delta_rev({ %arg, 1478 cinfo => $ccinfo, 1479 path => $newpath, 1480 copath => $copath }) 1481 ) if $arg{cb_unchanged}; 1482 next; 1483 } 1484 my ($type, $st) = _node_type ($copath); 1485 next unless defined $type; 1486 my $delta = $type ? $type eq 'directory' ? \&_delta_dir : \&_delta_file 1487 : $kind == $SVN::Node::file ? \&_delta_file : \&_delta_dir; 1488 my $obs = $type ? ($kind == $SVN::Node::dir xor $type eq 'directory') : 0; 1489 # if the sub-delta returns 1 it means the node is modified. invlidate 1490 # the signature cache 1491 $self->$delta ( %arg, 1492 add => $arg{in_copy} || ($obs && $arg{obstruct_as_replace}), 1493 type => $type, 1494 # if copath exist, we have base only if they are of the same type 1495 base => !$obs, 1496 depth => defined $arg{depth} ? defined $targets ? $arg{depth} : $arg{depth} - 1: undef, 1497 entry => $newentry, 1498 kind => $arg{base_root_is_xd} ? $kind : $arg{xdroot}->check_path ($newpath), 1499 base_kind => $kind, 1500 targets => $newtarget, 1501 baton => $baton, 1502 root => 0, 1503 st => $st, 1504 cinfo => $ccinfo, 1505 base_path => $arg{base_path} eq '/' ? "/$entry" : "$arg{base_path}/$entry", 1506 path => $newpath, 1507 copath => $copath) 1508 and ($signature && $signature->invalidate ($entry)); 1509 } 1510 1511 if ($signature) { 1512 $signature->flush; 1513 undef $signature; 1514 } 1515 my $ignore = $self->ignore ($fullprops->{'svn:ignore'}); 1516 1517 my @direntries; 1518 # if we are at somewhere arg{copath} not exist, $arg{type} is empty 1519 if ($arg{type} && !(defined $targets && !keys %$targets)) { 1520 opendir my ($dir), $arg{copath} or Carp::confess "$arg{copath}: $!"; 1521 for (readdir($dir)) { 1522 # Completely deny the existance of .svk; we shouldn't 1523 # show this even with e.g. --no-ignore. 1524 next if $_ eq '.svk' and $self->{floating}; 1525 1526 if (eval {from_native($_, 'path', $arg{encoder}); 1}) { 1527 push @direntries, $_; 1528 } 1529 elsif ($arg{auto_add}) { # fatal for auto_add 1530 die "$_: $@"; 1531 } 1532 else { 1533 print "$_: $@"; 1534 } 1535 } 1536 @direntries = sort grep { !m/^\.+$/ && !exists $entries->{$_} } @direntries; 1537 } 1538 1539 for my $copath (@direntries) { 1540 my $entry = $copath; 1541 my $newtarget; 1542 if (defined $targets) { 1543 next unless exists $targets->{$copath}; 1544 $newtarget = delete $targets->{$copath}; 1545 } 1546 to_native ($copath, 'path', $arg{encoder}); 1547 my %newpaths = ( copath => SVK::Path::Checkout->copath ($arg{copath}, $copath), 1548 entry => defined $arg{entry} ? "$arg{entry}/$entry" : $entry, 1549 path => $arg{path} eq '/' ? "/$entry" : "$arg{path}/$entry", 1550 base_path => $arg{base_path} eq '/' ? "/$entry" : "$arg{base_path}/$entry", 1551 targets => $newtarget, base_kind => $SVN::Node::none); 1552 $newpaths{kind} = $arg{base_root_is_xd} ? $SVN::Node::none : 1553 $arg{xdroot}->check_path ($newpaths{path}) != $SVN::Node::none; 1554 my ($ccinfo, $sche) = $self->get_entry($newpaths{copath}, 1); 1555 my $add = $sche || $arg{auto_add} || $newpaths{kind}; 1556 # If we are not at intermediate path, process ignore 1557 # for unknowns, as well as the case of auto_add (import) 1558 if (!defined $targets) { 1559 if ((!$add || $arg{auto_add}) && $entry =~ m/$ignore/) { 1560 $arg{cb_ignored}->($arg{editor}, $newpaths{entry}, $arg{baton}) 1561 if $arg{cb_ignored}; 1562 next; 1563 } 1564 } 1565 if ($ccinfo->{'.conflict'}) { 1566 $arg{cb_conflict}->($arg{editor}, $newpaths{entry}, $arg{baton}, $cinfo->{'.conflict'}) 1567 if $arg{cb_conflict}; 1568 } 1569 unless ($add || $ccinfo->{'.conflict'}) { 1570 if ($arg{cb_unknown}) { 1571 $arg{cb_unknown}->($arg{editor}, $newpaths{entry}, $arg{baton}); 1572 $self->_unknown_verbose (%arg, %newpaths) 1573 if $arg{unknown_verbose}; 1574 } 1575 next; 1576 } 1577 my ($type, $st) = _node_type ($newpaths{copath}) or next; 1578 my $delta = $type eq 'directory' ? \&_delta_dir : \&_delta_file; 1579 my $copyfrom = $ccinfo->{'.copyfrom'}; 1580 my ($fromroot) = $copyfrom ? $arg{xdroot}->get_revision_root($newpaths{path}, $ccinfo->{'.copyfrom_rev'}) : undef; 1581 $self->$delta ( %arg, %newpaths, add => 1, baton => $baton, 1582 root => 0, base => 0, cinfo => $ccinfo, 1583 type => $type, 1584 st => $st, 1585 depth => defined $arg{depth} ? defined $targets ? $arg{depth} : $arg{depth} - 1: undef, 1586 $copyfrom ? 1587 ( base => 1, 1588 _really_in_copy => 1, 1589 in_copy => $arg{expand_copy}, 1590 base_kind => $fromroot->check_path ($copyfrom), 1591 base_root_is_xd => 0, 1592 base_root => $fromroot, 1593 base_path => $copyfrom) : (), 1594 ); 1595 } 1596 1597 } 1598 1599 if ($thisdir) { 1600 $arg{editor}->change_dir_prop ($baton, $_, ref ($newprops->{$_}) ? undef : $newprops->{$_}, $pool) 1601 for sort keys %$newprops; 1602 } 1603 if (defined $targets) { 1604 $logger->warn(loc ("Unknown target: %1.", $_)) for sort keys %$targets; 1605 } 1606 1607 $arg{editor}->close_directory ($baton, $pool) 1608 unless $arg{root}; 1609 return 0; 1610} 1611 1612sub _get_rev { 1613 $_[0]->{checkout}->get ($_[1])->{revision}; 1614} 1615 1616sub checkout_delta { 1617 my ($self, %arg) = @_; 1618 $arg{base_root} ||= $arg{xdroot}; # xdroot is the 1619 $arg{base_path} ||= $arg{path}; # path is -> string name of file in repo 1620 $arg{encoder} = get_encoder; 1621 Carp::cluck unless defined $arg{base_path}; 1622 my $kind = $arg{base_kind} = $arg{base_root}->check_path ($arg{base_path}); 1623 $arg{base_root_is_xd} = $arg{base_root}->same_root($arg{xdroot}); 1624 $arg{kind} = $arg{base_root_is_xd} ? $kind : $arg{xdroot}->check_path ($arg{path}); 1625 die "checkout_delta called with non-dir node" 1626 unless $kind == $SVN::Node::dir; 1627 my ($copath, $repospath) = @arg{qw/copath repospath/}; 1628 $arg{editor}{_debug}++ 1629 if $arg{debug}; 1630 $arg{editor} = SVK::Editor::Delay->new ($arg{editor}) 1631 unless $arg{nodelay}; 1632 1633 # XXX: translate $repospath to use '/' 1634 $arg{cb_copyfrom} ||= $arg{expand_copy} ? sub { (undef, -1) } 1635 : sub { my $path = $_[0]; $path =~ s/%/%25/g; ("file://$repospath$path", $_[1]) }; 1636 local $SIG{INT} = sub { 1637 $arg{editor}->abort_edit; 1638 die loc("Interrupted.\n"); 1639 }; 1640 1641 my ($entry) = $self->get_entry($arg{copath}, 1); 1642 my $baton = $arg{editor}->open_root ($entry->{revision}); 1643 $self->_delta_dir (%arg, baton => $baton, root => 1, base => 1, type => 'directory'); 1644 $arg{editor}->close_directory ($baton); 1645 $arg{editor}->close_edit (); 1646} 1647 1648=item get_entry($copath) 1649 1650Returns the L<Data::Hierarchy> entry and the schedule of the entry. 1651 1652=cut 1653 1654sub get_entry { 1655 my ($self, $copath, $dont_clone) = @_; 1656 my $entry = $self->{checkout}->get($copath, $dont_clone); 1657 return ($entry, $entry->{'.schedule'} || ''); 1658} 1659 1660sub resolved_entry { 1661 my ($self, $entry) = @_; 1662 my $val = $self->{checkout}->get ($entry, 1); 1663 return unless $val && $val->{'.conflict'}; 1664 $self->{checkout}->store ($entry, {%$val, '.conflict' => undef}); 1665 $logger->warn(loc("%1 marked as resolved.", $entry)); 1666} 1667 1668sub do_resolved { 1669 my ($self, %arg) = @_; 1670 1671 if ($arg{recursive}) { 1672 for ($self->{checkout}->find ($arg{copath}, {'.conflict' => qr/.*/})) { 1673 $self->resolved_entry ($_); 1674 } 1675 } 1676 else { 1677 $self->resolved_entry ($arg{copath}); 1678 } 1679} 1680 1681sub get_eol_layer { 1682 my ($prop, $mode, $checkle) = @_; 1683 my $k = $prop->{'svn:eol-style'} or return ':raw'; 1684 # short-circuit no-op write layers on lf platforms 1685 if (NATIVE eq LF) { 1686 return ':raw' if $mode eq '>' && ($k eq 'native' or $k eq 'LF'); 1687 } 1688 # XXX: on write we should actually be notified when it's to be 1689 # normalized. 1690 if ($k eq 'native') { 1691 $checkle = $checkle ? '!' : ''; 1692 return ":raw:eol(LF$checkle-Native)"; 1693 } 1694 elsif ($k eq 'CRLF' or $k eq 'CR' or $k eq 'LF') { 1695 $k .= '!' if $checkle; 1696 return ":raw:eol($k)"; 1697 } 1698 else { 1699 return ':raw'; # unsupported 1700 } 1701} 1702 1703# Remove anything from the keyword value that could prevent us from being able 1704# to correctly collapse it again later. 1705sub _sanitize_keyword_value { 1706 my $value = shift; 1707 $value =~ s/[\r\n]/ /g; 1708 $value =~ s/ +\$/\$/g; 1709 return $value; 1710} 1711 1712sub get_keyword_layer { 1713 my ($root, $path, $prop) = @_; 1714 my $k = $prop->{'svn:keywords'}; 1715 return unless $k; 1716 1717 # XXX: should these respect svm related stuff 1718 my %kmap = ( Date => 1719 sub { my ($root, $path) = @_; 1720 my $rev = $root->node_created_rev ($path); 1721 my $fs = $root->fs; 1722 $fs->revision_prop ($rev, 'svn:date'); 1723 }, 1724 Rev => 1725 sub { my ($root, $path) = @_; 1726 $root->node_created_rev ($path); 1727 }, 1728 Author => 1729 sub { my ($root, $path) = @_; 1730 my $rev = $root->node_created_rev ($path); 1731 my $fs = $root->fs; 1732 $fs->revision_prop ($rev, 'svn:author'); 1733 }, 1734 Id => 1735 sub { my ($root, $path) = @_; 1736 my $rev = $root->node_created_rev ($path); 1737 my $fs = $root->fs; 1738 join( ' ', $path, $rev, 1739 $fs->revision_prop ($rev, 'svn:date'), 1740 $fs->revision_prop ($rev, 'svn:author'), '' 1741 ); 1742 }, 1743 URL => 1744 sub { my ($root, $path) = @_; 1745 return $path; 1746 }, 1747 FileRev => 1748 sub { my ($root, $path) = @_; 1749 my $rev = 0; 1750 traverse_history ( root => $root, 1751 path => $path, 1752 cross => 0, 1753 callback => sub { ++$rev }); 1754 "#$rev"; 1755 }, 1756 ); 1757 my %kalias = qw( 1758 LastChangedDate Date 1759 LastChangedRevision Rev 1760 LastChangedBy Author 1761 HeadURL URL 1762 1763 Change Rev 1764 File URL 1765 DateTime Date 1766 Revision Rev 1767 FileRevision FileRev 1768 ); 1769 1770 $kmap{$_} = $kmap{$kalias{$_}} for keys %kalias; 1771 1772 my %key = map { ($_ => 1) } grep {exists $kmap{$_}} (split /\W+/,$k); 1773 return unless %key; 1774 while (my ($k, $v) = each %kalias) { 1775 $key{$k}++ if $key{$v}; 1776 $key{$v}++ if $key{$k}; 1777 } 1778 1779 my $keyword = '('.join('|', sort keys %key).')'; 1780 1781 return PerlIO::via::dynamic->new 1782 (translate => 1783 sub { $_[1] =~ s/\$($keyword)(?:: .*? )?\$/"\$$1: "._sanitize_keyword_value($kmap{$1}->($root, $path)).' $'/eg; }, 1784 untranslate => 1785 sub { $_[1] =~ s/\$($keyword)(?:: .*? )?\$/\$$1\$/g; }); 1786} 1787 1788sub _fh_symlink { 1789 my ($mode, $fname) = @_; 1790 my $fh; 1791 if ($mode eq '>') { 1792 open $fh, '>:via(symlink)', $fname; 1793 } 1794 elsif ($mode eq '<') { 1795 # XXX: make PerlIO::via::symlink also do the reading 1796 open $fh, '<', \("link ".readlink($fname)); 1797 } 1798 else { 1799 die "unknown mode $mode for symlink fh"; 1800 } 1801 return $fh; 1802} 1803 1804=item get_fh 1805 1806Returns a file handle with keyword translation and line-ending layers attached. 1807 1808=cut 1809 1810sub get_fh { 1811 my ($root, $mode, $path, $fname, $prop, $layer, $eol) = @_; 1812 { 1813 # don't care about nonexisting path, for new file with keywords 1814 local $@; 1815 $prop ||= eval { $root->node_proplist($path) } || {}; 1816 } 1817 use Carp; Carp::cluck unless ref $prop eq 'HASH'; 1818 return _fh_symlink ($mode, $fname) 1819 if HAS_SYMLINK and ( defined $prop->{'svn:special'} || ($mode eq '<' && is_symlink($fname)) ); 1820 if (keys %$prop) { 1821 $layer ||= get_keyword_layer ($root, $path, $prop); 1822 $eol ||= get_eol_layer($prop, $mode); 1823 } 1824 $eol ||= ':raw'; 1825 open my ($fh), $mode.$eol, $fname or return undef; 1826 $layer->via ($fh) if $layer; 1827 return $fh; 1828} 1829 1830=item get_props 1831 1832Returns the properties associated with a node. Properties schedule for 1833commit are merged if C<$copath> is given. 1834 1835=back 1836 1837=cut 1838 1839sub _combine_prop { 1840 my ($props, $newprops) = @_; 1841 return $props unless $newprops; 1842 $props = {%$props, %$newprops}; 1843 for (keys %$props) { 1844 delete $props->{$_} 1845 if ref ($props->{$_}) && !defined ${$props->{$_}}; 1846 } 1847 return $props; 1848} 1849 1850sub _copy_source { 1851 my ($self, $entry, $copath, $root) = @_; 1852 return unless $entry->{scheduleanchor}; 1853 my $descendent = abs2rel($copath, $entry->{scheduleanchor}, '', '/'); 1854 $entry = $self->{checkout}->get ($entry->{scheduleanchor}, 1) 1855 if $entry->{scheduleanchor} ne $copath; 1856 my $from = $entry->{'.copyfrom'} or return; 1857 $from .= $descendent; 1858 return ($from, $root ? $root->fs->revision_root ($entry->{'.copyfrom_rev'}) 1859 : $entry->{'.copyfrom_rev'}); 1860} 1861 1862sub get_props { 1863 my ($self, $root, $path, $copath, $entry) = @_; 1864 my $props = {}; 1865 $entry ||= $self->{checkout}->get ($copath, 1) if $copath; 1866 my $schedule = $entry->{'.schedule'} || ''; 1867 1868 if (my ($source_path, $source_root) = $self->_copy_source ($entry, $copath, $root)) { 1869 $props = $source_root->node_proplist ($source_path); 1870 } 1871 elsif ($schedule ne 'add' && $schedule ne 'replace') { 1872 Carp::cluck 'hate' unless defined $path; 1873 $props = $root->node_proplist ($path); 1874 } 1875 return _combine_prop ($props, $entry->{'.newprop'}); 1876} 1877 1878sub cache_directory { 1879 my ($self) = @_; 1880 my $rv = catdir ( $self->{svkpath}, 'cache' ); 1881 mkdir $rv or die $! unless -e $rv; 1882 return $rv; 1883} 1884 1885sub patch_directory { 1886 my ($self) = @_; 1887 my $rv = catdir ( $self->{svkpath}, 'patch' ); 1888 mkdir $rv or die $! unless -e $rv; 1889 return $rv; 1890} 1891 1892sub patch_file { 1893 my ($self, $name) = @_; 1894 return '-' if $name eq '-'; 1895 return catdir ($self->patch_directory, "$name.patch"); 1896} 1897 1898sub DESTROY { 1899 my ($self) = @_; 1900 return if $self->{updated}; 1901 $self->store (); 1902} 1903 1904package SVK::XD::Signature; 1905use SVK::Util qw( $SEP ); 1906 1907sub new { 1908 my ($class, @arg) = @_; 1909 my $self = bless {}, __PACKAGE__; 1910 %$self = @arg; 1911 mkdir ($self->{root}) or die $! unless -e $self->{root}; 1912 return $self; 1913} 1914 1915sub load { 1916 my ($factory, $path) = @_; 1917 my $spath = $path; 1918 1919 if ($factory->{floating}) { 1920 $spath .= $SEP if $spath eq $factory->{floating}; 1921 $spath = substr($spath, length($factory->{floating})); 1922 } 1923 1924 $spath =~ s{(?=[_=])}{=}g; 1925 $spath =~ s{:}{=-}g; 1926 $spath =~ s{\Q$SEP}{_}go; 1927 my $self = bless { root => $factory->{root}, 1928 floating => $factory->{floating}, 1929 path => $path, spath => $spath }, __PACKAGE__; 1930 $self->read; 1931 return $self; 1932} 1933 1934sub path { 1935 my $self = shift; 1936 return "$self->{root}$SEP$self->{spath}"; 1937} 1938 1939sub lock_path { 1940 my $self = shift; 1941 return $self->path.'=lock'; 1942} 1943 1944sub lock { 1945 my ($self) = @_; 1946 my $path = $self->lock_path; 1947 return if -e $path; 1948 open my $fh, '>', $path or warn $!, return; 1949 print $fh $$; 1950 $self->{locked} = 1; 1951} 1952 1953sub unlock { 1954 my ($self) = @_; 1955 my $path = $self->lock_path; 1956 unlink $path if -e $path; 1957 $self->{locked} = 0; 1958} 1959 1960sub read { 1961 my ($self) = @_; 1962 my $path = $self->path; 1963 if (-s $path) { 1964 open my $fh, '<:raw', $path or die $!; 1965 $self->{signature} = { <$fh> }; 1966 } 1967 else { 1968 $self->{signature} = {}; 1969 } 1970 1971 $self->{changed} = {}; 1972 $self->{newsignature} = {}; 1973} 1974 1975sub write { 1976 my ($self) = @_; 1977 my $path = $self->path; 1978 # nothing to write 1979 return unless keys %{$self->{changed}}; 1980 1981 $self->lock; 1982 return unless $self->{locked}; 1983 my ($hash, $file) = @_; 1984 open my $fh, '>:raw', $path or die $!; 1985 print {$fh} $self->{keepold} ? (%{$self->{signature}}, %{$self->{newsignature}}) 1986 : %{ $self->{newsignature} }; 1987 $self->unlock; 1988} 1989 1990sub changed { 1991 my ($self, $entry) = @_; 1992 my $file = "$self->{path}/$entry"; 1993 # inode, mtime, size 1994 my @sig = (stat ($file))[1,7,9] or return 1; 1995 1996 my ($key, $value) = (quotemeta($entry)."\n", "@sig\n"); 1997 my $changed = (!exists $self->{signature}{$key} || 1998 $self->{signature}{$key} ne $value); 1999 $self->{changed}{$key} = 1 if $changed; 2000 delete $self->{signature}{$key}; 2001 $self->{newsignature}{$key} = $value 2002 if !$self->{keepold} || $changed; 2003 2004 return $changed; 2005} 2006 2007sub invalidate { 2008 my ($self, $entry) = @_; 2009 my $key = quotemeta($entry)."\n"; 2010 delete $self->{newsignature}{$key}; 2011 delete $self->{changed}{$key}; 2012} 2013 2014sub flush { 2015 my ($self) = @_; 2016 $self->write; 2017} 2018 20191; 2020