view release on metacpan or  search on metacpan

lib/App/karr/Cmd/Dashboard.pm  view on Meta::CPAN

our $VERSION = '0.600';
use Moo;
use MooX::Cmd;
use MooX::Options (
  usage_string => 'USAGE: karr dashboard [PATH] [--depth N] [--hide-no-board] [--show-no-board] [--json] [--compact]',
);
use Path::Tiny ();
use Term::ANSIColor qw( colored );
use App::karr::Git;
use App::karr::BoardStore;
use App::karr::Role::CliArgs;
use App::karr::Role::ExitCodes;
use App::karr::Role::Output;
use App::karr::Role::CompactOutput;

# Board-less on purpose (ticket #220): this walks a directory tree for
# repositories and opens each board directly through App::karr::Git /
# App::karr::BoardStore, the way App::karr::Foundation/_is_karr_board_root
# does. It composes neither App::karr::Role::BoardDiscovery nor
# App::karr::Role::BoardAccess -- there is no single board to discover here,
# and no --dir either: the positional PATH below already names the search
# root, and a second option with an unrelated meaning would only confuse.
# _reject_root_dir in execute() is what makes that decision hold for the root
# placement as well (#225); without it the option was accepted there and
# silently dropped.
with 'App::karr::Role::CliArgs', 'App::karr::Role::ExitCodes',
     'App::karr::Role::Output', 'App::karr::Role::CompactOutput';


option depth => (
  is      => 'ro',
  format  => 'i',
  default => sub { 4 },
  doc     => 'Maximum recursion depth below PATH (default 4)',
);

option hide_no_board => (
  is  => 'ro',
  doc => 'Hide the summarized list of repositories with no karr board',
);

option show_no_board => (
  is  => 'ro',
  doc => 'Always list the board-less repositories by name, wrapped over several lines',
);

# Same status -> colour mapping App::karr::Cmd::Board uses (see its own
# comment there): the same status must not look different between the two
# commands of this one distribution.
my %STATUS_COLOR = (
  backlog       => 'bright_black',
  todo          => 'cyan',
  'in-progress' => 'yellow',
  review        => 'magenta',
  done          => 'green',
  archived      => 'bright_black',
);

# Decision (documented on ticket #220, karr edit 220 -a "..."): blocked cards
# are pulled out of their status colour into their own trailing bar segment,
# always bold red -- the same colour App::karr::Cmd::Board uses for
# `blocked:reason` -- so a blocked card reads as blocked at a glance instead
# of disappearing into whichever status colour it happened to be sitting in.
use constant BLOCKED_COLOR => 'bold red';

# One block character per (unscaled) open task. Decision: capped at 10 blocks
# per bar (see _scale_segments) so a busy board's entry stays short enough for
# several columns to fit side by side at an ordinary 80-column terminal --
# the whole point of "mehrspaltig" being multiple repos per screen row, not
# one very wide repo taking the row on its own.
use constant BLOCK_CHAR      => "\x{2588}";
use constant MAX_BAR_BLOCKS  => 10;
use constant COLUMN_GAP      => 2;

sub execute {
  my ($self, $args_ref, $chain_ref) = @_;

  $self->_reject_root_dir($chain_ref);
  $self->check_positional_args($args_ref, 1);
  my ($pos) = $self->positional_args($args_ref);

  $self->usage_error( sprintf '--depth must be 0 or greater (got %d)', $self->depth )
    if $self->depth < 0;

  my $start = Path::Tiny::path( defined $pos ? $pos : '.' )->absolute;
  $self->usage_error("not a directory: $start") unless $start->is_dir;

  my @repo_dirs = sort { "$a" cmp "$b" } $self->_find_repos( $start, $self->depth );

  my ( @boards, @no_board );
  for my $dir (@repo_dirs) {
    my $info = $self->_probe_repo($dir);
    if ($info) { push @boards, $info }
    else       { push @no_board, $dir }
  }
  @boards = sort { $a->{name} cmp $b->{name} || "$a->{dir}" cmp "$b->{dir}" } @boards;

  my $total_open = 0;
  $total_open += $_->{open} for @boards;

  if ( $self->json ) {
    my %doc = (
      root    => "$start",
      summary => {
        repos => scalar(@repo_dirs),
        boards => scalar(@boards),
        open   => $total_open,
      },
      boards => [
        map {
          my $b = $_;
          +{
            path       => "$b->{dir}",
            name       => $b->{name},
            board_name => $b->{board_name},
            open       => $b->{open},
            blocked    => $b->{blocked},
            # Named $status, not $_: this is a map nested inside the outer
            # one, and reusing $_ here would shadow $b's own $_ alias with
            # the status name, breaking $b->{counts}{$_} silently.
            statuses => { map { my $status = $_; ( $status => $b->{counts}{$status} // 0 ) } @{ $b->{order} } },
          }
        } @boards
      ],
      ( $self->hide_no_board ? () : ( no_board => [ map { "$_" } @no_board ] ) ),
    );
    $self->print_json( \%doc );
    return;
  }

  if ( $self->compact ) {
    for my $b (@boards) {
      my @tokens = map { "$_:" . ( $b->{counts}{$_} // 0 ) } @{ $b->{order} };
      push @tokens, 'blocked:' . $b->{blocked};
      printf "%s\t%s\n", $b->{name}, join( ',', @tokens );
    }
    unless ( $self->hide_no_board ) {
      printf "%s\tno-board\n", $_->basename for @no_board;
    }
    return;
  }

  my $color = -t STDOUT && !$ENV{NO_COLOR};
  my $c = sub {
    my ( $text, $spec ) = @_;
    return $color ? colored( $text, $spec ) : $text;
  };

  # Every line printed below is fitted to this one width. Nothing may exceed
  # it: a line that is one character too long soft-wraps in the terminal, and
  # a soft-wrapped grid row destroys the column alignment this command exists
  # for -- worse than a plain one-column list would have been.
  my $width = $self->_term_width;

  print $c->( $self->_truncate( "Dashboard: $start", $width ), 'bold cyan' ), "\n\n";

  if (@boards) {
    my $name_width = 0;
    $name_width = length( $_->{name} ) > $name_width ? length( $_->{name} ) : $name_width
      for @boards;

    # The count column is the only other variable-width part; measure it so
    # the name cap below is exact rather than guessed.
    my $count_w = 0;
    for my $b (@boards) {
      my $l = length( '(' . $b->{open} . ')' );
      $count_w = $l if $l > $count_w;
    }

    # A cell is name + 2 spaces + bar + 1 space + count. On a terminal too
    # narrow to hold even one whole cell the grid falls back to a single
    # column, and a single column cannot shrink below its own content -- so
    # the content itself has to shrink. Names are capped first (they are the
    # only unbounded part), then the bar, so both stay inside $width. At any
    # ordinary width neither cap is reached and nothing is truncated.
    my $name_cap = $width - 3 - MAX_BAR_BLOCKS - $count_w;
    $name_cap = 4 if $name_cap < 4;
    $name_width = $name_cap if $name_width > $name_cap;

    my $bar_max = $width - $name_width - 3 - $count_w;
    $bar_max = 1 if $bar_max < 1;
    $bar_max = MAX_BAR_BLOCKS if $bar_max > MAX_BAR_BLOCKS;

    my @cells = map { $self->_entry_for_board( $_, $name_width, $bar_max, $c ) } @boards;
    print $self->_render_grid( \@cells, $width );
  }
  else {
    print $c->( '(no boards found)', 'bright_black' ), "\n";
  }

  # The board-less repositories are a footnote, and on a big tree there are
  # more of them than boards (46 of 91 under one real /home/getty/dev scan).
  # Joined into one line that was 837 characters -- seven soft-wrapped
  # terminal lines that buried the summary underneath them. Three cases now:
  # it fits on one line, or --show-no-board wraps it properly, or it collapses
  # to a count that says how to see the names.
  unless ( $self->hide_no_board || !@no_board ) {
    my @names = map { $_->basename } @no_board;
    my $one_line = 'No board: ' . join( ', ', @names );
    print "\n";
    if ( length($one_line) <= $width ) {
      print $c->( $one_line, 'bright_black' ), "\n";
    }
    elsif ( $self->show_no_board ) {
      print $c->( $_, 'bright_black' ), "\n"
        for $self->_wrap_items( 'No board: ', \@names, $width, 10 );
    }
    else {
      # The hint is worth a line only while it fits beside the count; on a
      # narrow terminal the count alone is what survives.
      my $hint  = sprintf( 'No board: %d repos (--show-no-board to list them)', scalar @names );
      my $short = sprintf( 'No board: %d repos',                                scalar @names );
      $hint = $short if length($hint) > $width;
      print $c->( $self->_truncate( $hint, $width ), 'bright_black' ), "\n";
    }
  }

  print "\n", $c->(
    $self->_truncate(
      sprintf( '%d repos  %d boards  %d open', scalar(@repo_dirs), scalar(@boards), $total_open ),
      $width ),
    'bold'
  ), "\n";
}

# `karr dashboard --dir PATH` was always rejected by MooX::Options (this
# command declares no such option) -- but `karr --dir PATH dashboard` was not:
# --dir is declared on App::karr::Role::BoardDiscovery, the root command
# composes it via BoardAccess, and MooX::Cmd leaves the parsed value on the
# root instance in the command chain, where nothing here ever looked. So the
# option was swallowed without a word and the scan ran on the current
# directory instead -- and a list of repositories with counts behind them
# looks like a valid answer no matter which tree it came from (#225).
#
# It is refused rather than adopted because the two paths are not the same
# path: --dir seeds a walk UPWARD to one repository's root
# (App::karr::Role::BoardDiscovery/_build_git_root, which is why it may name
# any directory inside the target repository), while the positional PATH here
# is the root of a walk DOWNWARD across a tree of repositories (_find_repos,
# bounded by --depth, never entering a repository's own work tree). Handed the
# same argument, the two would answer about different directories.
#
# The root is read from $chain_ref the way App::karr::Cmd::GetRefs reads it
# for the opposite purpose; a directly constructed instance (no MooX::Cmd
# dispatch, hence an empty chain) has no root option to reject.
sub _reject_root_dir {
  my ($self, $chain_ref) = @_;
  return unless $chain_ref && @$chain_ref;
  my $root = $chain_ref->[0];
  return unless $root && $root->can('has_dir') && $root->has_dir;
  # Wrapped to stay inside 80 columns with usage_error's own "Usage error: "
  # prefix on the first line: what to type comes first, the reason after it.
  $self->usage_error(
      "dashboard does not take --dir; its scan root is an argument:\n"
    . "karr dashboard PATH\n"
    . "(--dir seeds the search upward for one repository's board, while dashboard\n"
    . "searches downward for every board under a directory.)"
  );
}

# ---------------------------------------------------------------------------
# Discovery
# ---------------------------------------------------------------------------

# Iterative (not recursive) so a very deep or wide tree cannot blow the Perl
# call stack; order within a directory is irrelevant to the caller, which
# sorts the whole result afterwards.
sub _find_repos {
  my ( $self, $start, $max_depth ) = @_;
  my @found;
  my @stack = ( [ $start, 0 ] );

  while (@stack) {
    my ( $dir, $depth ) = @{ shift @stack };

    if ( $dir->child('.git')->exists ) {
      push @found, $dir;
      next;    # never search inside a repository's own working tree
    }
    next if $depth >= $max_depth;

    my @children = eval { grep { $_->is_dir } $dir->children };