App-Pod/lib/App/Pod.pm
package App::Pod;
use v5.24; # Postfix deref :)
use strict;
use warnings;
use Pod::Query;
use Module::CoreList();
use Getopt::Long qw( GetOptions );
use Module::Functions qw( get_full_functions );
use File::HomeDir qw( home );
use File::Basename qw( basename );
use File::Spec::Functions qw( catfile );
use List::Util qw( first max );
use Mojo::File qw( path );
use Mojo::JSON qw( j );
use Perl::OSType qw( os_type );
use Term::ANSIColor qw( colored );
use Carp qw( cluck );
use open qw( :std :utf8 );
use subs qw( _sayt uniq );
# Catch eval warnings better.
$SIG{__WARN__} = sub { cluck shift };
=head1 LOGO
~ __ ~
~ ____ ____ ____/ / ~
~ / __ \/ __ \/ __ / ~
~ / /_/ / /_/ / /_/ / ~
~ / .___/\____/\__,_/ ~
~ /_/ ~
=head1 NAME
App::Pod - Quickly show available class methods and documentation.
=cut
our $VERSION = '0.40';
=head1 SYNOPSIS
View summary of Mojo::UserAgent:
% pod Mojo::UserAgent
View summary of a specific method.
% pod Mojo::UserAgent get
Edit the module
% pod Mojo::UserAgent -e
Edit the module and jump to the specific method definition right away.
(Press "n" to next match if neeeded).
% pod Mojo::UserAgent get -e
Run perldoc on the module (for convenience).
% pod Mojo::UserAgent -d
List all available methods.
If no methods are found normally, then this will automatically be enabled.
(pod was made to work with Mojo pod styling).
% pod Mojo::UserAgent -a
List all Module::Build actions.
% pod Module::Build --query head1=ACTIONS/item-text
Can do the same stuff with a file
% pod my.pod --query head1
Show help.
% pod
% pod -h
=head1 DESCRIPTION
Basically, this is a tool that can quickly summarize the contents of a perl module.
=head1 SUBROUTINES/METHODS
=cut
#
# Method maker
#
=head2 _has
Generates class accessor methods (like Mojo::Base::attr)
=cut
sub _has {
no strict 'refs';
for my $attr ( @_ ) {
*$attr = sub {
return $_[0]{$attr} if @_ == 1; # Get: return $self-<{$attr}
$_[0]{$attr} = $_[1]; # Set: $self->{$attr} = $val
$_[0]; # return $self
}
if not defined &$attr;
}
}
sub import {
_has qw(
_class
_args
_method
_opts
_core_flags
_non_main_flags
_cache_from_file
_cache_pod
_cache_path
_cache_name_and_summary
_cache_version
_cache_isa
_cache_events
_cache_methods
_cache_method_and_doc
_dirty_cache
);
}
#
# Debug
#
sub _dumper {
require Data::Dumper;
my $data = Data::Dumper
->new( [@_] )
->Indent( 1 )
->Sortkeys( 1 )
->Terse( 1 )
->Useqq( 1 )
->Dump;
return $data if defined wantarray;
say $data;
}
#
# Run
#
=head2 run
Run the main program.
use App::Pod;
App::Pod->run;
Or just use the included script:
% pod
=cut
sub run {
my $self = __PACKAGE__->_new;
return if $self->_process_core_flags;
return if $self->_abort;
if ( $self->_non_main_flags->@* ) {
$self->_process_non_main;
}
else {
$self->_process_main;
}
$self->_dump();
$self->store_cache if $self->_dirty_cache;
}
sub _new {
my ( $class ) = @_;
my $self = bless {}, $class;
$self->_init;
$self;
}
sub _init {
my ( $self ) = @_;
# Show help when no input.
@ARGV = ( "--help" ) if not @ARGV;
my $o = _get_opts();
my ( $class, @args ) = @ARGV;
$self->_opts( $o );
$self->_class( $class );
$self->_args( \@args );
$self->_method( $args[0] );
my @core_flags;
my @non_main_flags;
for ( $self->_define_spec() ) {
# We are using the option and it has a handler.
next unless $o->{ $_->{name} } and $_->{handler};
if ( $_->{core} ) {
push @core_flags, $_;
}
else {
push @non_main_flags, $_;
}
}
# Core flags.
# These do not need any error checks
# and will be processed early.
$self->_core_flags( \@core_flags );
# Non main flags.
# These are features separate from the main program.
$self->_non_main_flags( \@non_main_flags );
# Explicitly force getting the real data.
$self->_dirty_cache( 1 ) if $o->{flush_cache};
# Not sure how to handle colors in windows.
$self->_no_colors() if $self->_opts->{no_colors} or os_type eq "Windows";
}
sub _no_colors {
my @colors = qw(
_red
_yellow
_green
_grey
_neon
_reset
);
no strict 'refs';
no warnings 'redefine';
# Pass through the args.
for my $color ( @colors ) {
*$color = sub { "@_" };
}
}
sub _dump {
my ( $self ) = @_;
my $dump = $self->_opts->{dump} or return;
my $data;
if ( $dump >= 2 ) { # Dump all.
$data = $self;
}
elsif ( $dump >= 1 ) { # Skip lol and tree.
$data = {%$self}; # Shallow copy.
for ( keys %$data ) { # Keep the dump simple.
delete $data->{$_} if /^_cache_/ and !/path/;
}
}
say "self=" . _dumper $data;
}
# Spec
sub _define_spec {
my @spec = (
# If given a handler, will be auto processed.
# Core options will be processed early.
# Core.
{
spec => "help|h",
description => "Show this help section.",
handler => "_show_help",
core => 1,
},
{
spec => "version|v",
description => "Show this tool version.",
handler => "_show_version",
core => 1,
},
{
spec => "tool_options|to",
description => "List tool options.",
handler => "list_tool_options",
core => 1,
},
# Non main.
{
spec => "class_options|co",
description => "Class events and methods.",
handler => "list_class_options",
},
{
spec => "doc|d",
description => "View class documentation.",
handler => "doc_class",
},
{
spec => "edit|e",
description => "Edit the source code.",
handler => "edit_class",
},
{
spec => "query|q=s",
description => "Run a pod query.",
handler => "query_class",
},
{
spec => "dump|dd+",
description => "Dump extra info (adds up).",
core => 1,
},
{
spec => "all|a",
description => "Show all class functions.",
},
{
spec => "no_colors",
description => "Do not output colors.",
},
{
spec => "no_error",
description => "Suppress some error message.",
},
{
spec => "flush_cache|f",
description => "Flush cache file(s).",
},
);
# Add the name.
for ( @spec ) {
$_->{name} = $_->{spec} =~ s/\|.+//r;
}
@spec;
}
sub _get_spec_list {
map { $_->{spec} } _define_spec();
}
sub _get_opts {
my $opts = {};
GetOptions( $opts, _get_spec_list() ) or die "$!\n";
$opts;
}
sub _get_pod {
my ( $self ) = @_;
# Use in-memory cache if present.
my $pod = $self->_cache_pod;
return $pod if $pod;
# Otherwise, make a new Pod::Query object.
$pod = Pod::Query->new( $self->_class );
# Cache it in-memory.
$self->_cache_pod( $pod );
$pod;
}
#
# Core
#
sub _process_core_flags {
my ( $self ) = @_;
for ( $self->_core_flags->@* ) {
say "Processing: $_->{name}" if $self->_opts->{dump};
my $handler = $_->{handler};
return 1 if $self->$handler;
}
return 0;
}
# Help
sub _show_help {
my ( $self ) = @_;
say $self->_process_template(
$self->_define_help_template,
$self->_build_help_options,
);
return 1;
}
sub _define_help_template {
<<"HELP";
##_neon:Syntax:
<SCRIPT> module_name [method_name] [options]
##_neon:Options:
<OPTIONS>
##_neon:Examples:
##_grey:# All or a method
<SCRIPT> Mojo::UserAgent
<SCRIPT> Mojo::UserAgent prepare
##_grey:# Documentation
<SCRIPT> Mojo::UserAgent -d
##_grey:# Edit class or method
<SCRIPT> Mojo::UserAgent -e
<SCRIPT> Mojo::UserAgent prepare -e
##_grey:# List all methods
<SCRIPT> Mojo::UserAgent --class_options
##_grey:# List all Module::Build actions.
<SCRIPT> Module::Build --query head1=ACTIONS/item-text
HELP
}
sub _process_template {
my ( $self, $template, $options ) = @_;
my $script = _yellow( "pod" );
for ( $template ) {
# Color.
s/ ^ \s* \K \#\#([\w_]+): (.*) / qq($1("$2")) /gmxee;
# Expand <SCRIPT> tags.
s/<SCRIPT>/$script/g;
# Expand <OPTIONS> tags.
s/<OPTIONS>/$options/g;
}
$template;
}
sub _build_help_options {
my @all = map {
my $opt = $_->{spec};
my $desc = $_->{description};
$opt =~ s/\+$//; # Trailing plus in option.
$opt =~ s/=\w+$//g; # Option parameter.
$opt =~ s/\|/, /g;
$opt =~ s/ (?=\b\w{2}) /--/gx; # Long opts
$opt =~ s/ (?=\b\w\b) /-/gx; # Short opts
my $colored_opt = _green( $opt );
[ $colored_opt, _grey( $desc ), length $colored_opt ];
} _define_spec();
my $max = max map { $_->[2] } @all;
my $indent = " " x 2;
my $options =
join "\n$indent",
map { sprintf "%-${max}s - %s", @$_[ 0, 1 ] } @all;
$options;
}
# Version
sub _show_version {
my ( $self ) = @_;
my $version = $self->VERSION;
say "pod (App::Pod) $version";
return 1;
}
# List
=head2 list_tool_options
Returns a list of the possible command line options
to this tool.
=cut
sub list_tool_options {
my ( $self ) = @_;
say
for sort
map { length( $_ ) == 1 ? "-$_" : "--$_"; }
map { s/\+$//r } # Options which are additive.
map { s/=\w+$//r } # Options which take values.
map { split /\|/ } _get_spec_list();
# Abort if not using also --class_options.
not $self->_opts->{class_options};
}
#
# Abort
#
sub _abort {
my ( $self ) = @_;
my $class = $self->_class;
if ( not $class ) {
if ( not $self->_opts->{no_error} ) {
say "";
say _red( "Class name not provided!" );
say _reset( "" );
}
return 1;
}
# No wierd class names.
if ( $class !~ m{ ^ [-~\w_:\\/. ]+ $ }x ) {
if ( not $self->_opts->{no_error} ) {
say "";
say _red( "Invalid class name: $class" );
say _reset( "" );
}
return 1;
}
# Make sure the path is not empty (error signal from Pod::Query).
if ( not $self->_get_path ) {
if ( not $self->_opts->{no_error} ) {
say "";
say _red( "Class not found: $class" );
say _reset( "" );
}
return 1;
}
return 0;
}
sub _get_path {
my ( $self ) = @_;
# Use in-memory cache if present.
my $mem_cache = $self->_cache_path;
return $mem_cache if $mem_cache;
# Use disk cache if present.
my $disk_cache = $self->retrieve_cache;
if ( $disk_cache and $disk_cache->{path} ) {
$self->_cache_path( $disk_cache->{path} );
return $disk_cache->{path};
}
# Otherwise, get the class path.
local $Pod::Query::DEBUG_FIND_DUMP = 1 if $self->_opts->{dump};
my $path = $self->_get_pod->path;
# Cache it in-memory.
$self->_cache_path( $path );
# Flag that disk cache should be stored later.
$self->_dirty_cache( 1 );
$path;
}
#
# Non Main
#
sub _process_non_main {
my ( $self ) = @_;
say "_process_non_main()" if $self->_opts->{dump};
for ( $self->_non_main_flags->@* ) {
say "Processing: $_->{name}" if $self->_opts->{dump};
my $handler = $_->{handler};
return 1 if $self->$handler;
}
}
# List
=head2 list_class_options
Shows a list of all the available class options
which may be methods, events, etc.
(This is handy for making tab completion based on
a class.)
=cut
sub list_class_options {
my ( $self ) = @_;
# Use cache if available.
my $cache = $self->retrieve_cache();
# Make class specific cache if missing.
if ( $cache->{class} ne $self->_class ) {
$cache = $self->store_cache;
}
# Show possible options
say for $cache->{options}->@*;
}
# Edit
=head2 edit_class
Edit a class using vim.
Can optionally just to a specific keyword.
=cut
sub edit_class {
my ( $self ) = @_;
my $path = $self->_get_path;
my $method = $self->_method;
my $cmd = "vim $path";
if ( $method ) {
my $m = "<\\zs$method\\ze>";
my $sub = "<sub $m";
my $monkey = "<monkey_patch>.+$m";
my $list = "^ +$m +\\=\\>";
my $qw = "<qw>.+$m";
my $emit = "<(emit|on)\\($m";
$cmd .= " '+/\\v$sub|$monkey|$list|$qw|$emit'";
}
exec $cmd;
}
# Doc
=head2 doc_class
Show the documentation for a module using perldoc.
=cut
sub doc_class {
my ( $self ) = @_;
my $class = $self->_class;
my @args = $self->_args->@*;
exec "perldoc @args $class";
}
# Query
=head2 query_class
Run a pod query using Pod::Query.
Use --dump option to show the data structure.
(For debugging use).
=cut
sub query_class {
my ( $self ) = @_;
local $Pod::Query::DEBUG_FIND_DUMP = 1 if $self->_opts->{dump};
say for $self->_get_pod->find( $self->_opts->{query} );
}
#
# Main
#
sub _process_main {
my ( $self ) = @_;
say "_process_main()" if $self->_opts->{dump};
# Go on.
$self->show_header;
if ( $self->_method ) {
$self->show_method_doc;
}
else {
$self->show_inheritance;
$self->show_events;
$self->show_methods;
}
}
# Header
sub _get_name_and_summary {
my ( $self ) = @_;
# Use in-memory cache if present.
my $mem_cache = $self->_cache_name_and_summary;
return $mem_cache if $mem_cache;
# Use disk cache if present.
my $disk_cache = $self->retrieve_cache;
if ( $disk_cache and $disk_cache->{name_and_summary} ) {
$self->_cache_name_and_summary( $disk_cache->{name_and_summary} );
return $disk_cache->{name_and_summary};
}
# Otherwise, get all class events.
local $Pod::Query::DEBUG_FIND_DUMP = 1 if $self->_opts->{dump};
my $title = $self->_get_pod->find_title;
my $name_and_summary = [ split /\s*-\s*/, $title, 2 ];
# Cache it in-memory.
$self->_cache_name_and_summary( $name_and_summary );
# Flag that disk cache should be stored later.
$self->_dirty_cache( 1 );
$name_and_summary;
}
sub _get_version {
my ( $self ) = @_;
# Use in-memory cache if present.
my $version_cache = $self->_cache_version;
return $version_cache if $version_cache;
# Use disk cache if present.
my $disk_cache = $self->retrieve_cache;
if ( $disk_cache and $disk_cache->{version} ) {
$self->_cache_version( $disk_cache->{version} );
return $disk_cache->{version};
}
# Otherwise, get the package/class version.
my $class = $self->_class;
# TODO: Be able to get class from path
if ( not $self->_get_pod->class_is_path ) {
eval "require $class";
}
my $version = $class->VERSION // '';
# Cache it in-memory.
$self->_cache_version( $version );
# Flag that disk cache should be stored later.
$self->_dirty_cache( 1 );
$version;
}
=head2 show_header
Prints a generic header for a module.
=cut
sub show_header {
my ( $self ) = @_;
my $class = $self->_class;
my $version = $self->_get_version;
my $class_is_path = $self->_get_pod->class_is_path;
my $first_release =
$class_is_path ? "" : Module::CoreList->first_release( $class );
my @package_line = (
_grey( "Package:" ),
sprintf(
"%s%s%s",
_yellow( $class_is_path ? "" : $class ),
( $version ? _green( " $version" ) : "" ),
(
$first_release
? _grey( " (since perl " )
. _green( $first_release )
. _grey( ")" )
: ""
),
),
);
my @path_line = ( _grey( "Path:" ), _grey( $self->_get_path ), );
my $max = max map { length } $package_line[0], $path_line[0];
my $format = "%-${max}s %s";
say "";
_sayt sprintf( $format, @package_line );
_sayt sprintf( $format, @path_line );
say "";
my ( $name, $summary ) = $self->_get_name_and_summary->@*;
return unless $name and $summary;
_sayt _yellow( $name ) . " - " . _green( $summary );
say _reset( "" );
}
# Inheritance
sub _get_isa {
my ( $self ) = @_;
# Use in-memory cache if present.
my $isa_cache = $self->_cache_isa;
return $isa_cache if $isa_cache;
# Use disk cache if present.
my $disk_cache = $self->retrieve_cache;
if ( $disk_cache and $disk_cache->{isa} ) {
$self->_cache_isa( $disk_cache->{isa} );
return $disk_cache->{isa};
}
# Otherwise, get all class inheritance.
my @classes = ( $self->_class );
my @isa;
my %seen;
# TODO: Be able to get class from path
if ( not $self->_get_pod->class_is_path ) {
no strict 'refs';
while ( my $class = shift @classes ) {
next if $seen{$class}++; # Already saw it
push @isa, $class; # Add to list.
eval "require $class";
push @classes, @{"${class}::ISA"};
}
}
# Cache it in-memory.
$self->_cache_isa( \@isa );
# Flag that disk cache should be stored later.
$self->_dirty_cache( 1 );
\@isa;
}
=head2 show_inheritance
Show the Inheritance chain of a class/module.
=cut
sub show_inheritance {
my ( $self ) = @_;
my $isa = $self->_get_isa;
my $size = @$isa;
return if $size <= 1;
say _neon( "Inheritance ($size):" );
say _grey( " $_" ) for @$isa;
say _reset( "" );
}
# Events
sub _get_events {
my ( $self ) = @_;
# Use in-memory cache if present.
my $mem_cache = $self->_cache_events;
return $mem_cache if $mem_cache;
# Use disk cache if present.
my $disk_cache = $self->retrieve_cache;
if ( $disk_cache and $disk_cache->{events} ) {
$self->_cache_events( $disk_cache->{events} );
return $disk_cache->{events};
}
# Otherwise, get all class events.
local $Pod::Query::DEBUG_FIND_DUMP = 1 if $self->_opts->{dump};
my %events = $self->_get_pod->find_events;
# Cache it in-memory.
$self->_cache_events( \%events );
# Flag that disk cache should be stored later.
$self->_dirty_cache( 1 );
\%events;
}
sub _get_event_names {
my ( $self ) = @_;
sort keys $self->_get_events->%*;
}
=head2 show_events
Show any declared class events.
=cut
sub show_events {
my ( $self ) = @_;
my $events = $self->_get_events;
my @names = sort keys %$events;
my $size = @names;
return unless $size;
my $len = max map { length( _green( $_ ) ) } @names;
my $format = " %-${len}s - %s";
say _neon( "Events ($size):" );
for ( @names ) {
_sayt sprintf $format, _green( $_ ), _grey( $events->{$_} );
}
say _reset( "" );
}
# Methods
sub _get_methods {
my ( $self ) = @_;
# Use in-memory cache if present.
my $mem_cache = $self->_cache_methods;
return $mem_cache if $mem_cache;
# Use disk cache if present.
my $disk_cache = $self->retrieve_cache;
if ( $disk_cache and $disk_cache->{methods} ) {
$self->_cache_methods( $disk_cache->{methods} );
return $disk_cache->{methods};
}
# Otherwise, get all class methods.
local $Pod::Query::DEBUG_FIND_DUMP = 1 if $self->_opts->{dump};
my $pod = $self->_get_pod;
my @method_names;
# The provided class is really the path.
{
local *_PodHelper;
if ( $pod->class_is_path ) {
@method_names = $pod->find( "head2" );
}
elsif ( $self->_import_class ) {
@method_names =
sort { $a cmp $b }
uniq get_full_functions( "_PodHelper" ), # ojo would import here.
get_full_functions( $self->_class ); # All else here
# TODO: figure out why "local *_Pod" does
# not remove the typeglob at the end.
# Also "undef *_Pod" does nothing.
delete @_PodHelper::{ keys %_PodHelper:: };
}
}
my @methods =
map { [ $_, scalar $pod->find_method_summary( $_ ) ] } @method_names;
# Cache it in-memory.
$self->_cache_methods( \@methods );
# Flag that disk cache should be stored later.
$self->_dirty_cache( 1 );
\@methods;
}
sub _import_class {
my ( $self ) = @_;
my $class = $self->_class;
# Try not to pollute main.
# ojo imports its DSL into the current package by default.
eval { eval "package _PodHelper; use $class"; };
my $import_ok = do {
if ( $@ ) { warn $@; 0 }
else { 1 }
};
$import_ok;
}
sub _get_method_names {
my ( $self ) = @_;
my $methods = $self->_get_methods;
my @names =
grep { / ^ [\w_-]+ $ /x } # Normal looking names.
map { $_->[0] } @$methods;
}
=head2 show_methods
Show all class methods.
=cut
sub show_methods {
my ( $self ) = @_;
my $all_method_names_and_docs = $self->_get_methods; # 0: name, 1: doc.
# Skip some methods unless using --all flag.
my %skip_methods =
map { $_ => 1 }
qw(
BEGIN
VERSION
ISA
__ANON__
);
if ( not $self->_opts->{all} ) {
@$all_method_names_and_docs =
grep { not $skip_methods{ $_->[0] } } @$all_method_names_and_docs;
}
# Documented methods
my @all_method_docs = grep { $_->[1] } @$all_method_names_and_docs;
# If we have methods, but none are documented (or found).
if ( @$all_method_names_and_docs and not @all_method_docs ) {
say _grey(
"Warning: All methods are undocumented! (reverting to --all)\n" );
$self->_opts->{all} = 1;
}
my @methods =
$self->_opts->{all} ? @$all_method_names_and_docs : @all_method_docs;
my $max = max 0, map { length _green( $_->[0] ) } @methods;
my $format_with_desc = " %-${max}s%s";
my $format_no_desc = " %s%s";
my $size = @methods;
say _neon( "Methods ($size):" );
for my $list ( @methods ) {
my ( $method, $doc_raw ) = @$list;
my $doc = $doc_raw ? " - $doc_raw" : "";
$doc =~ s/\n+/ /g;
my $format = $doc_raw ? $format_with_desc : $format_no_desc;
_sayt sprintf $format, _green( $method ), _grey( $doc );
}
say _grey( "\nUse --all (or -a) to see all methods." )
unless $self->_opts->{all};
say _reset( "" );
}
=head2 show_method_doc
Show documentation for a specific module method.
=cut
sub show_method_doc {
my ( $self ) = @_;
local $Pod::Query::DEBUG_FIND_DUMP = 1 if $self->_opts->{dump};
my $doc = $self->_get_pod->find_method( $self->_method );
# Color.
for ( $doc ) {
chomp;
# Headings.
s/ ^ \s* \K (\S+:) (?= \s* $ ) / _green($1) /xgem;
# Comments.
s/ (\#.+) / _grey($1) /xge;
}
say $doc;
say _reset( "" );
}
#
# Caching
#
=head2 define_last_run_cache_file
Defined where to save the results from the last run.
This is done for performance reasons.
=cut
sub define_last_run_cache_file {
my ( $self ) = @_;
catfile( home(), ".cache", "my_pod_last_run.cache", );
}
sub _get_class_options {
my ( $self ) = @_;
[ sort $self->_get_event_names, $self->_get_method_names, ];
}
=head2 store_cache
Saves the last class name and its methods/options.
=cut
sub store_cache {
my ( $self ) = @_;
my $cache = {
class => $self->_class,
path => $self->_get_path,
name_and_summary => $self->_get_name_and_summary,
version => $self->_get_version,
isa => $self->_get_isa,
events => $self->_get_events,
methods => $self->_get_methods,
options => $self->_get_class_options,
};
my $path = path( $self->define_last_run_cache_file );
if ( not -e $path->dirname ) {
mkdir $path->dirname or die $!;
}
my $writer = $path->can( "spew" ) ? "spew" : "spurt";
$path->$writer( j $cache );
# Reset the flag.
$self->_dirty_cache( 0 );
$cache;
}
=head2 retrieve_cache
Returns the last stored class cache and its options.
=cut
sub retrieve_cache {
my ( $self ) = @_;
my $empty = { class => "" };
return $empty if $self->_dirty_cache;
# Use in-memory cache if present.
my $mem_cache = $self->_cache_from_file;
return $mem_cache if $mem_cache;
# Otherwise, go to the actual file.
my $file = $self->define_last_run_cache_file;
if ( not -e $file ) {
$self->_dirty_cache( 1 );
return $empty;
}
# Extract data from file.
my $disk_cache = j path( $file )->slurp;
# Wrong class.
if ( $disk_cache->{class} ne $self->_class ) {
$self->_dirty_cache( 1 );
return $empty;
}
# Cache it locally
$self->_cache_from_file( $disk_cache );
$disk_cache;
}
#
# Output
#
=head2 trim
Trim a line to fit the terminal width.
Handles also escape codes within the line.
=cut
sub trim {
my ( $line ) = @_;
state $esc = qr{ \033\[ [\d;]+ m }x;
state $data = qr{ (?: (?!$esc) . )++ }x;
state $data_or_escape = qr{ (?<data>$data) | (?<esc>$esc) }x;
state $term_width = Pod::Query::get_term_width();
state $replacement = " ...";
state $width_raw = $term_width - length( $replacement );
state $base_width = $width_raw >= 0 ? $width_raw : 0; # To avoid negatives.
# Figure out the total len of the line (uncolored).
my $total_chars = 0;
my @detailed_line_parts;
while ( $line =~ /$data_or_escape/g ) {
my $part = {%+};
$total_chars += $part->{len} = length( $part->{data} // "" );
push @detailed_line_parts, $part;
}
# No need to trim.
return $line if $total_chars <= $term_width;
# Need to trim.
my @parts;
my $size_exceeded;
my $so_far_len = 0;
for my $part ( @detailed_line_parts ) {
# Handle escape codes.
if ( not $part->{len} ) {
push @parts, $part->{esc}; # Add escapes back.
last if $size_exceeded; # Done.
next;
}
# Handle trailing escapes.
last if $size_exceeded;
# Trim line if it would be too long.
if ( $so_far_len + $part->{len} > $base_width ) {
$size_exceeded = 1; # Still need to possibly add a trailing escape.
# Limit line to allowed width.
$part->{data} = substr(
$part->{data},
0,
$base_width - $so_far_len, # How much space is left.
) . $replacement;
}
$so_far_len += $part->{len};
push @parts, $part->{data};
}
join "", @parts;
}
sub _sayt {
say trim( @_ );
}
sub _red {
colored( "@_", "RESET RED" );
}
sub _yellow {
colored( "@_", "RESET YELLOW" );
}
sub _green {
# Reset since last line may be trimmed.
colored( "@_", "RESET GREEN" );
}
sub _grey {
colored( "@_", "RESET DARK" );
}
sub _neon {
colored( "@_", "RESET ON_BRIGHT_BLACK" );
}
sub _reset {
colored( "@_", "RESET" );
}
#
# Misc Support
#
sub uniq(@) {
my %h;
grep { not $h{$_}++ } @_;
}
#
# Legacy
#
=for Legacy
-
- # pod version 0
-
- package UNIVERSAL;
-
- sub dir{
- my ($s) = @_; # class or object
- my $ref = ref $s;
- my $class = $ref ? $ref : $s; # myClass
- my $pkg = $class . "::"; # MyClass::
- my @keys_raw;
- my $is_special_block = qr/^ (?:BEGIN|UNITCHECK|INIT|CHECK|END|import|DESTROY) $/x;
-
- no strict 'refs';
-
- while( my($key,$stash) = each %$pkg){
- # next if $key =~ /$is_special_block/; # Not a special block
- # next if $key =~ /^ _ /x; # Not private method
- next if ref $stash; # Stash name should not be a reference
- next if not defined *$stash{CODE}; # Stash function should be defined
- push @keys_raw, $key;
- }
-
- my @keys = sort @keys_raw;
-
- return @keys if defined wantarray;
-
- say join "\n ", "\n$class", @keys;
- }
=head1 ENVIRONMENT
Install bash completion support.
% apt install bash-completion
Install tab completion.
% source bash_completion_pod
=head1 SEE ALSO
L<Pod::Query>
L<Pod::LOL>
L<Module::Functions>
=head1 AUTHOR
Tim Potapov, C<< <tim.potapov[AT]gmail.com> >>
=head1 BUGS
Please report any bugs or feature requests to L<https://github.com/poti1/app-pod/issues>.
=head1 SUPPORT
You can find documentation for this module with the perldoc command.
perldoc App::Pod
You can also look for information at:
L<https://metacpan.org/pod/App::Pod>
L<https://github.com/poti1/app-pod>
=head1 ACKNOWLEDGEMENTS
TBD
=head1 LICENSE AND COPYRIGHT
This software is Copyright (c) 2022 by Tim Potapov.
This is free software, licensed under:
The Artistic License 2.0 (GPL Compatible)
=cut
1; # End of App::Pod