1#!/usr/bin/env perl 2# 3########################################################################## 4# @(#) App::PFM::Directory 1.12 5# 6# Name: App::PFM::Directory 7# Version: 1.12 8# Author: Rene Uittenbogaard 9# Created: 1999-03-14 10# Date: 2014-04-08 11# 12 13########################################################################## 14 15=pod 16 17=head1 NAME 18 19App::PFM::Directory 20 21=head1 DESCRIPTION 22 23PFM Directory class, containing the directory contents and the 24actions that can be performed on them. 25 26=head1 METHODS 27 28=over 29 30=cut 31 32########################################################################## 33# declarations 34 35package App::PFM::Directory; 36 37use base qw(App::PFM::Abstract Exporter); 38 39use App::PFM::Job::Bazaar; 40use App::PFM::Job::Cvs; 41use App::PFM::Job::Git; 42use App::PFM::Job::Mercurial; 43use App::PFM::Job::Subversion; 44use App::PFM::File; 45use App::PFM::Screen qw(:constants); 46use App::PFM::Util qw(clearugidcache canonicalize_path basename dirname); 47use POSIX qw(getcwd); 48 49use strict; 50use locale; 51 52use constant { 53 RCS_DONE => 0, 54 RCS_RUNNING => 1, 55 SLOWENTRIES => 300, 56 D_FILTER => 128, # decide what to display (init @showncontents) 57 D_SORT => 256, # sort @dircontents 58 D_CONTENTS => 512, # read directory contents from disk 59 D_SMART => 1024, # make D_CONTENTS smart (i.e. smart refresh) 60# D_FILELIST # D_CONTENTS + D_SORT + D_FILTER 61 D_CHDIR => 2048, # filesystem usage data 62# D_ALL # D_CHDIR + D_FILELIST 63 M_MARK => '*', 64 M_OLDMARK => '.', 65 M_NEWMARK => '~', 66}; 67 68use constant D_FILELIST => D_SORT | D_FILTER | D_CONTENTS; 69use constant D_FILELIST_SMART => D_SORT | D_FILTER | D_CONTENTS | D_SMART; 70use constant D_ALL => D_CHDIR | D_FILELIST; 71 72use constant RCS => [ qw( 73 Subversion 74 Mercurial 75 Cvs 76 Bazaar 77 Git 78) ]; 79 80our %EXPORT_TAGS = ( 81 constants => [ qw( 82 D_FILTER 83 D_SORT 84 D_CONTENTS 85 D_SMART 86 D_FILELIST 87 D_FILELIST_SMART 88 D_CHDIR 89 D_ALL 90 M_MARK 91 M_OLDMARK 92 M_NEWMARK 93 ) ] 94); 95 96our @EXPORT_OK = @{$EXPORT_TAGS{constants}}; 97 98our ($_pfm); 99 100########################################################################## 101# private subs 102 103=item _init(App::PFM::Application $pfm, App::PFM::Screen $screen, 104App::PFM::Config $config, App::PFM::OS $os, App::PFM::JobHandler $jobhandler, 105string $path) 106 107Initializes new instances. Called from the constructor. 108 109=cut 110 111sub _init { 112 my ($self, $pfm, $screen, $config, $os, $jobhandler, $path) = @_; 113 $App::PFM::File::_pfm = $pfm; 114 $_pfm = $pfm; 115 $self->{_screen} = $screen; 116 $self->{_config} = $config; 117 $self->{_os} = $os; 118 $self->{_jobhandler} = $jobhandler; 119 $self->{_path} = $path; 120 $self->{_logicalpath} = $path; 121 $self->{_rcsjob} = undef; 122 $self->{_wasquit} = undef; 123 $self->{_path_mode} = 'log'; 124 $self->{_ignore_mode} = 0; 125 $self->{_dircontents} = []; 126 $self->{_showncontents} = []; 127 $self->{_marked_nr_of} = {}; 128 $self->{_total_nr_of} = {}; 129 $self->{_disk} = {}; 130 $self->{_dirty} = 0; 131 132 $self->_install_event_handlers(); 133 return; 134} 135 136=item _clone(App::PFM::Directory $original [ , array @args ] ) 137 138Performs one phase of the cloning process by cloning an existing 139App::PFM::Directory instance. 140 141=cut 142 143sub _clone { 144 my ($self, $original, @args) = @_; 145 # note: we are not cloning the files here. 146 $self->{_dircontents} = [ @{$original->{_dircontents} } ]; 147 $self->{_showncontents} = [ @{$original->{_showncontents} } ]; 148 $self->{_marked_nr_of} = { %{$original->{_marked_nr_of} } }; 149 $self->{_total_nr_of} = { %{$original->{_total_nr_of} } }; 150 $self->{_disk} = { %{$original->{_disk} } }; 151 152 # Any running rcs job has got event handlers pointing to the original 153 # Directory object (i.e., not to our event handlers). Remove the job 154 # number from the clone. 155 $self->{_rcsjob} = undef; 156 157 $self->_install_event_handlers(); 158 return; 159} 160 161=item _install_event_handlers() 162 163Installs listeners for the events 'after_set_color_mode' (fired 164by App::PFM::Screen) and 'after_change_formatlines' (fired by 165App::PFM::Screen::Listing), that require reformatting of the File objects. 166 167=cut 168 169sub _install_event_handlers { 170 my ($self) = @_; 171 $self->{_on_after_change_formatlines} = 172 $self->{_on_after_set_color_mode} = sub { 173 $self->reformat(); 174 }; 175 $self->{_screen}->register_listener( 176 'after_set_color_mode', $self->{_on_after_set_color_mode}); 177 $self->{_screen}->listing->register_listener( 178 'after_change_formatlines', $self->{_on_after_change_formatlines}); 179 return; 180} 181 182=item _by_sort_mode() 183 184Sorts two directory entries according to the selected sort mode. 185Dotdot mode is taken into account. 186 187=cut 188 189sub _by_sort_mode { 190 my ($self) = @_; 191 if ($self->{_config}->{dotdot_mode}) { 192 # Oleg Bartunov requested to have . and .. unsorted (always at the top) 193 if ($a->{name} eq '.' ) { return -1 } 194 elsif ($b->{name} eq '.' ) { return 1 } 195 elsif ($a->{name} eq '..') { return -1 } 196 elsif ($b->{name} eq '..') { return 1 } 197 } 198 return $self->_sort_multilevel($_pfm->state->sort_mode); 199} 200 201=item _sort_multilevel(string $sort_mode) 202 203Recursively sorts two directory entries according to the selected 204sort mode string (multilevel). 205 206=cut 207 208sub _sort_multilevel { 209 my ($self, $sort_mode) = @_; 210 return 0 unless length $sort_mode; 211 return 212 $self->_sort_singlelevel(substr($sort_mode, 0, 1)) || 213 $self->_sort_multilevel( substr($sort_mode, 1)); 214} 215 216=item _sort_singlelevel(char $sort_mode) 217 218Sorts two directory entries according to the selected sort mode 219character (one level). 220 221=cut 222 223sub _sort_singlelevel { 224 my ($self, $sort_mode) = @_; 225 my ($exta, $extb); 226 for ($sort_mode) { 227 /n/ and return $a->{name} cmp $b->{name}; 228 /N/ and return $b->{name} cmp $a->{name}; 229 /m/ and return lc($a->{name}) cmp lc($b->{name}); 230 /M/ and return lc($b->{name}) cmp lc($a->{name}); 231 /d/ and return $a->{mtime} <=> $b->{mtime}; 232 /D/ and return $b->{mtime} <=> $a->{mtime}; 233 /a/ and return $a->{atime} <=> $b->{atime}; 234 /A/ and return $b->{atime} <=> $a->{atime}; 235 /s/ and return $a->{size} <=> $b->{size}; 236 /S/ and return $b->{size} <=> $a->{size}; 237 /z/ and return $a->{grand} <=> $b->{grand}; 238 /Z/ and return $b->{grand} <=> $a->{grand}; 239 /u/ and return $a->{user} cmp $b->{user}; 240 /U/ and return $b->{user} cmp $a->{user}; 241 /g/ and return $a->{group} cmp $b->{group}; 242 /G/ and return $b->{group} cmp $a->{group}; 243 /w/ and return $a->{uid} <=> $b->{uid}; 244 /W/ and return $b->{uid} <=> $a->{uid}; 245 /h/ and return $a->{gid} <=> $b->{gid}; 246 /H/ and return $b->{gid} <=> $a->{gid}; 247 /l/ and return $a->{nlink} <=> $b->{nlink}; 248 /L/ and return $b->{nlink} <=> $a->{nlink}; 249 /i/ and return $a->{inode} <=> $b->{inode}; 250 /I/ and return $b->{inode} <=> $a->{inode}; 251 /v/ and return $a->{rcs} cmp $b->{rcs}; 252 /V/ and return $b->{rcs} cmp $a->{rcs}; 253 /t/ and do { 254 return 0 if ($a->{type} eq $b->{type}); 255 return -1 if ($a->{type} eq 'd'); 256 return 1 if ($b->{type} eq 'd'); 257 return $a->{type} cmp $b->{type}; 258 }; 259 /T/ and do { 260 return 0 if ($a->{type} eq $b->{type}); 261 return -1 if ($b->{type} eq 'd'); 262 return 1 if ($a->{type} eq 'd'); 263 return $b->{type} cmp $a->{type}; 264 }; 265 /p/ and do { 266 return 0 if ($a->{mode} eq $b->{mode}); 267 return $a->{mode} cmp $b->{mode}; 268 }; 269 /P/ and do { 270 return 0 if ($a->{mode} eq $b->{mode}); 271 return $b->{mode} cmp $a->{mode}; 272 }; 273 /\*/ and do { 274 return 0 if ($a->{mark} eq $b->{mark}); 275 return -1 if ($a->{mark} eq M_MARK ); 276 return 1 if ($b->{mark} eq M_MARK ); 277 return -1 if ($a->{mark} eq M_NEWMARK); 278 return 1 if ($b->{mark} eq M_NEWMARK); 279 return -1 if ($a->{mark} eq M_OLDMARK); 280 return 1 if ($b->{mark} eq M_OLDMARK); 281 return $a->{mark} cmp $b->{mark}; 282 }; 283 /[ef]/i and do { 284 $exta = $extb = ''; 285 if ($a->{name} =~ /^.*(\.[^\.]+)$/) { 286 $exta = $1; 287 } 288 if ($b->{name} =~ /^.*(\.[^\.]+)$/) { 289 $extb = $1; 290 } 291 /e/ and return $exta cmp $extb; 292 /E/ and return $extb cmp $exta; 293 /f/ and return lc($exta) cmp lc($extb); 294 /F/ and return lc($extb) cmp lc($exta); 295 }; 296 } 297 return; 298} 299 300=item _init_filesystem_info() 301 302Determines the current filesystem usage and stores it in an internal hash. 303 304=cut 305 306sub _init_filesystem_info { 307 my ($self) = @_; 308 my (@dflist, @mountlist, $mountpoint, @mountinfo, $fstype, $layers, @layers); 309 310 chop (@dflist = $self->{_os}->df($self->{_path})); 311 shift @dflist; # skip header 312 @{$self->{_disk}}{qw/device total used avail/} = split (/\s+/, $dflist[0]); 313 $dflist[0] =~ /(\S*)$/; 314 $mountpoint = $1; 315 $self->{_disk}{mountpoint} = $mountpoint; 316 317 chop (@mountlist = $self->{_os}->backtick('mount')); 318 # "none on /dev/pts type devpts (rw,noexec,nosuid,gid=5,mode=0620)" 319 @mountinfo = grep { /^\S+\s+on\s+(\Q$mountpoint\E)\s+/ } @mountlist; 320 321 # For aufs. TODO move this to App::PFM::Filesystem 322 # "none on /mnt/overlay type aufs (rw,br:/mnt/upper:/mnt/intermediate:/mnt/lower)" 323 ($fstype) = $mountinfo[0] =~ /\Q$mountpoint\E\s+type\s+(\S+)/; 324 ($layers) = $mountinfo[0] =~ /[\(,]br:([^\)]+)/; 325 @layers = split(/:/, $layers) if defined $layers; 326# $self->{_disk}{mountinfo} = $mountinfo[0]; 327 $self->{_disk}{fstype} = $fstype; 328 $self->{_disk}{layers} = [ @layers ]; 329 330 return $self->{_disk}; 331} 332 333=item _init_dircount() 334 335Initializes the total number of entries of each type in the current 336directory by zeroing them out. 337 338=cut 339 340sub _init_dircount { 341 my ($self) = @_; 342 %{$self->{_marked_nr_of}} = 343 %{$self->{_total_nr_of}} = 344 ( d=>0, '-'=>0, l=>0, c=>0, b=>0, D=>0, P=>0, 345 p=>0, 's'=>0, n=>0, w=>0, bytes => 0 ); 346 return; 347} 348 349=item _countcontents(array @entries) 350 351Counts the total number of entries of each type in the current directory. 352 353=cut 354 355sub _countcontents { 356 my ($self, @entries) = @_; 357 $self->_init_dircount(); 358 foreach my $i (0..$#entries) { 359 $self->{_total_nr_of }{$entries[$i]{type}}++; 360 $self->{_marked_nr_of}{$entries[$i]{type}}++ 361 if $entries[$i]{mark} eq M_MARK; 362 } 363 return; 364} 365 366=item _readcontents(bool $smart) 367 368Reads the entries in the current directory and performs a stat() on them. 369 370If I<smart> is false, the directory is read fresh. If true, the directory 371is refreshed but the marks are retained. 372 373=cut 374 375sub _readcontents { 376 my ($self, $smart) = @_; 377 my ($file, %namemarkmap, $counter, $interrupted, $interrupt_key, $layer); 378 my @allentries = (); 379 my @white_entries = (); 380 my %white_entries = (); 381 my @new_white_entries = (); 382 my $screen = $self->{_screen}; 383 # TODO stop jobs here? 384 clearugidcache(); 385 $self->_init_dircount(); 386 %namemarkmap = map { $_->{name}, $_->{mark}; } @{$self->{_dircontents}}; 387 $self->{_dircontents} = []; 388 $self->{_showncontents} = []; 389 # don't use '.' as the directory path to open: we may be just 390 # prepare()ing this object without actually entering the directory 391 if (opendir my $CURRENT, $self->{_path}) { 392 @allentries = readdir $CURRENT; 393 closedir $CURRENT; 394 # should be something like $self->{_filesystem}->listwhite() 395 if ($self->{_disk}{fstype} eq 'aufs') { 396 foreach $layer (@{$self->{_disk}{layers}}) { 397 @new_white_entries = 398 grep { !/^\.wh\./ } 399 map { s!\Q$layer\E/\.wh\.!!; $_ } 400 glob("$layer/.wh.*"); 401 push @white_entries, @new_white_entries; 402 } 403 # remove duplicates (we may have whiteout entries in multiple layers) 404 @white_entries{@white_entries} = (); 405 @white_entries = keys %white_entries; 406 } else { 407 # chop newlines 408 @white_entries = map { chop; $_ } $self->{_os}->listwhite($self->{_path}); 409 } 410 } else { 411 $screen->at(0,0)->clreol()->display_error("Cannot read . : $!"); 412 } 413 # next lines also correct for directories with no entries at all 414 # (this is sometimes the case on NTFS filesystems: why?) 415 if ($#allentries < 0) { 416 @allentries = ('.', '..'); 417 } 418 if ($#allentries > SLOWENTRIES) { 419 $screen->at(0,0)->clreol()->putmessage('Please Wait'); 420 } 421 $counter = $#allentries + SLOWENTRIES/2; # Prevent "0" from being printed 422 STAT_ENTRIES: foreach my $entry (@allentries) { 423 # have the mark cleared on first stat with ' ' 424 $self->add({ 425 entry => $entry, 426 skip_stat => $interrupted, 427 white => '', 428 mark => $smart ? $namemarkmap{$entry} : ' ' 429 }); 430 unless (--$counter % SLOWENTRIES) { 431 $screen->at(0,0)->putmessage( 432 sprintf('Please Wait [%d]', $counter / SLOWENTRIES))->clreol(); 433 } 434 # See if a new key was pressed. 435 if (!defined($interrupt_key) and $screen->pending_input()) { 436 # See if it was "Escape". 437 if (($interrupt_key = $screen->getch()) eq "\e") { 438 # It was. Flag "interrupted" for the rest of the loop. 439 $interrupted = 1; 440 } else { 441 # It was not. Put it back on the input queue. 442 $screen->stuff_input($interrupt_key); 443 } 444 } 445 } 446 foreach my $entry (@white_entries) { 447 $self->add({ 448 entry => $entry, 449 white => 'w', 450 mark => $smart ? $namemarkmap{$entry} : ' ' 451 }); 452 } 453 $screen->set_deferred_refresh(R_MENU | R_HEADINGS); 454 $self->checkrcsapplicable() if $self->{_config}{autorcs}; 455 return $self->{_dircontents}; 456} 457 458=item _sortcontents() 459 460Sorts the directory's contents according to the selected sort mode. 461 462=cut 463 464sub _sortcontents { 465 my ($self) = @_; 466 @{$self->{_dircontents}} = 467 sort { $self->_by_sort_mode } @{$self->{_dircontents}}; 468 return; 469} 470 471=item _filtercontents() 472 473Filters the directory contents according to the filter modes 474(displays or hides dotfiles and whiteouts). 475 476=cut 477 478sub _filtercontents { 479 my ($self) = @_; 480 @{$self->{_showncontents}} = grep { 481 $_pfm->state->{dot_mode} || $_->{name} =~ /^(\.\.?|[^\.].*)$/ and 482 $_pfm->state->{white_mode} || $_->{type} ne 'w' 483 } @{$self->{_dircontents}}; 484 return; 485} 486 487=item _catch_quit() 488 489Catches terminal quit signals (SIGQUIT). 490 491=cut 492 493sub _catch_quit { 494 my ($self) = @_; 495 $self->{_wasquit} = 1; 496 $SIG{QUIT} = \&_catch_quit; 497 return; 498} 499 500########################################################################## 501# constructor, getters and setters 502 503=item destroy() 504 505Unregisters our 'after_change_formatlines' and 'after_set_color_mode' 506event listeners with the App::PFM::Screen and App::PFM::Screen::Listing 507objects. This removes the references that they have to us, readying the 508Directory object for garbage collection. 509 510=cut 511 512sub destroy { 513 my ($self) = @_; 514 my $screen = $self->{_screen}; 515 if (defined $screen) { 516 $screen->unregister_listener( 517 'after_set_color_mode', 518 $self->{_on_after_set_color_mode}); 519 if (defined $screen->listing) { 520 $screen->listing->unregister_listener( 521 'after_change_formatlines', 522 $self->{_on_after_change_formatlines}); 523 } 524 } 525# $self->stop_any_rcsjob(); 526 return; 527} 528 529=item path() 530 531Getter for the current directory path. Setting the current 532directory should be done through App::PFM::Directory::chdir() or 533App::PFM::Directory::prepare(). 534 535=cut 536 537sub path { 538 my ($self) = @_; 539 return $self->{_path}; 540} 541 542=item dircontents( [ arrayref $dircontents ] ) 543 544Getter/setter for the $_dircontents member variable, which points to 545the complete array of files in the directory. 546 547=cut 548 549sub dircontents { 550 my ($self, $value) = @_; 551 $self->{_dircontents} = $value if defined $value; 552 return $self->{_dircontents}; 553} 554 555=item showncontents( [ arrayref $showncontents ] ) 556 557Getter/setter for the $_showncontents member variable, which points to 558the array of the files shown on-screen. 559 560=cut 561 562sub showncontents { 563 my ($self, $value) = @_; 564 $self->{_showncontents} = $value if defined $value; 565 return $self->{_showncontents}; 566} 567 568=item total_nr_of() 569 570Getter for the hash which keeps track of how many directory entities 571of each type there are. 572 573=cut 574 575sub total_nr_of { 576 return $_[0]->{_total_nr_of}; 577} 578 579=item marked_nr_of() 580 581Getter for the hash which keeps track of how many directory entities 582of each type have been marked. 583 584=cut 585 586sub marked_nr_of { 587 return $_[0]->{_marked_nr_of}; 588} 589 590=item disk() 591 592Getter for the hash which keeps track of filesystem information: 593usage, mountpoint and device. 594 595=cut 596 597sub disk { 598 return $_[0]->{_disk}; 599} 600 601=item mountpoint( [ string $mountpoint ] ) 602 603Getter/setter for the mountpoint on which the current directory is situated. 604 605=cut 606 607sub mountpoint { 608 my ($self, $value) = @_; 609 $self->{_disk}{mountpoint} = $value if defined $value; 610 return $self->{_disk}{mountpoint}; 611} 612 613=item device( [ string $device ] ) 614 615Getter/setter for the device on which the current directory is situated. 616 617=cut 618 619sub device { 620 my ($self, $value) = @_; 621 $self->{_disk}{device} = $value if defined $value; 622 return $self->{_disk}{device}; 623} 624 625=item path_mode( [ string $path_mode ] ) 626 627Getter/setter for the path mode setting ('phys' or 'log') 628 629=cut 630 631sub path_mode { 632 my ($self, $value) = @_; 633 if (defined $value) { 634 $self->{_path_mode} = $value; 635 if ($self->{_path_mode} eq 'phys') { 636 $self->{_path} = getcwd(); 637 } else { 638 $self->{_path} = $self->{_logicalpath}; 639 } 640 $self->{_screen}->set_deferred_refresh(R_FOOTER | R_PATHINFO); 641 } 642 return $self->{_path_mode}; 643} 644 645=item ignore_mode( [ bool $ignore_mode ] ) 646 647Getter/setter for the ignore mode setting. 648 649=cut 650 651sub ignore_mode { 652 my ($self, $value) = @_; 653 if (defined $value) { 654 $self->{_ignore_mode} = $value; 655 $self->{_screen}->set_deferred_refresh(R_FOOTER); 656 $self->preparercscol(); 657 $self->checkrcsapplicable(); 658 } 659 return $self->{_ignore_mode}; 660} 661 662########################################################################## 663# public subs 664 665=item prepare( [ string $path ] ) 666 667Prepares the contents of this directory object. Can be used if this 668state should not be displayed on-screen right away. 669 670=cut 671 672sub prepare { 673 my ($self, $path) = @_; 674 $self->path_mode($self->{_config}{path_mode}); 675 if (defined $path) { 676 $self->{_path} = $path; 677 $self->{_logicalpath} = $path; 678 } 679 $self->_init_filesystem_info(); 680 $self->_readcontents(); # prepare(), so no need for D_SMART 681 $self->_sortcontents(); 682 $self->_filtercontents(); 683 $self->{_dirty} = 0; 684 return; 685} 686 687=item chdir(string $nextdir [, string $direction [, bool $no_save_prev ] ] ) 688 689Tries to change the current working directory, if necessary using B<CDPATH>. 690If successful, it stores the previous state in App::PFM::Application->_states 691and executes the 'chdirautocmd' from the F<.pfmrc> file. 692 693The I<direction> argument can be 'up' (when changing to a parent directory), 694'down' (when descending into a directory) or empty (when making a jump) and 695will determine where the cursor will be positioned in the new directory (at 696the previous directory when moving up, at '..' when descending, and at '.' 697when making a jump). 698 699The I<no_save_prev> argument can be used to indicate that the current 700state should not be saved to the "previous" state (B<F2> command). 701 702=cut 703 704sub chdir { 705 my ($self, $nextdir, $direction, $no_save_prev) = @_; 706 my ($success, $chdirautocmd, $nextpos); 707 my $screen = $self->{_screen}; 708 my $prevdir = $self->{_path}; 709 if ($nextdir eq '') { 710 $nextdir = $ENV{HOME}; 711 } elsif (-d $nextdir and $nextdir !~ m!^/!) { 712 $nextdir = "$prevdir/$nextdir"; 713 } elsif ($nextdir !~ m!/!) { 714 foreach (split /:/, $ENV{CDPATH}) { 715 if (-d "$_/$nextdir") { 716 $nextdir = "$_/$nextdir"; 717 $screen->at(0,0)->clreol() 718 ->display_error("Using $nextdir") 719 ->at(0,0); 720 last; 721 } 722 } 723 } 724 $nextdir = canonicalize_path($nextdir); 725 $self->fire(App::PFM::Event->new({ 726 name => 'before_change_directory', 727 type => 'soft', 728 # TODO use this event to flag to Application that the S_MAIN is to be 729 # saved in S_PREV. 730 })); 731 if ($success = chdir $nextdir and $nextdir ne $prevdir) { 732 # store the cursor position in the state 733 $_pfm->state->{_position} = $_pfm->browser->currentfile->{name}; 734 $_pfm->state->{_baseindex} = $_pfm->browser->baseindex; 735 unless ($no_save_prev) { # TODO move this to Application? 736 # Note that the clone does not inherit the rcs job number. 737 $_pfm->state('S_PREV', $_pfm->state->clone()); 738 } 739 # Stop the rcs job. We don't need it any more. 740 $self->stop_any_rcsjob(); 741 # In 'phys' mode: find the physical name of the directory. 742 if ($self->{_path_mode} eq 'phys') { 743 $self->{_path} = getcwd(); 744 } else { 745 $self->{_path} = $nextdir; 746 } 747 $self->{_logicalpath} = $self->{_path}; 748 # restore the cursor position 749# if ($swapping) { 750# $_pfm->browser->position_at($_pfm->state->{_position}); 751# $_pfm->browser->baseindex( $_pfm->state->{_baseindex}); 752# $screen->set_deferred_refresh(R_SCREEN); 753# } else { 754 $nextpos = $direction eq 'up' 755 ? basename($prevdir) 756 : $direction eq 'down' ? '..' : '.'; 757 $_pfm->browser->position_at($nextpos); 758 $_pfm->browser->baseindex(0); 759 $screen->set_deferred_refresh(R_CHDIR); 760 $self->set_dirty(D_ALL); 761# } 762 $chdirautocmd = $self->{_config}{chdirautocmd}; 763 system("$chdirautocmd") if length($chdirautocmd); 764 } 765 return $success; 766} 767 768=item addifabsent(hashref { entry => string $filename, white => char 769$iswhite, mark => char $mark, refresh => bool $refresh } ) 770 771Checks if the file is not yet in the directory. If not, add()s it. 772 773=cut 774 775sub addifabsent { 776 my ($self, $options) = @_; 777 my $findindex = 0; 778 my $dircount = $#{$self->{_dircontents}}; 779 my $file; 780 while ($findindex <= $dircount and 781 $options->{entry} ne ${$self->{_dircontents}}[$findindex]{name}) 782 { 783 $findindex++; 784 } 785 if ($findindex > $dircount) { 786 $self->add($options); 787 } else { 788 $file = ${$self->{_dircontents}}[$findindex]; 789 $self->unregister($file); 790 # copy $white from caller, it may be a whiteout. 791 # copy $mark from file (preserve). 792 $file->stat_entry($file->{name}, $options->{white}, $file->{mark}); 793 $self->register($file); 794 $self->set_dirty(D_FILTER | D_SORT); 795 # flag screen refresh 796 if ($options->{refresh}) { 797 $self->{_screen}->set_deferred_refresh(R_LISTING); 798 } 799 } 800 return; 801} 802 803=item add(hashref { entry => string $filename, white => char 804$iswhite, mark => char $mark, refresh => bool $refresh } ) 805 806Adds the entry as file to the directory. Also calls register(). 807 808=cut 809 810sub add { 811 my ($self, $options) = @_; 812 $options->{parent} = $self->{_path}; 813 my $file = App::PFM::File->new($options); 814 push @{$self->{_dircontents}}, $file; 815 $self->register($file); 816 $self->set_dirty(D_FILTER | D_SORT); 817 if ($options->{refresh}) { 818 $self->{_screen}->set_deferred_refresh(R_LISTING); 819 } 820 return; 821} 822 823=item register(App::PFM::File $file) 824 825Adds the file to the internal (total and marked) counters. 826 827=cut 828 829sub register { 830 my ($self, $entry) = @_; 831 $self->{_total_nr_of}{$entry->{type}}++; 832 if ($entry->{mark} eq M_MARK) { 833 $self->register_include($entry); 834 } 835 $self->{_screen}->set_deferred_refresh(R_DISKINFO); 836 return; 837} 838 839=item unregister(App::PFM::File $file) 840 841Removes the file from the internal (total and marked) counters. 842 843=cut 844 845sub unregister { 846 my ($self, $entry) = @_; 847 my $prevmark; 848 $self->{_total_nr_of}{$entry->{type}}--; 849 if ($entry->{mark} eq M_MARK) { 850 $prevmark = $self->register_exclude($entry); 851 } 852 $self->{_screen}->set_deferred_refresh(R_DISKINFO); 853 return $prevmark; 854} 855 856=item include(App::PFM::File $file) 857 858Marks a file. Updates the internal (marked) counters. 859 860=cut 861 862sub include { 863 my ($self, $entry) = @_; 864 $self->register_include($entry) if ($entry->{mark} ne M_MARK); 865 $entry->{mark} = M_MARK; 866 return; 867} 868 869=item exclude(App::PFM::File $file [, char $to_mark ] ) 870 871Removes a file's mark, or replaces it with I<to_mark>. Updates the 872internal (marked) counters. 873 874=cut 875 876sub exclude { 877 my ($self, $entry, $to_mark) = @_; 878 my $prevmark = $entry->{mark}; 879 $self->register_exclude($entry) if ($entry->{mark} eq M_MARK); 880 $entry->{mark} = $to_mark || ' '; 881 return $prevmark; 882} 883 884=item register_include(App::PFM::File $file) 885 886Adds a file to the counters of marked files. 887 888=cut 889 890sub register_include { 891 my ($self, $entry) = @_; 892 $self->{_marked_nr_of}{$entry->{type}}++; 893 $entry->{type} =~ /-/ and $self->{_marked_nr_of}{bytes} += $entry->{size}; 894 $self->{_screen}->set_deferred_refresh(R_DISKINFO); 895 return; 896} 897 898=item register_exclude(App::PFM::File $file) 899 900Removes a file from the counters of marked files. 901 902=cut 903 904sub register_exclude { 905 my ($self, $entry) = @_; 906 $self->{_marked_nr_of}{$entry->{type}}--; 907 $entry->{type} =~ /-/ and $self->{_marked_nr_of}{bytes} -= $entry->{size}; 908 $self->{_screen}->set_deferred_refresh(R_DISKINFO); 909 return; 910} 911 912=item ls() 913 914Used for debugging. 915 916=cut 917 918sub ls { 919 my ($self) = @_; 920 my $listing = $self->{_screen}->listing; 921 foreach my $file (@{$self->{_dircontents}}) { 922 print $listing->fileline($file), "\n"; 923 } 924 return; 925} 926 927=item set_dirty(int $flag_bits) 928 929Flags that this directory needs to be updated. The B<D_*> 930constants (see below) may be used to specify which aspect. 931 932=cut 933 934sub set_dirty { 935 my ($self, $bits) = @_; 936 $self->{_dirty} |= $bits; 937 return; 938} 939 940=item unset_dirty(int $flag_bits) 941 942Removes the flag that this directory needs to be updated. The B<D_*> 943constants (see below) may be used to specify which aspect. 944 945=cut 946 947sub unset_dirty { 948 my ($self, $bits) = @_; 949 $self->{_dirty} &= ~$bits; 950 return; 951} 952 953=item refresh() 954 955Refreshes the aspects of the directory that have been flagged as dirty. 956 957=cut 958 959sub refresh { 960 my ($self) = @_; 961 my $smart; 962 my $browser = $_pfm->browser; 963 my $dirty = $self->{_dirty}; 964 $self->{_dirty} = 0; 965 966 if ($dirty & D_FILELIST) { # any of the flags 967 # first time round 'currentfile' is undefined 968 if (defined $browser->currentfile) { 969 # TODO we should handle this with an event. 970 $browser->position_at($browser->currentfile->{name}); 971 } 972 # next line works because $screen->refresh() will re-examine 973 # the _deferred_refresh flags after the $directory->refresh(). 974 # 975 $self->{_screen}->set_deferred_refresh(R_LISTING); 976 } 977 # now refresh individual elements 978 if ($dirty & D_CHDIR) { 979 $self->_init_filesystem_info(); 980 } 981 if ($dirty & D_CONTENTS) { 982 # the smart flag is only respected if the current directory has changed 983 $smart = ( 984 !($dirty & D_CHDIR) and 985 ($dirty & D_SMART || $self->{_config}{refresh_always_smart}) 986 ); 987 $self->_readcontents($smart); 988 } 989 if ($dirty & D_SORT) { 990 $self->_sortcontents(); 991 } 992 if ($dirty & D_FILTER) { 993 $self->_filtercontents(); 994 } 995 return; 996} 997 998=item checkrcsapplicable( [ string $path ] ) 999 1000Checks if any rcs jobs are applicable for this directory, 1001and starts them. 1002 1003=cut 1004 1005sub checkrcsapplicable { 1006 my ($self, $entry) = @_; 1007 my $fullclass; 1008 my $path = $self->{_path}; 1009 my $screen = $self->{_screen}; 1010 $entry = defined $entry ? $entry : $path; 1011 my $on_after_job_start = sub { 1012 # next line needs to provide a '1' argument because 1013 # $self->{_rcsjob} has not yet been set 1014 $screen->set_deferred_refresh(R_HEADINGS); 1015 $screen->frame->rcsrunning(RCS_RUNNING); 1016 return; 1017 }; 1018 my $on_after_job_receive_data = sub { 1019 my $event = shift; 1020 my $job = $event->{origin}; 1021 my $count = 0; 1022 my %nameindexmap = 1023 map { $_->{name}, $count++ } @{$self->{_showncontents}}; 1024 foreach my $data_line (@{$event->{data}}) { 1025 my ($flags, $file) = @$data_line; 1026 my ($topdir, $mapindex, $oldval); 1027 if (substr($file, 0, length($path)) eq $path) { 1028 $file = substr($file, length($path)+1); # +1 for trailing / 1029 } 1030 # currentdir or subdir? 1031 if ($file =~ m!/!) { 1032 # change in subdirectory 1033 ($topdir = $file) =~ s!/.*!!; 1034 $mapindex = $nameindexmap{$topdir}; 1035 # find highest prio marker 1036 $oldval = $self->{_showncontents}[$mapindex]{rcs}; 1037 $self->{_showncontents}[$mapindex]{rcs} = 1038 $job->rcsmax($oldval, $flags); 1039# # if there was a change in a subdir, then show M on currentdir 1040# $mapindex = $nameindexmap{'.'}; 1041# # find highest prio marker 1042# $oldval = $self->{_showncontents}[$mapindex]{rcs}; 1043# $self->{_showncontents}[$mapindex]{rcs} = 1044# $job->rcsmax($oldval, 'M'); 1045 } else { 1046 # change file in current directory 1047# if (defined($mapindex = $nameindexmap{$file})) { 1048 $mapindex = $nameindexmap{$file}; 1049 $self->{_showncontents}[$mapindex]{rcs} = $flags; 1050# } 1051 } 1052 } # endfor $data_line ($event->data) 1053 # TODO only show if this directory is on-screen (is_main). 1054 $screen->listing->show(); 1055 $screen->listing->highlight_on(); 1056 return; 1057 }; 1058 my $on_after_job_finish = sub { 1059 $self->{_rcsjob} = undef; 1060 $screen->set_deferred_refresh(R_HEADINGS); 1061 $screen->frame->rcsrunning(RCS_DONE); 1062 return; 1063 }; 1064 # TODO when a directory is swapped out, the jobs should continue 1065 # Note that this supports only one revision control system per directory. 1066 foreach my $class (@{$self->RCS}) { 1067 $fullclass = "App::PFM::Job::$class"; 1068 if ($fullclass->isapplicable($path, $entry)) { 1069 # If the previous job did not yet finish, 1070 # kill it and run the command for the entire directory. 1071 if ($self->stop_any_rcsjob()) { 1072 $entry = $path; 1073 } 1074 $self->{_rcsjob} = $self->{_jobhandler}->start($class, { 1075 after_job_start => $on_after_job_start, 1076 after_job_receive_data => $on_after_job_receive_data, 1077 after_job_finish => $on_after_job_finish, 1078 }, { 1079 path => $entry, 1080 noignore => $self->{_ignore_mode}, 1081 }); 1082 return; 1083 } 1084 } 1085 return; 1086} 1087 1088=item stop_any_rcsjob() 1089 1090Stop an rcsjob, if it is running. 1091Returns a boolean indicating if one was running. 1092 1093=cut 1094 1095sub stop_any_rcsjob { 1096 my ($self) = @_; 1097 if (defined $self->{_rcsjob}) { 1098 # The after_job_finish handler will reset $self->{_rcsjob}. 1099 $self->{_jobhandler}->stop($self->{_rcsjob}); 1100 return 1; 1101 } 1102 return 0; 1103} 1104 1105=item preparercscol( [ App::PFM::File $file ] ) 1106 1107Prepares the 'Version' field in the directory contents by clearing it. 1108If a I<file> argument is provided, then only process this file; 1109otherwise, process this entire directory. 1110 1111=cut 1112 1113sub preparercscol { 1114 my ($self, $file) = @_; 1115 my $layoutfields = $self->{_screen}->listing->LAYOUTFIELDS; 1116 if (defined $file and $file->{name} ne '.') { 1117 $file->{$layoutfields->{'v'}} = '-'; 1118 return; 1119 } 1120 foreach (0 .. $#{$self->{_showncontents}}) { 1121 $self->{_showncontents}[$_]{$layoutfields->{'v'}} = '-'; 1122 } 1123 $self->{_screen}->set_deferred_refresh(R_LISTING); 1124 return; 1125} 1126 1127=item reformat() 1128 1129Adjusts the visual representation of the directory contents according 1130to the new layout. 1131 1132=cut 1133 1134sub reformat { 1135 my ($self) = @_; 1136 # the dircontents may not have been initialized yet 1137 return unless @{$self->{_dircontents}}; 1138 foreach (@{$self->{_dircontents}}) { 1139 $_->format(); 1140 } 1141 return; 1142} 1143 1144=item dirlookup(string $filename, array @dircontents) 1145 1146Finds a directory entry by name and returns its index. 1147Used by apply(). 1148 1149=cut 1150 1151sub dirlookup { 1152 # this assumes that the entry will be found 1153 my ($self, $name, @array) = @_; 1154 my $found = $#array; 1155 while ($found >= 0 and $array[$found]{name} ne $name) { 1156 $found--; 1157 } 1158 return $found; 1159} 1160 1161=item apply(coderef $do_this, App::PFM::Event $event, array @args) 1162 1163In single file mode: applies the supplied function to the current file, 1164as passed in I<$event-E<gt>{currentfile}>. 1165In multiple file mode: applies the supplied function to all marked files 1166in the current directory. 1167 1168Special flags can be passed in I<$event-E<gt>{lunchbox}{applyflags}>. 1169 1170If the apply flags contain 'delete', the directory is processed in 1171reverse order. This is important when deleting files. 1172 1173If the apply flags do not contain 'nofeedback', the filename of the file 1174being processed will be displayed on the second line of the screen. 1175 1176=cut 1177 1178sub apply { 1179 my ($self, $do_this, $event, @args) = @_; 1180 my $applyflags = $event->{lunchbox}{applyflags}; 1181 my ($loopfile, $deleted_index, $count, %nameindexmap); 1182 if ($_pfm->state->{multiple_mode}) { 1183 #$self->{_wasquit} = 0; 1184 #local $SIG{QUIT} = \&_catch_quit; 1185 my $screen = $self->{_screen}; 1186 my @range = 0 .. $#{$self->{_showncontents}}; 1187 if ($applyflags =~ /\bdelete\b/o) { 1188 @range = reverse @range; 1189 # build nameindexmap on dircontents, not showncontents. 1190 # this is faster than doing a dirlookup() every iteration 1191 $count = 0; 1192 %nameindexmap = 1193 map { $_->{name}, $count++ } @{$self->{_dircontents}}; 1194 } 1195 foreach my $i (@range) { 1196 $loopfile = $self->{_showncontents}[$i]; 1197 if ($loopfile->{mark} eq M_MARK) { 1198 # don't give feedback in cOmmand or Your 1199 if ($applyflags !~ /\bnofeedback\b/o) { 1200 $screen->at($screen->PATHLINE, 0)->clreol() 1201 ->puts($loopfile->{name})->at($screen->PATHLINE+1, 0); 1202 } 1203 $loopfile->apply($do_this, $applyflags, @args); 1204 # see if the file was lost, and we were deleting. 1205 # we could also test if return value of File->apply eq 'deleted' 1206 if (!$loopfile->{nlink} and 1207 $loopfile->{type} ne 'w' and 1208 $applyflags =~ /\bdelete\b/o) 1209 { 1210 $self->unregister($loopfile); 1211 $deleted_index = $nameindexmap{$loopfile->{name}}; 1212 splice @{$self->{_dircontents}}, $deleted_index, 1; 1213 $self->set_dirty(D_FILTER); 1214 } 1215 } 1216 # from perlfunc/system: 1217# if ($? == -1) { 1218# print "failed to execute: $!\n"; 1219# } 1220# elsif ($? & 127) { 1221# printf "child died with signal %d, %s coredump\n", 1222# ($? & 127), ($? & 128) ? 'with' : 'without'; 1223# } 1224 #last if $self->{_wasquit}; 1225 } 1226 $_pfm->state->{multiple_mode} = 0 if $self->{_config}{autoexitmultiple}; 1227 $self->checkrcsapplicable() if $self->{_config}{autorcs}; 1228 $screen->set_deferred_refresh(R_LISTING | R_PATHINFO | R_FRAME); 1229 } else { 1230 $loopfile = $event->{currentfile}; 1231 $loopfile->apply($do_this, $applyflags, @args); 1232 $self->checkrcsapplicable($loopfile->{name}) 1233 if $self->{_config}{autorcs}; 1234 # see if the file was lost, and we were deleting. 1235 # we could also test if return value of File->apply eq 'deleted' 1236 if (!$loopfile->{nlink} and 1237 $loopfile->{type} ne 'w' and 1238 $applyflags =~ /\bdelete\b/o) 1239 { 1240 $self->unregister($loopfile); 1241 $deleted_index = $self->dirlookup( 1242 $loopfile->{name}, @{$self->{_dircontents}}); 1243 splice @{$self->{_dircontents}}, $deleted_index, 1; 1244 $self->set_dirty(D_FILTER); 1245 } 1246 } 1247 return; 1248} 1249 1250########################################################################## 1251 1252=back 1253 1254=head1 CONSTANTS 1255 1256This package provides the B<D_*> constants which indicate 1257which aspects of the directory object need to be refreshed. 1258They can be imported with C<use App::PFM::Directory qw(:constants)>. 1259 1260=over 1261 1262=item D_FILTER 1263 1264The directory contents should be filtered again. 1265 1266=item D_SORT 1267 1268The directory contents should be sorted again. 1269 1270=item D_CONTENTS 1271 1272The directory contents should be updated from disk. 1273 1274=item D_FILELIST 1275 1276Convenience alias for a combination of all of the above. 1277 1278=item D_CHDIR 1279 1280The current directory was changed, therefore, filesystem usage 1281information should be updated from disk. 1282 1283=item D_ALL 1284 1285Convenience alias for a combination of all of the above. 1286 1287=back 1288 1289A refresh need for an aspect of the directory may be flagged by 1290providing one or more of these constants to set_dirty(), I<e.g.> 1291 1292 $directory->set_dirty(D_SORT); 1293 1294The actual refresh will be performed on calling: 1295 1296 $directory->refresh(); 1297 1298This will also reset the flags. 1299 1300In addition, this package provides the B<M_*> constants which 1301indicate which characters are to be used for mark, oldmark and newmark. 1302They can be imported with C<use App::PFM::Directory qw(:constants)>. 1303 1304=over 1305 1306=item M_MARK 1307 1308The character used for marked files. 1309 1310=item M_OLDMARK 1311 1312The character used for an oldmark (when a file has been operated on 1313in multiple mode). 1314 1315=item M_NEWMARK 1316 1317The character used for a newmark (when a file has newly been created 1318in multiple mode). 1319 1320=back 1321 1322=head1 SEE ALSO 1323 1324pfm(1). 1325 1326=cut 1327 13281; 1329 1330# vim: set tabstop=4 shiftwidth=4: 1331