File Coverage

lib/CLI/Dispatch/Help.pm

Criterion	Covered	Total	%
statement	277	277	100.0
branch	14	48	29.1
condition	2	17	11.7
subroutine	88	88	100.0
pod	9	9	100.0
total	390	439	88.8

package CLI::Dispatch::Help;

use strict;
use warnings;
use base qw( CLI::Dispatch::Command );
use Class::Unload;
use Class::Inspector;
use Encode;
use Pod::Simple::Text;
use Path::Tiny;
use String::CamelCase;
use Term::Encoding ();
use Try::Tiny;

my $term_encoding = eval {
  find_encoding(Term::Encoding::get_encoding())
} || 'utf8';


sub options {qw( from|decode=s to|encode=s )}

sub extra_namespaces {}

sub run {
  my ($self, @args) = @_;

  my $text;
  if ( @args ) {
    $text = $self->extract_pod( @args );
  }
  else {
    $text = $self->list_commands;
  }

  $self->output( $text );
}

sub output {
  my ($self, $text, $no_print) = @_;

  unless ( Encode::is_utf8( $text ) ) {
    $text = decode( $self->option('from') || 'utf8', $text )
  }
  $text = encode( $self->option('to') || $term_encoding, $text );

  print $text unless $no_print;

  return $text;
}

sub extract_pod {
  my ($self, $command) = @_;

  my $content = $self->_lookup( $command );

  unless ( $content ) {
    $self->logger(1) unless $self->logger;
    $self->log( warn => "$command is not found" );
    return $self->list_commands;
  }

  my $pod = $self->_parse_pod($content);

  return $self->extract_pod_body($pod);
}

sub extract_pod_body {
  my ($self, $pod) = @_;

  # remove the first ("NAME") section as the command does not
  # always belong to the same namespace as the dispatcher/script.
  # (default CLI::Dispatch namespace may be confusing for end users)
  $pod =~ s/^\S+\s+(.+?)\n(?=\S)//s;

  return $pod;
}

sub list_commands {
  my $self = shift;

  my @paths = map { s{::}{/}g; $_ } $self->_namespaces;

  my %found;
  my %classes;
  my $maxlength = 0;
  foreach my $inc ( @INC ) {
    foreach my $path ( @paths ) {
      my $dir = path( $inc, $path );
      next unless $dir->exists && $dir->is_dir;
      my $iter = $dir->iterator({recurse => 1});
      while (my $file = $iter->()) {
        next if $file->is_dir;

        my $basename = $file->basename;
           $basename =~ s/\.(?:pm|pod)$//;

        next if defined $found{$basename};

        (my $class = $path) =~ s{/}{::}g;
        $class .= '::'.$basename;
        $classes{$class} = 1;

        # ignore base class
        next if $class eq 'CLI::Dispatch::Command';

        my $podfile = $file->parent->child($basename . '.pod');
        my $pmfile  = $file->parent->child($basename . '.pm');

        # should always parse .pod file if it exists
        my $pod = $self->_parse_pod($podfile->exists ? $podfile->slurp : $file->slurp);

        $basename = $self->convert_command($basename);

        $found{$basename} ||= $self->extract_brief_description($pod, $class);

        # check availability
        if ( $pmfile->exists ) {
          my $loaded = Class::Inspector->loaded($class);
          Class::Unload->unload($class) if $loaded;
          my $error;
          try   { eval "require $class" or die }
          catch { $error = $_ || 'Obscure error' };
          if ($error) {
            if ($error =~ /^Can't locate /) {
              # most probably this is a subcommand of some command
              # (ie. in a wrong namespace)
              delete $found{$basename};
            }
            else {
              $found{$basename} .= " [disabled: compile error]";
            }
          }
          elsif ( $class->can('check') ) {
            try   { $class->check }
            catch {
              $error = $_ || 'Obscure error';
              $error =~ s/\s+at .+? line \d+\.?\s*$//;
              $found{$basename} .= " [disabled: $error]";
            };
          }
          Class::Unload->unload($class) unless $loaded;
        }

        my $len = length $basename;
        $maxlength = $len if $maxlength < $len;
      }
    }
  }

  my $text = '';
  my $format = "%-${maxlength}s - %s\n";
  foreach my $key ( sort keys %found ) {
    $text .= sprintf($format, $key, $found{$key});
  }
  return $text;
}

sub convert_command {
  my ($self, $command) = @_;
  String::CamelCase::decamelize( $command );
}

sub extract_brief_description {
  my ($self, $pod, $class) = @_;

  # "NAME" header may be localized
  my ($brief_desc) = $pod =~ /^\S+\s+$class\s+\-\s+(.+?)\n/s;

  return $brief_desc || '';
}

sub _parse_pod {
  my ($self, $file) = @_;

  my $parser = Pod::Simple::Text->new;
     $parser->output_string( \my $pod );
     $parser->parse_string_document("$file");

  return $pod;
}

sub _namespaces {
  my $self = shift;

  my %seen;
  return grep { !$seen{$_}++ } (
    $self->extra_namespaces,
    @{ $self->option('_namespaces') || [] },
    'CLI::Dispatch'
  );
}

sub _lookup {
  my ($self, $command) = @_;

  my @paths;
  if ($command =~ s/^\+//) {
    $command =~ s{::}{/}g;
    @paths = $command;
  }
  else {
    @paths = map { s{::}{/}g; "$_/$command" } $self->_namespaces;
  }

  foreach my $inc ( @INC ) {
    foreach my $path ( @paths ) {
      foreach my $ext (qw( pod pm )) {
        my $file = path( $inc, "$path.$ext" );
        return $file->slurp if $file->exists;
      }
    }
  }

  # probably it's embedded in the caller...
  my $ct = 0;
  my %seen;
  while (my @caller = caller($ct++)) {
    next if $caller[0] =~ /^CLI::Dispatch(::.+)?$/;
    next if $seen{$caller[0]}++;
    my $content = path($caller[1])->slurp;
    for my $path ( @paths ) {
      (my $package = $path) =~ s{/}{::}g;
      if ($content =~ /=head1\s+\S+\s+$package/s) { # hopefully NAME
        return $content;
      }
    }
  }

  return;
}

1;

__END__