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::Extended;
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 $maxlength = 0;
  foreach my $inc ( @INC ) {
    foreach my $path ( @paths ) {
      my $dir = dir( $inc, $path );
      next unless $dir->exists;
      $dir->recurse( callback => sub {
        my $file = shift;
        return if $file->is_dir;

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

        return if defined $found{$basename};

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

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

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

        # should always parse .pod file if it exists
        my $pod = $self->_parse_pod(scalar ($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) {
            $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 = file( $inc, "$path.$ext" );
        return scalar $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 = scalar file($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__

=head1 NAME

CLI::Dispatch::Help - show help

=head1 SYNOPSIS

  to list available commands:

    > perl your_script.pl

  to show help of a specific command:

    > perl your_script.pl help command

  you may want to encode/decode the text:

    > perl your_script.pl command --help --from=utf-8 --to=shift_jis

=head1 DESCRIPTION

This command is used to show help, and expects the first section of the pod of
each command to be a NAME (or equivalent) section with a class name and brief
description of the class/command, separated by a hyphen and arbitrary numbers
of white spaces (like this pod).

If you distribute your script, you may want to make a subclass of this command
just to provide more user-friendly document (content-wise and language-wise).

=head1 METHODS

=head2 run

shows a list of available commands (with brief description if any), or help
(pod) of a specific command.

=head2 options

by default, encode/decode options are available to change encoding.

=head2 extra_namespaces

by default, this command looks for commands just under the namespace you
specified in the script/dispatcher. However, you may want it to look into other
directories to show something like tutorials. For example, if you make a
subclass like this:

  package MyScript::Help;
  use strict;
  use base qw( CLI::Dispatcher::Help );

  sub extra_namespaces { qw( MyScript::Cookbook ) }
  1;

then, when you run the script like this, MyScript/Cookbook/Install.pod (or .pm)
will be shown:

  > perl myscript.pl help install

You may even make it language-conscious:

  package MyScript::Help;
  use strict;
  use base qw( CLI::Dispatcher::Help );

  sub options {qw( lang=s )}

  sub extra_namespaces {
    my $self = shift;
    my $lang = uc( $self->option('lang') || 'EN' );
    return (
      'MyScript::Cookbook::'.$lang,
      'MyScript::Cookbook::EN',     # in case of $lang is wrong
    );
  1;

This can be used to provide more user-friendly documents (without overriding
commands themselves).

=head2 output

by default, takes a text, decode/encode it if necessary, prints the result to
stdout, and returns the text.

=head2 extract_pod

takes a command and looks for the actual pm/pod file to read its pod, and
returns the pod (without the first section to hide the class name and brief
description).

=head2 extract_pod_body

takes a pod, removes the first ("NAME") section, and returns the pod. You may
also want to hide other sections like "AUTHOR" and "COPYRIGHT" for end users.

=head2 list_commands

returns a concatenated text of a list of the available commands with brief
description (if any).

=head2 convert_command

takes a name of a command, converts it if necessary (decamelize by default),
and returns the result.

=head2 extract_brief_description

takes a pod, extract the first ("NAME") section (actually the first line of the
first section), and returns it. Override this if you don't want to cut longer
(multi-lined) description.

=head1 AUTHOR

Kenichi Ishigaki, E<lt>ishigaki@cpan.orgE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2008 by Kenichi Ishigaki.

This program is free software; you can redistribute it and/or modify it under
the same terms as Perl itself.

=cut