File Coverage

lib/Devel/Trepan/CmdProcessor/Command/Info_Subcmd/Packages.pm

Criterion	Covered	Total	%
statement	57	205	27.8
branch	0	84	0.0
condition	0	10	0.0
subroutine	19	27	70.3
pod			n/a
total	76	326	23.3

# -*- coding: utf-8 -*-
# Copyright (C) 2014 Rocky Bernstein <[e-mail]>
use warnings; no warnings 'redefine'; no warnings 'once';
use rlib '../../../../..';

package Devel::Trepan::CmdProcessor::Command::Info::Packages;

use Devel::Trepan::CmdProcessor::Command::Subcmd::Core;
use Getopt::Long qw(GetOptionsFromArray);

use strict;
our (@ISA, @SUBCMD_VARS);
# Values inherited from parent
use vars @Devel::Trepan::CmdProcessor::Command::Subcmd::SUBCMD_VARS;

## FIXME: do automatically.
our $CMD = "info packages";

unless (@ISA) {
    eval <<"EOE";
    use constant MAX_ARGS => undef;  # Need at most this many - undef -> unlimited.
EOE
}
@ISA = qw(Devel::Trepan::CmdProcessor::Command::Subcmd);
=pod

=head2 Synopsis:

=cut
our $HELP = <<'HELP';
=pod

B<info packages> [I<options>] [I<match>]

options:

    -e | --exact
    -p | --prefix
    -r | --regexp
    -f | --files
    -s | --subs

The default is C<--prefix>

Give package names and optionally the file(s) that package is in for
packages matching I<match>. Options control how to interpret the the
match pattern.

=head2 Examples:

    info packages Tie::            # match all packages that start with Tie::
                                   # e.g. Tie::ExtraHash and Tie::Hash
    info packages -p Tie::         # same as above
    info packages -r ^Tie::        # same as above
    info packages -s Tie::         # same as above, but list the subs
                                   # of each package along with the package
    info packages -e Tie::Hash     # match exactly Tie::Hash
    info packages -e -f Tie::Hash  # same as above but show the file(s) where
                                   # the package is defined
    info packages -r ::Tie$        # match Tie only at the end,
                                   # e.g. ReadLine::Tie
    info packages                  # List all packages

=head2 See also:

L<C<info functions>|Devel::Trepan::CmdProcessor::Command::Info::Functions>, and
L<C<complete>|Devel::Trepan::CmdProcessor::Command::Complete>.

=cut
HELP

our $SHORT_HELP = 'All function names, or those matching REGEXP';
our $MIN_ABBREV = length('pa');

sub complete($$) {
    my ($self, $prefix) = @_;
    my @pkgs = Devel::Trepan::Complete::complete_packages($prefix);
    my @opts = (qw(-r --regexp -p --prefix -s --subs -f --files),
		@pkgs);
    Devel::Trepan::Complete::complete_token(\@opts, $prefix) ;
}

my $DEFAULT_OPTIONS = {
    exact   => 0,
    prefix  => 0,
    regexp  => 0,
    files   => 0,
    funcs   => 0,
};

sub parse_options($$)
{
    my ($self, $args) = @_;
    my %opts = %$DEFAULT_OPTIONS;
    my $result = &GetOptionsFromArray($args,
          '-e'        => \$opts{exact},
          '--exact'   => \$opts{exact},
          '-r'        => \$opts{regexp},
          '--regexp'  => \$opts{regexp},
          '-f'        => \$opts{files},
          '--files'   => \$opts{files},
          '-p'        => \$opts{prefix},
          '--prefix'  => \$opts{prefix},
          '-s'        => \$opts{subs},
          '--subs'    => \$opts{subs}
        );
    # Option consistency checking
    my $count = $opts{exact} + $opts{regexp} + $opts{prefix};
    if ($count == 0) {
	$opts{prefix} = 1;
    } elsif ($count > 1) {
	if ($opts{regexp}) {
	    $self->{proc}->errmsg("regexp option used with prefix and/or exact; regexp used");
	    $opts{prefix} = $opts{exact} = 0;
	} elsif ($opts{prefix}) {
	    $self->{proc}->errmsg("prefix used with exact; prefix used");
	    $opts{exact} = 0;
	}
    }

    \%opts;

}

# FIXME combine with Command::columnize_commands
use Array::Columnize;
sub columnize_pkgs($$)
{
    my ($proc, $commands) = @_;
    my $width = $proc->{settings}->{maxwidth};
    my $r = Array::Columnize::columnize($commands,
                                       {displaywidth => $width,
                                        colsep => '    ',
                                        ljust => 1,
                                        lineprefix => '  '});
    chomp $r;
    return $r;
}

sub run($$)
{
    my ($self, $args) = @_;
    my @args = @$args;
    my $options = parse_options($self, \@args);
    my $proc = $self->{proc};
    my $match = undef;

    if (@args == 3) {
        $match = $args[2];
    }

    my %pkgs;
    foreach my $function (keys %DB::sub) {
	my @parts = split('::', $function);
	if (scalar @parts > 1) {
	    my $func  = pop(@parts);
	    my $pkg = join('::', @parts);
	    $pkgs{$pkg} ||= [{}, {}];
	    if ($options->{files}) {
		my $file_range = $DB::sub{$function};
		if ($file_range =~ /^(.+):(\d+-\d+)/) {
		    my ($filename, $range) = ($1, $2);
		    my $files = $pkgs{$pkg}->[0];
		    $files->{$filename} = 1;
		    $pkgs{$pkg}->[0] = $files;
		}
	    }
	    if ($options->{subs}) {
		my $funcs = $pkgs{$pkg}->[1];
		$funcs->{$func} = 1;
		$pkgs{$pkg}->[1] = $funcs;
	    }

	}
    }
    my @pkgs = keys %pkgs;
    if ($options->{regexp}) {
	@pkgs = grep /$match/, @pkgs if defined $match;
    } elsif ($options->{prefix}) {
	@pkgs = grep /^$match/, @pkgs if defined $match;
    } else {
	@pkgs = grep /^$match$/, @pkgs if defined $match;
    }
    if (scalar @pkgs) {
	if ($options->{files} || $options->{subs}) {
	    for my $pkg (sort @pkgs) {
		if ($options->{subs}) {
		    my $subs = $pkgs{$pkg}->[1];
		    my @subs = sort keys %$subs;
		    $proc->section($pkg);
		    if (scalar @subs) {
			my $msg = columnize_pkgs($proc, \@subs);
			$proc->msg($msg);
		    } else {
			$proc->msg($pkg);
		    }
		}
		if ($options->{files}) {
		    my $filename = $pkgs{$pkg}->[0];
		    my @files = sort keys %$filename;
		    if (scalar @files) {
			my $file_str = @files == 1 ? 'file' : 'files';
			my $msg = sprintf("%s is in %s %s", $pkg, $file_str,
					  join(', ', @files));
			$proc->msg($msg);
		    } else {
			$proc->msg($pkg);
		    }
		}
	    }
        } else {
	    @pkgs = sort @pkgs;
	    my $msg = columnize_pkgs($proc, \@pkgs);
	    $proc->msg($msg);
	}
    } else {
	$proc->msg('No matching package');
    }
}

unless (caller) {
    # Demo it.
    require Devel::Trepan::CmdProcessor::Mock;
    my $proc = Devel::Trepan::CmdProcessor->new(undef, 'bogus');
    my $cmd = __PACKAGE__->new($proc);
    $cmd->{proc} = $proc;
    my $frame_ary = Devel::Trepan::CmdProcessor::Mock::create_frame();
    $proc->frame_setup($frame_ary);
    $proc->{settings}{highlight} = 0;
    %DB::sub = qw(main::gcd 1);
    $cmd->run([]);

    # require_relative '../../mock'
    # my($dbgr, $parent_cmd) = MockDebugger::setup('show');
    # $cmd = __PACKAGE__->new(parent_cmd);
    # $cmd->run(@$cmd->prefix);
}

# Suppress a "used-once" warning;
$HELP || scalar @SUBCMD_VARS;