1# $Id: BuildCacheControl.pm,v 1.30 2012/03/04 13:56:35 pfeiffer Exp $ 2 3=head1 NAME 4 5Mpp::BuildCacheControl - Externally usable management commands 6 7=cut 8 9package Mpp::BuildCacheControl; 10use strict; 11require Exporter; 12 13our @ISA = 'Exporter'; 14our @EXPORT = qw(c_clean c_create c_show c_stats); 15 16use Mpp::File; 17use Mpp::BuildCache; 18use Mpp::FileOpt; 19use Mpp::Cmds; 20use POSIX ':errno_h'; 21 22BEGIN { 23 (*DEV, undef, *MODE, *EXTLINK, *UID, *GID, *BIUID) = @Mpp::Text::N; 24 *SIZE = sub() { 7 }; 25 *ATIME = sub() { 8 }; 26 *MTIME = sub() { 9 }; 27 *CTIME = sub() { 10 }; 28 29 *Mpp::propagate_pending_signals = \&DEV unless defined &Mpp::propagate_pending_signals; 30 31 no warnings; 32 *ESTALE = \&Mpp::BuildCache::ESTALE; # Overridden on Win ActiveState. 33} 34 35=head2 group 'path/to/build_cache', ... 36 37Recursively collect all build caches which can be found in the GROUP attribute 38in the $Mpp::BuildCache::options_file of all the given directories. Actually the 39file may contain two hashes, only the last of which is read by 40Mpp::BuildCache::new. This function augments each object with values in the first 41of the two hashes, if available. After calling this function, these variables 42are set: 43 44=head3 @group 45 46This is set to a list of one or more Mpp::BuildCache objects. These have more 47attributes than the same objects in makepp: 48 49 .. The Mpp::File of the build cache directory. 50 xPREFERRED This is a preferred build cache iff this key exists. 51 52=head3 $preferred 53 54This is set to the number of preferred build caches in the group. These are 55sorted at the beginning of C<@group>. 56 57=head3 @unreachable (private) 58 59This contains the directory names of caches which should have been loaded by 60the above logic, but weren't, possibly because the disk or server is offline. 61 62=cut 63 64our @group; 65our $preferred = 0; 66my @unreachable; 67sub group(@) { 68 my %bc; 69 my @list = @_; 70 for( @list ) { 71 my $dinfo = file_info $_; 72 next if exists $bc{int $dinfo}; 73 $bc{int $dinfo} = $dinfo; 74 75 my $opt = "$_/$Mpp::BuildCache::options_file"; 76 unless( -r $opt ) { # Disk or NFS server might be down. 77 push @unreachable, $_ if $! == ENOENT || $! == ENOTDIR; 78 undef $bc{int $dinfo}; # Note it so we don't warn for it again. 79 warn "Can't read $opt--$!\n"; 80 next; 81 } 82# do() fails to return list on one instance of 5.6.1, hence alternative on next line: 83# my @tmp = do $opt or die $@ =~ / $opt / ? $@ : "$opt: $@"; 84 open my $fh, '<', $opt; local $/; my @tmp = eval <$fh> or die $@ =~ / $opt / ? $@ : "$opt: $@"; 85 $tmp[-1]{'..'} = $dinfo; # [0] for non grouped, [1] for grouped. 86 $dinfo->{BC} = new Mpp::BuildCache $_, $tmp[-1]; 87 88 if( @tmp > 1 ) { # Was already grouped 89 push @list, @{$tmp[0]{GROUP}} if exists $tmp[0]{GROUP}; 90 # Superset, in case GROUP got out of sync. 91 ++$preferred, undef $tmp[1]{xPREFERRED} if exists $tmp[0]{xPREFERRED}; 92 } 93 } 94 @group = sort { 95 (exists $b->{xPREFERRED} || 0) <=> (exists $a->{xPREFERRED} || 0) 96 or $a->{DIRNAME} cmp $b->{DIRNAME}; 97 } map defined() ? $_->{BC} : (), values %bc; 98 die "$0: no group members were readable\n" unless @group; 99} 100 101=head2 ARGVgroups { code } 102 103This calls C<group> for each element in C<@ARGV>, and calls I<code> for each 104group that wasn't already identified by an earlier element. 105 106=cut 107 108our $blend; 109my $blendopt = ['b', qr/blend(?:[-_]?groups?)?/, \$blend]; 110sub ARGVgroups(&) { 111 unless( @ARGV ) { 112 -f $Mpp::BuildCache::options_file 113 or die "$0: no build cache directories given and not in one\n"; 114 @ARGV = '.'; 115 } 116 if( $blend ) { 117 group @ARGV; 118 &{$_[0]}; 119 } else { 120 my %seen; 121 for( @ARGV ) { # Might specify more than one group. 122 group $_; 123 # TODO: warn if we have partially overlapping groups. 124 next if exists $seen{int $group[0]{'..'}}; # Already handled this group. 125 &{$_[0]}; 126 @seen{map int( $_->{'..'} ), @group} = (); # Remember we've treated these BCs. 127 } 128 } 129} 130 131=head2 groupfind { code } [$try] 132 133This function walks the virtual superposition of all caches in the group. 134Call I<code> only once for every cache entry, whether it is in one cache of 135the group or replicated to others. The first argument to code is an array of 136all the absolute path names in the different caches, virtually pointing to the 137same directory. The list is in the same order as C<@group>. The second arg 138is the path to the current file, relative to the cache root. 139 140C<group> must have been called for this to work, even if the "group" consists 141of only one build cache. The subdir we are currently inspecting relative to 142the build cache root is in C<$try>, and gets automatically added during the 143recursive descent. 144 145In addition to the parameters passed to I<code> there are some global 146variables: 147 148=head3 $_ 149 150This holds the name of the current file. Mapping the concatenation of this to 151the list of dirs gives the pathes to the replicates. 152 153=head3 @lstats 154 155This is a list of arrays containing the list returned by C<lstat>. The list 156is in the same order as C<@group>. For inexistent files this contains undef 157instead of an array. For symbolic links this contains ext-links, 158i.e. nlinks-1, the number of external links instead of an array. 159 160Two fields have non-standard meanings: 161 162 3 EXTLINK (nlink) Number of links to the file, not counting the one in the cache. 163 6 BIUID (rdev) The uid of the build info or undef if none. 164 165=head3 @combined_lstat 166 167This is the virtual lstat for the file, where the times are the maximum of all 168replicates' times. EXTLINK is the sum of all replicates' EXTLINK. 169 170=cut 171 172our( @lstats, @combined_lstat ); 173our $clean_empty; 174sub groupfind(&;$) { 175 my( $code, $try ) = @_; 176 my $top = 1 unless defined $try; 177 my( @dirs, @contents ); 178 @dirs = map $top ? $_->{DIRNAME} : "$_->{DIRNAME}/$try", @group; 179 for( @dirs ) { 180 if( opendir my( $dh ), $_ ) { 181 my %contents; 182 @contents{(readdir $dh)} = (); # Parens needed for list context to readdir. 183 delete @contents{qw(. ..), $Mpp::File::build_info_subdir}; 184 delete @contents{$Mpp::BuildCache::options_file, $Mpp::BuildCache::incoming_subdir} 185 if $top; 186 push @contents, \%contents; 187 } else { 188 push @contents, undef; 189 } 190 } 191 my %combined_contents; 192 @combined_contents{keys %$_} = () for @contents; # Merge all the individual contents. 193 # Merely make the keys exist. 194 FILE: for( keys %combined_contents ) { 195 @combined_lstat = @lstats = (); 196 $combined_lstat[EXTLINK] = 0; 197 for( my $i = 0; $i < @dirs; $i++ ) { # Look at all group members. 198 unless( exists $contents[$i]{$_} ) { # Not present in this cache. 199 push @lstats, undef; # Placeholder so we stay in sync with @group. 200 next; 201 } 202 unless( defined -l "$dirs[$i]/$_" ) { # What's wrong, concurrent clean? 203 my $msg = "$0: lstat $_: $!\n"; 204 if( $! == ENOENT || $! == ESTALE ) { 205 warn $msg; 206 next; 207 } 208 die $msg; 209 }; 210 if( -l _ ) { 211 push @lstats, (lstat _)[EXTLINK] - 1; 212 # nlink: Don't count cached symlink itself. 213 $combined_lstat[EXTLINK] += $lstats[-1]; 214 } elsif( -d _ ) { 215 &groupfind( $code, $top ? $_ : "$try/$_" ); # Ignore prototype for $code. 216 next FILE; # We just treated whole group recursively. 217 } else { # A plain file. 218 push @lstats, [lstat _]; 219 $combined_lstat[EXTLINK] += --$lstats[-1][EXTLINK]; 220 # nlink: Don't count cached file itself. 221 @combined_lstat[MODE, UID, SIZE] = @{$lstats[-1]}[MODE, UID, SIZE]; 222 !defined $combined_lstat[$_] || $combined_lstat[$_] < $lstats[-1][$_] 223 and $combined_lstat[$_] = $lstats[-1][$_] 224 for ATIME, MTIME, CTIME; # Max. 225 defined( $lstats[-1][BIUID] = # Redefine field from what lstat put there. 226 (lstat "$dirs[$i]/$Mpp::File::build_info_subdir/$_.mk")[UID] ) 227 and !-l _ # Real build_info file? 228 and $combined_lstat[BIUID] = $lstats[-1][BIUID]; 229 } 230 } 231 &$code( \@dirs, $top ? $_ : "$try/$_" ); 232 } 233 234 # This is only used by clean. Have to do it here, as callback is only for files: 235 if( $clean_empty ) { 236 DIR: for( map( "$_/$Mpp::File::build_info_subdir", @dirs ), @dirs ) { 237 opendir my( $dh ), $_ or next; 238 my $entry; 239 $entry =~ /^\.\.?$/ or next DIR while $entry = readdir $dh; 240 closedir $dh; 241 rmdir or warn "$0: can't delete `$_'--$!\n"; 242 } 243 } 244} 245 246 247sub c_clean { 248 local @ARGV = @_; 249 my( $min_atime, $atime, $max_atime, 250 $min_mtime, $mtime, $max_mtime, 251 $min_inc_mtime, $inc_mtime, $max_inc_mtime, 252 $min_ctime, $ctime, $max_ctime, 253 $min_size, $size, $max_size, 254 $bi_check, $link_check, $group, $user, $predicate, $weekbase); 255 my %unit = 256 (s => 1, 257 m => 60, 258 h => 60 * 60, 259 d => 24 * 60 * 60, 260 w => 7 * 24 * 60 * 60); 261 $unit{''} = $unit{d}; 262 my $time = time; 263 $inc_mtime = '+2h'; # default is 2 hours old or older. 264 265 my ($target_files_deleted, $build_info_files_deleted) = (0, 0); 266 267 Mpp::Cmds::frame { 268 if( $weekbase ) { 269 $weekbase = $unit{w}; # 7 days after epoch. 270 my( $min, $hour, $wday ) = (localtime $weekbase)[1, 2, 6]; 271 $weekbase -= --$wday * $unit{d} + $hour * $unit{h} + $min * $unit{m}; 272 # Count back to monday 0:00. 273 } 274 map { 275 if( defined $_->[1] ) { 276 %unit = 277 ('' => 1, 278 c => 1, 279 k => 2 ** 10, 280 M => 2 ** 20, 281 G => 2 ** 30) if $_->[3]; 282 # '+-1' is useful for testing. We rely on ([-+]?) being ungreedy here. 283 $_->[1] =~ /^([-+]?)(\d+(?:\.\d+)?|-1)([wdhmsckMG]?)/ or 284 die "$0: `$_->[1]' is not a valid specification\n"; 285 # We unlink the ones that are IN the range, so '+' (unlink older than) 286 # means to set the max, and '-' (unlink newer than) means to set the 287 # min (except that size is opposite). 288 if($_->[3]) { # size 289 if( $1 eq '-' ) { 290 ${$_->[2]} = $2 * $unit{$3}; # max 291 } else { 292 ${$_->[0]} = $2 * $unit{$3}; # min 293 ${$_->[2]} = ${$_->[2]} + $unit{$3} if !$1; # range 294 } 295 } else { # time 296 if( $1 eq '-' ) { 297 ${$_->[0]} = $time - $2 * $unit{$3}; # min 298 } else { 299 ${$_->[2]} = $time - $2 * $unit{$3}; # max 300 ${$_->[0]} = ${$_->[2]} - $unit{$3} if !$1; # range 301 } 302 if( defined $weekbase ) { 303 defined and 304 $_ -= (int( ($time - $weekbase) / $unit{w} ) - int( ($_ - $weekbase) / $unit{w} )) * 305 # Count both weeks since monday after the epoch. 306 2 * $unit{d} # Subtract number of weeks times 2 days. 307 for ${$_->[0]}, ${$_->[2]}; 308 } 309 } 310 } 311 } [\$min_atime, $atime, \$max_atime], 312 [\$min_mtime, $mtime, \$max_mtime], 313 [\$min_inc_mtime, $inc_mtime, \$max_inc_mtime], 314 [\$min_ctime, $ctime, \$max_ctime], 315 [\$min_size, $size, \$max_size, 1]; # NOTE: $size must be last! 316 $min_inc_mtime and die "$0: minimum incoming mtime not supported\n"; 317 318 # Traverse desired filesystems 319 local $clean_empty = 1; 320 local $Mpp::force_bc_copy = 1; 321 ARGVgroups { # Might specify more than one group. 322 # Special rule for incoming subdir: 323 for( @group ) { 324 my $inc = "$_->{DIRNAME}/$Mpp::BuildCache::incoming_subdir"; 325 opendir my( $dh ), $inc or next; 326 -e "$inc/$_" && !-d _ && (stat _)[MTIME] < $max_inc_mtime && unlink "$inc/$_" 327 for readdir $dh; 328 } 329 330 my $delete = sub { 331 my $file = $_[0]; # Copy, because perform { } has own @_. 332 eval { Mpp::Cmds::perform { unlink $file } "delete `$file'" }; 333 if( $Mpp::verbose ) { 334 if( $@ ) { warn $@ } 335 else { ++$target_files_deleted } 336 } 337 if( @_ == 1 || unlink $_[1] ) { 338 ++$build_info_files_deleted; 339 } elsif( $Mpp::verbose ) { 340 warn "unlink $_[1]--$!\n"; 341 } 342 }; 343 344 my $round_robin = 0; 345 groupfind { 346 if( $combined_lstat[EXTLINK] ) { # File has external links. 347 RETAIN: 348 my( $found_idx, $found, $found_build_info, $found_extlink ); 349 for( my $i = 0; $i < @group; $i++ ) { 350 next unless ref $lstats[$i]; # Look at all real group members. 351 my $build_info = "$_[0][$i]/$Mpp::File::build_info_subdir/$_.mk"; 352 undef $build_info unless -f $build_info; 353 my $file = "$_[0][$i]/$_"; 354 if( $build_info and $bi_check ? defined Mpp::File::load_build_info_file file_info $file : 1 ) { 355 if( defined $user && $user != $lstats[$i][UID] ) { 356 $lstats[$i][UID] = $user; 357 Mpp::Cmds::perform { chown $user, $lstats[$i][GID], $file } "set owner $user for `$file'"; 358 } 359 if( !defined $found_idx || $preferred && $i < $preferred && $found_extlink < $lstats[$i][EXTLINK] ) { 360 $found_idx = $i; 361 $found = $file; 362 $found_build_info = $build_info; 363 $found_extlink = $lstats[$i][EXTLINK]; 364 } 365 } elsif( $time - $lstats[$i][MTIME] > 600 ) { # Missing or corrupted build info (see Mpp::BuildCache::fix_ok). 366 &$delete( $file ); # load_build_info_file wiped build_info. 367 } 368 } 369 goto UNLINK unless $found; 370 if( $preferred && $found_idx >= $preferred ) { 371 # Found a file but not in a preferred BC. 372 for my $i ( $round_robin+1..$preferred-1, 0..$round_robin, undef ) { 373 return unless defined $i; # No free slot in any preferred BC. 374 unless( $lstats[$i] ) { # No file or symlink without ext links. 375 &$delete( "$_[0][$i]/$_", "$_[0][$i]/$Mpp::File::build_info_subdir/$_.mk" ) 376 if defined $lstats[$i]; # Symlink is in the way. 377 $round_robin = $i; 378 last; 379 } 380 } 381 if( $group[$round_robin]->cache_file( file_info( $found ), "$_[0][$round_robin]/$_", \(my $reason), $lstats[$found_idx][ATIME] )) { 382 # Succeeded in copying it, pretend it's the one we found. 383 $found = "$_[0][$round_robin]/$_"; 384 $found_build_info = "$_[0][$round_robin]/$Mpp::File::build_info_subdir/$_.mk"; 385 # Copy file attrs too: 386 chown @{$lstats[$found_idx]}[UID, GID], $found; 387 chown @{$lstats[$found_idx]}[BIUID, GID], $found_build_info; 388 @{$lstats[$round_robin] ||= []}[ATIME, MTIME, UID, GID, BIUID] = 389 @{$lstats[$found_idx]}[ATIME, MTIME, UID, GID, BIUID]; 390 $found_idx = $round_robin; 391 } 392 } 393 my $copied; 394 for( my $i = 0; $i < @group; $i++ ) { 395 next if $i == $found_idx; 396 my $build_info = "$_[0][$i]/$Mpp::File::build_info_subdir/$_.mk"; 397 if( $lstats[$i] ) { 398 next unless ref $lstats[$i] && !$lstats[$i][EXTLINK] && exists $group[$i]{SYMLINK}; 399 &$delete( "$_[0][$i]/$_", $build_info ); 400 } elsif( defined $lstats[$i] ) { # Symlink with no ext links. 401 next unless $link_check; 402 next if $found eq readlink "$_[0][$i]/$_" 403 && $found_build_info eq readlink $build_info; 404 &$delete( "$_[0][$i]/$_", $build_info ); 405 } elsif( lstat $build_info ) { # Build info without file 406 $time - (lstat _)[MTIME] > 600 and 407 unlink $build_info and 408 ++$build_info_files_deleted; 409 } 410 if( exists $group[$i]{SYMLINK} ) { 411 -d "$_[0][$i]/$Mpp::File::build_info_subdir" 412 || eval { Mpp::Cmds::c_mkdir( $group[$i]{MKDIR_OPT}, "$_[0][$i]/$Mpp::File::build_info_subdir" ) } 413 and symlink $found_build_info, $build_info 414 and symlink $found, "$_[0][$i]/$_"; 415 } elsif( $group[$i]->cache_file( file_info( $found ), "$_[0][$i]/$_", \(my $reason), $lstats[$found_idx][ATIME] )) { 416 $copied = 1; 417 # Copy owners too: 418 chown @{$lstats[$found_idx]}[UID, GID], "$_[0][$i]/$_"; 419 chown @{$lstats[$found_idx]}[BIUID, GID], $build_info; 420 } 421 } 422 utime @{$lstats[$found_idx]}[ATIME, MTIME], $found 423 if $copied; # Don't note cache_file as a read. 424 } else { # Clean only matching files not used elsewhere. 425 # There may still be copies though. 426 if( $predicate ) { 427 my $value = &$predicate; 428 goto UNLINK if $value; 429 goto RETAIN if defined $value; 430 } 431 432 map { # Test against deletion options. 433 goto RETAIN 434 if defined $_->[0] && $combined_lstat[$_->[1]] < $_->[0] 435 or defined $_->[2] && $_->[2] < $combined_lstat[$_->[1]]; # Found one that's out of bounds. 436 } [$min_atime, ATIME, $max_atime], 437 [$min_mtime, MTIME, $max_mtime], 438 [$min_ctime, CTIME, $max_ctime], 439 [$min_size, SIZE, $max_size] 440 if defined $combined_lstat[UID]; # Do we have a real file at all? 441 UNLINK: 442 for( my $i = 0; $i < @group; $i++ ) { 443 &$delete( "$_[0][$i]/$_", "$_[0][$i]/$Mpp::File::build_info_subdir/$_.mk" ) 444 if defined $lstats[$i]; # Look at all group members. 445 } 446 } 447 }; 448 }; 449 450 print "Deleted $target_files_deleted target files and $build_info_files_deleted build info files.\n" 451 if $Mpp::verbose; 452 } ['a', qr/a(?:ccess[-_]?)?time/, \$atime, 1], 453 $blendopt, 454 ['c', qr/c(?:hange[-_]?)?time/, \$ctime, 1], 455 ['g', qr/(?:new[-_]?)?gro?u?p/, \$group, 1, 456 sub { 457 defined( $group = getgrnam $group ) or die "$0: group unknown\n" if $group !~ /^\d+$/; 458 $( = $) = $group; 459 die "$0: newgrp $group failed--$!\n" if $!; 460 }], 461 ['i', qr/(?:build[-_]?)?info(?:[-_]?check)?/, \$bi_check], 462 ['l', qr/(?:sym(?:bolic)?[-_]?)?link(?:[-_]?check)?/, \$link_check], 463 ['m', qr/m(?:odification[-_]?)?time/, \$mtime, 1], 464 ['M', qr/in(?:coming)?[-_]?m(?:odification[-_]?)?time/, \$inc_mtime, 1], 465 ['p', qr/p(?:erl|redicate)/, \$predicate, 1, 466 sub { $predicate = Mpp::Cmds::eval_or_die( "sub { $predicate }" ) }], 467 [qw(s size), \$size, 1], 468 ['u', qr/(?:set[-_]?)?user/, \$user, 1, 469 sub { defined( $user = getpwnam $user ) or die "$0: user unknown\n" if $user !~ /^\d+$/ }], 470 [qw(w workdays), \$weekbase]; 471} 472 473 474# 475# Create the build cache for the first time. 476# 477sub c_create { 478 local @ARGV = @_; 479 my( $extend, $force, $mode, $preferred, $subdir_chars ); 480 Mpp::Cmds::frame { 481 @ARGV or die "$0: no build cache directories given\n"; 482 483 if( defined $mode ) { 484 $mode =~ /^[0-7]+$/ or die "$0: mode `$mode' is not octal\n"; 485 substr $mode, 0, 0, 'm'; # &mkdir -p gets prepended below 486 } else { 487 $mode = ''; 488 } 489 my $group_subdir_chars; 490 if( defined $extend ) { 491 group $extend; 492 for( @group ) { 493 if( defined $group_subdir_chars ) { 494 $group_subdir_chars eq join ',', @{$_->{SUBDIR_CHARS}} or 495 die "$0: error: `$group[0]{DIRNAME}' and `$_->{DIRNAME}' have different --subdir-chars\n"; 496 } else { 497 $group_subdir_chars = join ',', @{$_->{SUBDIR_CHARS}}; 498 } 499 } 500 } 501 if( defined $subdir_chars ) { 502 $subdir_chars =~ tr/ \t//d; 503 defined $group_subdir_chars and $group_subdir_chars ne $subdir_chars and 504 die "$0: error: `$group[0]{DIRNAME}' has different --subdir-chars=$group_subdir_chars\n"; 505 506 my $last_len = 0; # Do some quick validation: 507 for( split ',', $subdir_chars ) { 508 /^\d+$/ or 509 die "$0: error: specify a list of numbers to --subdir-chars\n"; 510 $_ > $last_len or 511 die "$0: error: parameters to --subdir-chars must be in increasing order\n"; 512 $last_len = $_; 513 } 514 } else { 515 $subdir_chars = $extend ? $group_subdir_chars : '2,4'; 516 # Fall back to the default directory configuration. 517 } 518 519 for( @ARGV ) { 520 if( -l or -e _ ) { 521 die "$0: error: `$_' already exists\n" unless $force; 522 unlink or die "$0: error: can't remove `$_'--$!\n" 523 unless -d; 524 } 525 if( $extend || @ARGV > 1 ) { 526 $_ = { DIRNAME => $_, '..' => file_info $_ }; 527 undef $_->{xPREFERRED} if $preferred; 528 } else { 529 $_ = { DIRNAME => $_ }; 530 } 531 } 532 Mpp::Cmds::c_mkdir '-p' . $mode, map "$_->{DIRNAME}/$Mpp::BuildCache::incoming_subdir", @ARGV; 533 push @ARGV, @group if $extend; 534 for( @ARGV ) { 535 my $str; 536 if( @ARGV > 1 ) { 537 my $self = $_->{'..'}; 538 $str .= "no warnings 'void'; # Scalar context skips next line.\n{ GROUP => [qw(" . 539 (Mpp::Subs::f_sort # f_sort eliminates dups, which come from re-adding a lost group member. 540 join ' ', @unreachable, map { $_->{'..'} == $self ? () : absolute_filename $_->{'..'} } @ARGV ) . 541 ')]'; 542 $str .= ', xPREFERRED => undef' if exists $_->{xPREFERRED}; 543 $str .= " },\n{ "; 544 } else { 545 $str = '{ '; 546 } 547 $str .= "SUBDIR_CHARS => [$subdir_chars]"; 548 if( @ARGV > 1 ) { 549 my( $y, $z ) = ("$_->{DIRNAME}/.y", "$_->{DIRNAME}/.z"); 550 # Prepend '.' which doesn't occur in bc keys, in 551 # case we are forcing creation of an existing cache. 552 my $symlink = eval { symlink 'x', $y }; 553 $symlink &&= link $y, $z; # Can we link to a stale symlink? Stale, as some systems 554 # link to the linked file, which only works on same fs. 555 unlink $y, $z; 556 $str .= ', SYMLINK => undef' if $symlink; 557 } 558 Mpp::Cmds::c_echo "$str }", -o => "$_->{DIRNAME}/$Mpp::BuildCache::options_file"; 559 } 560 } ['e', qr/extend(?:[-_]?group)?/, \$extend, 1], 561 [qw(f force), \$force], 562 ['m', qr/mode|access[-_]?permisssions/, \$mode, 1], 563 [qw(p preferred), \$preferred], 564 ['s', qr/subdir[-_]?chars/, \$subdir_chars, 1]; 565} 566 567 568sub showtime($) { 569 my @time = localtime $_[0]; 570 sprintf "%s %02d-%02d-%02d %02d:%02d:%02d", 571 qw(Su Mo Tu We Th Fr Sa)[$time[6]], 572 $time[5] % 100, 573 $time[4] + 1, 574 @time[3, 2, 1, 0]; 575} 576 577sub showfull($$$@) { 578 if( defined $_[0][MODE] ) { 579 my $grfmt = exists $_[4] ? " copies: %d sym-links: %d\n" : ''; 580 printf "%s 581 mode: %04o ext-links: %d $grfmt uid: %s bi-uid: %s size: %d 582 atime: %s 583 mtime: %s 584 ctime: %s\n", $_[1], 585 $_[0][MODE] & 07777, 586 $_[0][EXTLINK], 587 exists $_[4] ? @_[3, 4] : (), 588 @{$_[0]}[UID, BIUID, SIZE], 589 map { 590 my $res = showtime( $_ ) . ' ('; 591 $_ = $_[2] - $_; 592 $res . int( $_ / (24 * 60 * 60) ) . 'd or ' . 593 int( $_ / (60 * 60) ) . 'h or ' . 594 int( $_ / 60 ) . 'm)'; 595 } @{$_[0]}[ATIME, MTIME, CTIME]; 596 } elsif( exists $_[4] ) { 597 printf "%s 598 ext-links: %d sym-links: %d\n", $_[1], $_[0][EXTLINK], $_[4]; 599 } else { 600 printf "%s 601 ext-links: %d\n", $_[1], $_[0][EXTLINK]; 602 } 603} 604 605# 606# This is a sort of recursive stat command, which takes into account that the 607# owner of the cached file may have been changed, while the build info file 608# retains the original owner. 609# 610sub c_show { 611 local @ARGV = @_; 612 my( $atime, $ctime, $deletable, $pattern, %user, $sep ); 613 my $time = time; 614 my $sort; 615 616 Mpp::Cmds::frame { 617 warn "$0: ignoring --sort with --verbose\n" if defined $sort && $Mpp::verbose; 618 for( $pattern ) { 619 last unless defined; 620 s/([?*])/.$1/g; 621 s/\{/(?:/g and tr/,}/|)/; 622 $_ = qr/_$_$/; 623 } 624 my @sort = split /[\s,]+/, defined $sort ? $sort : 'MEMBER,AGE'; 625 ARGVgroups { 626 my( $grtitle, $grfmt, $grnone, $offset, @sortidxlen, %sort ) = 627 @group > 1 ? ('C S ', '%d %d ', '- %d ', 4) : 628 ('', '', '', 0); 629 my $timetype = $atime ? 'A' : $ctime ? 'C' : 'M'; 630 for my $key ( @sort ) { 631 $key = uc $key; 632 map { 633 if( $_->[0] eq $key ) { 634 push @sortidxlen, $_->[1], $_->[2]; 635 next; 636 } 637 } [MODE => 0, 4], 638 [EL => 5, 2], 639 [C => 8, 1], 640 [S => 10, 1], 641 [UID => 8 + $offset, 8], 642 ['BI-UID', 17 + $offset, 1], 643 [SIZE => 26 + $offset, 9], 644 ["${timetype}D" => 36 + $offset, 2], 645 [AGE => 39 + $offset, 17], 646 ["${timetype}DATE", 39 + $offset, 8], 647 ["${timetype}TIME", 48 + $offset, 8], 648 [MEMBER => -57 - $offset, -1]; 649 } 650 $sep = "MODE EL ${grtitle}UID BI-UID SIZE ${timetype}D ${timetype}DATE ${timetype}TIME MEMBER\n" 651 unless $Mpp::verbose; 652 groupfind { 653 return if $deletable && ($combined_lstat[EXTLINK] && defined $combined_lstat[BIUID]) 654 or defined $pattern && !/$pattern/; 655 $_ = defined() ? $user{$_} ||= getpwuid( $_ ) || $_ : '-' 656 for @combined_lstat[UID, BIUID]; 657 if( defined $sep ) { 658 print $sep; 659 undef $sep; 660 } 661 my @grinfo; 662 if( @group > 1 ) { # Count the copies and symlinks. 663 @grinfo = (0, 0); 664 for( @lstats ) { 665 $grinfo[ref() ? 0 : 1]++ if defined; 666 } 667 } 668 if( $Mpp::verbose ) { 669 showfull \@combined_lstat, $_[1], $time, @grinfo; 670 if( $Mpp::verbose > 1 ) { # Show each individual member. 671 for( my $i = 0; $i < @lstats; $i++ ) { 672 next unless defined $lstats[$i]; 673 my $file = "$_[0][$i]/$_"; 674 if( ref $lstats[$i] ) { # Normal file 675 $_ = defined() ? $user{$_} ||= getpwuid( $_ ) || $_ : '-' 676 for @{$lstats[$i]}[UID, BIUID]; 677 showfull $lstats[$i], $file, $time; 678 } else { 679 print "$file -> " . readlink( $file ) . "\n"; 680 } 681 } 682 $sep = "\n"; 683 } 684 } else { 685 my $res; 686 if( defined $combined_lstat[MODE] ) { # A real file. 687 $res = sprintf "%04o %2d $grfmt%-8s %-8s %9d %s %s\n", 688 $combined_lstat[MODE] & 07777, 689 $combined_lstat[EXTLINK], @grinfo, 690 @combined_lstat[UID, BIUID, SIZE], 691 showtime $combined_lstat[$atime ? ATIME : $ctime ? CTIME : MTIME], 692 $_[1]; 693 } else { # Only stale symlink(s). 694 shift @grinfo; # Doesn't have copies. 695 $res = sprintf "- %2d $grnone- - - - - - %s\n", 696 $combined_lstat[EXTLINK], @grinfo, 697 $_[1]; 698 } 699 if( @sort ) { 700 my $key = ''; 701 for( my $i = 0; $i < @sortidxlen; $i += 2 ) { 702 my( $idx, $len ) = @sortidxlen[$i, $i+1]; 703 $idx = 1 + index $res, '_', $idx if $idx < 0; # Name starts after _ 704 $key .= substr $res, $idx, $len; 705 } 706 if( exists $sort{$key} ) { 707 $sort{$key} .= $res; 708 } else { 709 $sort{$key} = $res; 710 } 711 } else { 712 print $res; 713 } 714 } 715 }; 716 if( @sort ) { 717 print $sort{$_} for sort keys %sort; 718 } 719 $sep = "\f\n" if $Mpp::verbose; 720 }; 721 } 'f', qw(o O), # fails in 5.6: qw(f o O); 722 ['a', qr/a(?:ccess[-_]?)?time/, \$atime], 723 $blendopt, 724 ['c', qr/c(?:hange[-_]?)?time/, \$ctime], 725 [qw(d deletable), \$deletable], 726 [qw(p pattern), \$pattern, 1], 727 [qw(s sort), \$sort, 1]; 728} 729 730 731 732sub cumul($\@\@) { 733 my( $val, $asc, $desc ) = @_; 734 my $last = @$val - 1; 735 736 for my $i ( 0..$last ) { 737 if( $i ) { 738 $asc->[$i] = $asc->[$i - 1] + ($val->[$i] ||= 0); 739 $desc->[$last - $i] = $desc->[$last - $i + 1] + ($val->[$last - $i] ||= 0); 740 } else { 741 $asc->[0] = $val->[0] ||= 0; 742 $desc->[$last] = $val->[$last] ||= 0; 743 } 744 } 745} 746my $sep = ''; 747sub display($$$;$) { 748 my( $size, $files, $title, $idx ) = @_; 749 return unless @$size; 750 my $last = @$size - 1; 751 my( @size_asc, @size_desc, @files_asc, @files_desc ); 752 cumul $size, @size_asc, @size_desc; 753 cumul $files, @files_asc, @files_desc; 754 755 my $name_len = $idx ? length $idx->[$last] : 1 + int log( $last ) / log 10; 756 $name_len = length $title->[0] if $name_len < length $title->[0]; 757 758 my $size_len = 1 + int log( $size_asc[$last] ) / log 10; 759 $size_len = length $title->[-2] if $size_len < length $title->[-2]; 760 $size_len = length 'CUMUL' if $size_len < length 'CUMUL'; 761 my $size_fmt = "%${size_len}s %%"; 762 763 my $files_len = 1 + int log( $files_asc[$last] ) / log 10; 764 $files_len = length $title->[-1] if $files_len < length $title->[-1]; 765 $files_len = length 'CUMUL' if $files_len < length 'CUMUL'; 766 my $files_fmt = "%${files_len}s %%"; 767 768 printf "$sep%${name_len}s | $size_fmt $size_fmt $size_fmt | $files_fmt $files_fmt $files_fmt\n", 769 @{$title}[0..@$title-2], qw(CUMUL CUMUL), $title->[-1], qw(CUMUL CUMUL); 770 771 $size_fmt = "%$size_len.0f %6.2f"; 772 $files_fmt = "%$files_len.0f %6.2f"; 773 my $fmt = "%${name_len}s | $size_fmt $size_fmt $size_fmt | $files_fmt $files_fmt $files_fmt\n"; 774 for my $i ( 0..$last ) { 775 printf $fmt, 776 $idx ? $idx->[$i] : $i, 777 778 $size->[$i], 100 * $size->[$i] / $size_asc[$last], 779 $size_asc[$i], 100 * $size_asc[$i] / $size_asc[$last], 780 $size_desc[$i], 100 * $size_desc[$i] / $size_asc[$last], 781 782 $files->[$i], 100 * $files->[$i] / $files_asc[$last], 783 $files_asc[$i], 100 * $files_asc[$i] / $files_asc[$last], 784 $files_desc[$i], 100 * $files_desc[$i] / $files_asc[$last] 785 if $size->[$i]; 786 } 787 $sep = "\n"; 788} 789 790sub c_stats { 791 my( $hours, $pattern ); 792 my $time = time; 793 Mpp::Cmds::frame { 794 for( $pattern ) { 795 last unless defined; 796 s/([?*])/.$1/g; 797 s/\{/(?:/g and tr/,}/|)/; 798 $_ = qr/_$_$/; 799 } 800 ARGVgroups { # Might specify more than one group. 801 my( @atime_size, @atime_count, @ctime_size, @ctime_count, @mtime_size, @mtime_count, 802 @el_size, @el_count, %cs_size, %cs_count ); 803 groupfind { 804 return if defined $pattern && !/$pattern/; 805 no warnings 'uninitialized'; 806 807 # Count and sum by atime hours. 808 my $hour = $time - $combined_lstat[ATIME]; 809 $hour = $hour < 0 ? 0 : int $hour / 3600 / ($hours ? 1 : 24); 810 $atime_size[$hour] += $combined_lstat[SIZE]; 811 $atime_count[$hour]++; 812 813 # Count and sum by ctime hours. 814 $hour = $time - $combined_lstat[CTIME]; 815 $hour = $hour < 0 ? 0 : int $hour / 3600 / ($hours ? 1 : 24); 816 $ctime_size[$hour] += $combined_lstat[SIZE]; 817 $ctime_count[$hour]++; 818 819 # Count and sum by mtime hours. 820 $hour = $time - $combined_lstat[MTIME]; 821 $hour = $hour < 0 ? 0 : int $hour / 3600 / ($hours ? 1 : 24); 822 $mtime_size[$hour] += $combined_lstat[SIZE]; 823 $mtime_count[$hour]++; 824 825 # Count and sum by external links. 826 $el_size[$combined_lstat[EXTLINK]] += $combined_lstat[SIZE]; 827 $el_count[$combined_lstat[EXTLINK]]++; 828 829 if( @group > 1 ) { 830 # Count and sum by combination of number of copies and symlinks. 831 my( $copies, $symlinks ) = (0, 0); 832 defined and ref() ? $copies++ : $symlinks++ for @lstats; 833 $copies .= ":$symlinks"; 834 $cs_size{$copies} += $combined_lstat[SIZE]; 835 $cs_count{$copies}++; 836 } 837 }; 838 839 # Display by timestamps. 840 display \@atime_size, \@atime_count, [$hours ? 'AH' : 'AD', qw(SIZE FILES)]; 841 display \@ctime_size, \@ctime_count, [$hours ? 'CH' : 'CD', qw(SIZE FILES)]; 842 display \@mtime_size, \@mtime_count, [$hours ? 'MH' : 'MD', qw(SIZE FILES)]; 843 844 # Display by external links. 845 display \@el_size, \@el_count, [qw(EL SIZE FILES)]; 846 undef $el_size[0]; 847 undef $el_count[0]; 848 for( my $i = 1; $i < @el_size; $i++ ) { 849 next unless defined $el_size[$i]; 850 $el_size[$i] *= $i; 851 $el_count[$i] *= $i; 852 } 853 display \@el_size, \@el_count, [qw(EL *SIZE *FILES)]; 854 855 # Display by combination of number of copies and symlinks. 856 my @cs_keys = sort keys %cs_size; 857 display [@cs_size{@cs_keys}], [@cs_count{@cs_keys}], [qw(C:S SIZE FILES)], \@cs_keys; 858 } 859 } [qw(h hours), \$hours], 860 [qw(p pattern), \$pattern, 1]; 861} 862 863 864package Mpp; # DATA shall be in this package for help. 865 866$0 = 'makepp_build_cache_control'; 867 868no warnings 'redefine'; 869 870sub helpfoot { die <<'EOF' } 871 872Look at @htmldir@/makepp_build_cache.html for more details, 873or at http://makepp.sourceforge.net/@BASEVERSION@/makepp_build_cache.html 874or type "man makepp_build_cache". 875EOF 876 8771; 878 879__DATA__ 880command [option ...] directory ... 881 mppbcc command [option ...] directory ... 882 makeppbuiltin -MMpp::BuildCacheControl command [option ...] directory ... 883 mppb -MMpp::BuildCacheControl command [option ...] directory ... 884 available commands: clean, create, show, stats 885 to see options do: makepp_build_cache_control command --help 886