view release on metacpan or  search on metacpan

lib/Class/Usul/TraitFor/Usage.pm  view on Meta::CPAN

   documentation      => 'Displays this command line usage',
   short              => '?';

option 'show_version' => is => 'ro',   isa => Bool, default => FALSE,
   documentation      => 'Displays the version number of the program class';

has 'file'            => is => 'lazy', isa => DataLumper,
   builder            => sub { Class::Usul::File->new( builder => $_[ 0 ] ) };

has 'ipc'             => is => 'lazy', isa => ProcCommer,
   builder            => sub { Class::Usul::IPC->new( builder => $_[ 0 ] ) },
   handles            => [ 'run_cmd' ];

# Class attributes
my $_can_call_cache = {}; my $_method_cache = {};

# Private functions
my $_list_methods_of = sub {
   my $class = blessed $_[ 0 ] || $_[ 0 ];

   exists $_method_cache->{ $class } or $_method_cache->{ $class }
      = [ map  { s{ \A .+ :: }{}msx; $_ }
          grep { my $subr = $_;
                 grep { $_ eq 'method' } attributes::get( \&{ $subr } ) }
              @{ Class::Inspector->methods( $class, 'full', 'public' ) } ];

   return $_method_cache->{ $class };
};

my $_get_pod_header_for_method = sub {
   my ($class, $method) = @_;

   my $src = find_source $class
      or throw 'Class [_1] cannot find source', [ $class ];
   my $ev  = [ grep { $_->{content} =~ m{ (?: ^|[< ]) $method (?: [ >]|$ ) }msx}
               grep { $_->{type} eq 'command' }
                   @{ Pod::Eventual::Simple->read_file( $src ) } ]->[ 0 ];
   my $pod = $ev ? $ev->{content} : undef; $pod and chomp $pod;

   return $pod;
};

# Private methods
my $_apply_stdio_encoding = sub {
   my $self = shift; my $enc = untaint_cmdline $self->encoding;

   for (*STDIN, *STDOUT, *STDERR) {
      $_->opened or next; binmode $_, ":encoding(${enc})";
   }

   autoflush STDOUT TRUE; autoflush STDERR TRUE;
   return;
};

my $_get_classes_and_roles = sub {
   my $self = shift; my %uniq = (); ensure_class_loaded 'mro';

   my @classes = @{ mro::get_linear_isa( blessed $self ) };

   while (my $class = shift @classes) {
      $class = (split m{ __WITH__ }mx, $class)[ 0 ];
      $class =~ m{ ::_BASE \z }mx and next;
      $class =~ s{ \A Role::Tiny::_COMPOSABLE:: }{}mx;
      $uniq{ $class } and next; $uniq{ $class }++;

      exists $Role::Tiny::APPLIED_TO{ $class }
         and push @classes, keys %{ $Role::Tiny::APPLIED_TO{ $class } };
   }

   return [ sort keys %uniq ];
};

my $_man_page_from = sub {
   my ($self, $src) = @_; ensure_class_loaded 'Pod::Man';

   my $conf     = $self->config;
   my $parser   = Pod::Man->new( center  => $conf->doc_title || NUL,
                                 name    => $conf->script,
                                 release => 'Version '.$self->app_version,
                                 section => '3m' );
   my $cmd      = $conf->man_page_cmd || [];
   my $tempfile = $self->file->tempfile;

   $parser->parse_from_file( $src->pathname.NUL, $tempfile->pathname );
   emit $self->run_cmd( [ @{ $cmd }, $tempfile->pathname ] )->out;
   return OK;
};

my $_usage_for = sub {
   my ($self, $method) = @_; ensure_class_loaded 'Pod::Select';

   for my $class (@{ $self->$_get_classes_and_roles }) {
      is_member( $method, Class::Inspector->methods( $class, 'public' ) )
         or next;

      my $selector = Pod::Select->new(); my $tfile = $self->file->tempfile;

      $selector->select( "/(?:[A-Z][\<])?${method}.*" );
      $selector->parse_from_file( find_source $class, $tfile->pathname );
      $tfile->stat->{size} > 0 and return $self->$_man_page_from( $tfile );
   }

   emit_to \*STDERR, "Method ${method} no documentation found\n";
   return FAILED;
};

my $_output_usage = sub {
   my ($self, $verbose) = @_; my $method = $self->next_argv;

   defined $method and $method = untaint_identifier dash2under $method;

   $self->can_call( $method ) and return $self->$_usage_for( $method );

   $verbose > 1 and return $self->$_man_page_from( $self->config );

   ensure_class_loaded 'Pod::Usage'; $verbose > 0 and Pod::Usage::pod2usage
      ( { -exitval => OK,
          -input   => $self->config->pathname.NUL,
          -message => SPC,
          -verbose => $verbose } ); # Never returns