# -*- coding: utf-8 -*-
# Copyright (C) 2011-2012, 2014 Rocky Bernstein <rocky@cpan.org>
use warnings; use strict; use utf8;
use Exporter;
package Devel::Trepan::Complete;
=head1 SUMMARY
Completion routines for L<Devel::Trepan>
=cut
use vars qw(@ISA @EXPORT); @ISA = qw(Exporter);
@EXPORT = qw(
complete_builtins complete_subs complete_packages
complete_token complete_token_with_next
next_token signal_complete
complete_token_filtered_with_next);
use constant BUILTIN_CONST => qw(__FILE__ __LINE__ __PACKAGE__);
use constant BUILTIN_FNS => qw(
abs accept alarm
and atan2 bind binmode bless caller
chdir chmod chown chr chroot close
closedir cmp connect continue cos crypt
dbmclose dbmopen die dump endgrent
endhostent endnetent endprotoent endpwent
endservent eof eq exec exit exp fcntl
fileno flock fork formline ge getc
getgrent getgrgid getgrnam gethostbyaddr
gethostbyname gethostent getlogin
getnetbyaddr getnetbyname getnetent
getpeername getpgrp getppid getpriority
getprotobyname getprotobynumber getprotoent
getpwent getpwnam getpwuid getservbyname
getservbyport getservent getsockname
getsockopt glob gmtime gt hex index int
ioctl join kill lc lcfirst le length
link listen localtime lock log lstat lt
mkdir msgctl msgget msgrcv msgsnd ne
not oct open opendir or ord pack pipe
quotemeta rand read readdir readline
readlink readpipe recv ref rename require
reset reverse rewinddir rindex rmdir seek
seekdir select semctl semget semop send
setgrent sethostent setnetent setpgrp
setpriority setprotoent setpwent setservent
setsockopt shmctl shmget shmread shmwrite
shutdown sin sleep socket socketpair
sprintf sqrt srand stat substr symlink
syscall sysopen sysread system syswrite tell
telldir time times truncate uc ucfirst
umask unlink unpack utime values vec
wait waitpid wantarray warn write x xor
);
use constant BUILTIN_CORE_FNS => map { 'CORE::' . $_ } BUILTIN_FNS;
=head2 Subroutines
=head3 complete_token
Return an list of string, I<$complete_ary>, which start out with
String I<$prefix>.
=cut
sub complete_token($$)
{
my ($complete_ary, $prefix) = @_;
my @result = ();
for my $cmd (@$complete_ary) {
if (0 == index($cmd, $prefix)) {
push @result, $cmd ;
}
}
sort @result;
}
sub complete_token_with_next($$;$)
{
my ($complete_hash, $prefix, $cmd_prefix) = @_;
$cmd_prefix ='' if scalar(@_) < 3;
my $cmd_prefix_len = length($cmd_prefix);
my @result = ();
while (my ($cmd_name, $cmd_obj) = each %{$complete_hash}) {
if (0 == index($cmd_name, $cmd_prefix . $prefix)) {
push @result, [substr($cmd_name, $cmd_prefix_len), $cmd_obj]
}
}
sort {$a->[0] cmp $b->[0]} @result;
}
=head3 complete_token_filtered
Find all starting matches in Hash I<$aliases+>that start with
I<$prefix>, but filter out any matches already in I<$expanded>.
=cut
sub complete_token_filtered($$$)
{
my ($aliases, $prefix, $expanded) = @_;
my @complete_ary = keys %{$aliases};
my @result = ();
for my $cmd (@complete_ary) {
push @result, $cmd if
0 == index($cmd, $prefix) && !exists $expanded->{$aliases->{$cmd}};
}
sort @result;
}
=head3 complete_token_filtered_with_next
Find all starting matches in hash I<$aliases> that start with I<$prefix>,
but filter out any matches already in I<$expanded>.
=cut
sub complete_token_filtered_with_next($$$$)
{
my ($aliases, $prefix, $expanded, $commands) = @_;
# require Enbugger; Enbugger->stop;
my @complete_ary = keys %{$aliases};
my %expanded = %{$expanded};
my @result = ();
for my $cmd (@complete_ary) {
if (0 == index($cmd, $prefix) && !exists $expanded{$aliases->{$cmd}}) {
push @result, [$cmd, $commands->{$aliases->{$cmd}}];
}
}
@result;
}
=head3 next_token
Find the next token in str string from start_pos. We return
the token and the next blank position after the token or
length($str) if this is the last token. Tokens are delimited by
white space.
=cut
sub next_token($$)
{
my ($str, $start_pos) = @_;
my $look_at = substr($str, $start_pos);
my $strlen = length($look_at);
return (1, '') if 0 == $strlen;
my $next_nonblank_pos = $start_pos;
my $next_blank_pos;
if ($look_at =~ /^(\s*)(\S+)\s*/) {
$next_nonblank_pos += length($1);
$next_blank_pos = $next_nonblank_pos+length($2);
} elsif ($look_at =~ /^(\s+)$/) {
return ($start_pos + length($1), '');
} elsif ($look_at =~/^(\S+)\s*/) {
$next_blank_pos = $next_nonblank_pos + length($1);
} else {
die "Something is wrong in next_token";
}
my $token_size = $next_blank_pos - $next_nonblank_pos;
return ($next_blank_pos, substr($str, $next_nonblank_pos, $token_size));
}
=head3 filename_list
I<filename_list> is from I<Term::ReadLine::readline.pm>:
For use in passing to completion_matches(), returns a list of
filenames that begin with the given pattern. The user of this
package can set I<$rl_completion_function> to 'rl_filename_list' to
restore the default of filename matching if they'd changed it
earlier, either directly or via I<&rl_basic_commands>.
=cut
sub filename_list(;$$)
{
my ($pattern, $add_suffix) = @_;
$pattern = '' unless defined $pattern;
$add_suffix = 0 unless defined $add_suffix;
# $pattern = glob($pattern) if substr($pattern, 0, 1) = '~';
my @files = (<$pattern*>);
if ($add_suffix) {
foreach (@files) {
if (-l $_) {
$_ .= '@';
} elsif (-d _) {
$_ .= '/';
} elsif (-x _) {
$_ .= '*';
} elsif (-S _ || -p _) {
$_ .= '=';
}
}
}
return @files;
}
# Custom completion routines
my @signal_complete_completions=();
sub signal_complete($) {
my ($prefix) = @_;
unless(@signal_complete_completions) {
@signal_complete_completions = keys %SIG;
my $last_sig = scalar @signal_complete_completions;
push(@signal_complete_completions,
map({lc $_} @signal_complete_completions));
my @nums = (-$last_sig .. $last_sig);
push @signal_complete_completions, @nums;
}
complete_token(\@signal_complete_completions, $prefix);
}
sub complete_builtins($)
{
my ($prefix) = @_;
my @builtin_fns = BUILTIN_FNS;
if (0 == index($prefix ,'CORE::')) {
map { 'CORE::' . $_ }
complete_token(\@builtin_fns, substr($prefix, length('CORE::')));
} else {
complete_token(\@builtin_fns, $prefix);
}
}
sub complete_subs($)
{
my ($prefix) = @_;
no warnings 'once';
my @all_fns = sort((keys(%DB::sub),
BUILTIN_FNS, BUILTIN_CORE_FNS, BUILTIN_CONST));
my $have_fn_sigl = 0;
if (substr($prefix, 0, 1) eq '&') {
@all_fns = map { '&' . $_ } @all_fns;
$have_fn_sigl = 1;
}
my @functions = complete_token(\@all_fns, $prefix);
if (scalar @functions == 0 && !($prefix =~ /::/)) {
my $pkg_prefix = $DB::package . '::';
if ($have_fn_sigl) {
my $new_prefix = '&' . $pkg_prefix . substr($prefix, 1);
@functions = map { substr($_, length($pkg_prefix)+1) }
complete_token(\@all_fns, $new_prefix);
} else {
my $new_prefix = $pkg_prefix . $prefix;
@functions = map { substr($_, length($pkg_prefix)) }
complete_token(\@all_fns, $new_prefix);
}
}
return sort @functions;
}
sub complete_packages($)
{
my ($prefix) = @_;
my %pkgs;
no warnings 'once';
foreach my $function (keys %DB::sub) {
my @parts = split('::', $function);
if (scalar @parts > 1) {
pop(@parts);
my $pkg = join('::', @parts);
$pkgs{$pkg} = 1 if $pkg =~ /^$prefix/;
}
}
return sort keys %pkgs;
}
unless (caller) {
my $hash_ref = {'ab' => 1, 'aac' => 2, 'aa' => 3, 'b' => 4};
my @cmds = keys %{$hash_ref};
printf("complete_token(@cmds, '') => %s\n",
join(', ', complete_token(\@cmds, '')));
printf("complete_token(@cmds, 'a') => %s\n",
join(', ', complete_token(\@cmds, 'a')));
printf("complete_token(@cmds, 'b') => %s\n",
join(', ', complete_token(\@cmds, 'b')));
printf("complete_token(@cmds, 'c') => %s\n",
join(', ', complete_token(\@cmds, 'c')));
my @ary = complete_token_with_next($hash_ref, 'a');
my @ary_str = map "($_->[0], $_->[1])", @ary;
printf("complete_token_with_next(\$hash_ref, 'a') => %s\n",
join(', ', @ary_str));
print "0 1 \n";
print "0123456789012345678\n";
my $x = ' now is the time';
print "$x\n";
for my $pos (0, 2, 5, 6, 8, 9, 13, 18, 19) {
my @ary = next_token($x, $pos);
printf "next_token($pos) = %d, '%s'\n", $ary[0], $ary[1];
}
print "List of filenames:\n";
print join(', ', filename_list), "\n";
print "List of filenames beginning with C:\n";
print join(', ', filename_list('C')), "\n";
print join(', ', signal_complete('C')), "\n";
foreach my $prefix (qw(CORE::len len db foo CORE::foo)) {
printf("complete_subs($prefix) => %s\n",
join(', ', complete_subs($prefix)));
}
$DB::package = 'main';
%DB::sub = qw(main::gcd 1);
foreach my $prefix (qw(end CORE::end gcd main::gcd foo CO __FI)) {
printf("complete_subs($prefix) => %s\n",
join(', ', complete_subs($prefix)));
}
my $prefix = 'mai';
printf("complete_packages($prefix) => %s\n",
join(', ', complete_packages($prefix)));
# FIXME: We don't handle ~ expansion right now.
# print "List of filenames expanded from ~\n";
}
1;