view release on metacpan or  search on metacpan

Mpp/BuildCacheControl.pm  view on Meta::CPAN

      } @{$_[0]}[ATIME, MTIME, CTIME];
  } elsif( exists $_[4] ) {
    printf "%s
  ext-links: %d    sym-links: %d\n", $_[1], $_[0][EXTLINK], $_[4];
  } else {
    printf "%s
  ext-links: %d\n", $_[1], $_[0][EXTLINK];
  }
}

#
# This is a sort of recursive stat command, which takes into account that the
# owner of the cached file may have been changed, while the build info file
# retains the original owner.
#
sub c_show {
  local @ARGV = @_;
  my( $atime, $ctime, $deletable, $pattern, %user, $sep );
  my $time = time;
  my $sort;

  Mpp::Cmds::frame {
    warn "$0: ignoring --sort with --verbose\n" if defined $sort && $Mpp::verbose;
    for( $pattern ) {
      last unless defined;
      s/([?*])/.$1/g;
      s/\{/(?:/g and tr/,}/|)/;
      $_ = qr/_$_$/;
    }
    my @sort = split /[\s,]+/, defined $sort ? $sort : 'MEMBER,AGE';
    ARGVgroups {
      my( $grtitle, $grfmt, $grnone, $offset, @sortidxlen, %sort ) =
	@group > 1 ? ('C S ', '%d %d ', '- %d ', 4) :
	  ('', '', '', 0);
      my $timetype = $atime ? 'A' : $ctime ? 'C' : 'M';
      for my $key ( @sort ) {
	$key = uc $key;
	map {
	  if( $_->[0] eq $key ) {
	    push @sortidxlen, $_->[1], $_->[2];
	    next;
	  }
	} [MODE => 0, 4],
	  [EL => 5, 2],
	  [C => 8, 1],
	  [S => 10, 1],
	  [UID => 8 + $offset, 8],
	  ['BI-UID', 17 + $offset, 1],
	  [SIZE => 26 + $offset, 9],
	  ["${timetype}D" => 36 + $offset, 2],
	  [AGE => 39 + $offset, 17],
	  ["${timetype}DATE", 39 + $offset, 8],
	  ["${timetype}TIME", 48 + $offset, 8],
	  [MEMBER => -57 - $offset, -1];
      }
      $sep = "MODE EL ${grtitle}UID      BI-UID        SIZE ${timetype}D ${timetype}DATE    ${timetype}TIME    MEMBER\n"
	unless $Mpp::verbose;
      groupfind {
	return if $deletable && ($combined_lstat[EXTLINK] && defined $combined_lstat[BIUID])
	  or defined $pattern && !/$pattern/;
	$_ = defined() ? $user{$_} ||= getpwuid( $_ ) || $_ : '-'
	  for @combined_lstat[UID, BIUID];
	if( defined $sep ) {
	  print $sep;
	  undef $sep;
	}
	my @grinfo;
	if( @group > 1 ) {	# Count the copies and symlinks.
	  @grinfo = (0, 0);
	  for( @lstats ) {
	    $grinfo[ref() ? 0 : 1]++ if defined;
	  }
	}
	if( $Mpp::verbose ) {
	  showfull \@combined_lstat, $_[1], $time, @grinfo;
	  if( $Mpp::verbose > 1 ) { # Show each individual member.
	    for( my $i = 0; $i < @lstats; $i++ ) {
	      next unless defined $lstats[$i];
	      my $file = "$_[0][$i]/$_";
	      if( ref $lstats[$i] ) { # Normal file
		$_ = defined() ? $user{$_} ||= getpwuid( $_ ) || $_ : '-'
		  for @{$lstats[$i]}[UID, BIUID];
		showfull $lstats[$i], $file, $time;
	      } else {
		print "$file -> " . readlink( $file ) . "\n";
	      }
	    }
	    $sep = "\n";
	  }
	} else {
	  my $res;
	  if( defined $combined_lstat[MODE] ) { # A real file.
	    $res = sprintf "%04o %2d $grfmt%-8s %-8s %9d %s %s\n",
	      $combined_lstat[MODE] & 07777,
	      $combined_lstat[EXTLINK], @grinfo,
	      @combined_lstat[UID, BIUID, SIZE],
	      showtime $combined_lstat[$atime ? ATIME : $ctime ? CTIME : MTIME],
	      $_[1];
	  } else {		# Only stale symlink(s).
	    shift @grinfo;	# Doesn't have copies.
	    $res = sprintf "-    %2d $grnone-        -                - -  -        -        %s\n",
	      $combined_lstat[EXTLINK], @grinfo,
	      $_[1];
	  }
	  if( @sort ) {
	    my $key = '';
	    for( my $i = 0; $i < @sortidxlen; $i += 2 ) {
	      my( $idx, $len ) = @sortidxlen[$i, $i+1];
	      $idx = 1 + index $res, '_', $idx if $idx < 0; # Name starts after _
	      $key .= substr $res, $idx, $len;
	    }
	    if( exists $sort{$key} ) {
	      $sort{$key} .= $res;
	    } else {
	      $sort{$key} = $res;
	    }
	  } else {
	    print $res;
	  }
	}
      };
      if( @sort ) {
	print $sort{$_} for sort keys %sort;
      }
      $sep = "\f\n" if $Mpp::verbose;
    };
  } qw(f o O),
    ['a', qr/a(?:ccess[-_]?)?time/, \$atime],
    $blendopt,
    ['c', qr/c(?:hange[-_]?)?time/, \$ctime],
    [qw(d deletable), \$deletable],
    [qw(p pattern), \$pattern, 1],
    [qw(s sort), \$sort, 1];
}



sub cumul($\@\@) {
  my( $val, $asc, $desc ) = @_;
  my $last = @$val - 1;