package Padre::Document::Perl::Autocomplete;
use 5.008;
use strict;
use warnings;
use List::Util ();
our $VERSION = '0.96';
# Experimental package. The API needs a lot of refactoring
# and the whole thing needs a lot of tests
sub new {
my $class = shift;
# Padre has its own defaults for each parameter but this code
# might serve other purposes as well
my %args = (
minimum_prefix_length => 1,
maximum_number_of_choices => 20,
minimum_length_of_suggestion => 3,
@_
);
my $self = bless \%args, $class;
return $self;
}
# WARNING: This is totally not done, but Gabor made me commit it.
# TO DO:
# a) complete this list
# b) make the path configurable
# c) make the whole thing optional and/or pluggable
# d) make it not suck
# e) make the types of auto-completion configurable
# f) remove the old auto-comp code or at least let the user choose to use the new
# *or* the old code via configuration
# g) hack STC so that we can get more information in the autocomp. window,
# h) hack STC so we can start populating the autocompletion choices and continue to do so in the background
# i) hack Perl::Tags to be better (including inheritance)
# j) add inheritance support
# k) figure out how to do method auto-comp. on objects
# (Ticket #676)
sub run {
my $self = shift;
my $parser = shift;
if ( $self->{prefix} =~ /([\$\@\%\*])(\w+(?:::\w+)*)$/ ) {
my $prefix = $2;
my $type = $1;
if ( defined $parser ) {
my $tag = $parser->findTag( $prefix, partial => 1 );
my @words;
my %seen;
while ( defined($tag) ) {
# TO DO check file scope?
if ( !defined( $tag->{kind} ) ) {
# This happens with some tagfiles which have no kind
} elsif ( $tag->{kind} eq 'v' ) {
# TO DO potentially don't skip depending on circumstances.
if ( not $seen{ $tag->{name} }++ ) {
push @words, $tag->{name};
}
}
$tag = $parser->findNextTag;
}
return ( length($prefix), @words );
}
}
# check for hashs
elsif ( $self->{prefix} =~ /(\$\w+(?:\-\>)?)\{([\'\"]?)([\$\&]?\w*)$/ ) {
my $hashname = $1;
my $textmarker = $2;
my $keyprefix = $3;
my %words;
my $text = $self->{pre_text} . ' ' . $self->{post_text};
while ( $text =~ /\Q$hashname\E\{(([\'\"]?)\Q$keyprefix\E.+?\2)\}/g ) {
$words{$1} = 1;
}
return (
length( $textmarker . $keyprefix ),
sort {
my $a1 = $a;
my $b1 = $b;
$a1 =~ s/^([\'\"])(.+)\1/$2/;
$b1 =~ s/^([\'\"])(.+)\1/$2/;
$a1 cmp $b1;
} ( keys(%words) )
);
}
# check for methods
elsif ( $self->{prefix} =~ /(?![\$\@\%\*])(\w+(?:::\w+)*)\s*->\s*(\w*)$/ ) {
my $class = $1;
my $prefix = $2;
$prefix = '' if not defined $prefix;
if ( defined $parser ) {
my $tag = ( $prefix eq '' ) ? $parser->firstTag : $parser->findTag( $prefix, partial => 1 );
my @words;
# TO DO: INHERITANCE!
while ( defined($tag) ) {
if ( !defined( $tag->{kind} ) ) {
# This happens with some tagfiles which have no kind
} elsif ( $tag->{kind} eq 's'
and defined $tag->{extension}{class}
and $tag->{extension}{class} eq $class )
{
push @words, $tag->{name};
}
$tag = ( $prefix eq '' ) ? $parser->nextTag : $parser->findNextTag;
}
return ( length($prefix), @words );
}
}
# check for packages
elsif ( $self->{prefix} =~ /(?![\$\@\%\*])(\w+(?:::\w+)*)/ ) {
my $prefix = $1;
if ( defined $parser ) {
my $tag = $parser->findTag( $prefix, partial => 1 );
my @words;
my %seen;
while ( defined($tag) ) {
# TO DO check file scope?
if ( !defined( $tag->{kind} ) ) {
# This happens with some tagfiles which have no kind
} elsif ( $tag->{kind} eq 'p' ) {
# TO DO potentially don't skip depending on circumstances.
if ( not $seen{ $tag->{name} }++ ) {
push @words, $tag->{name};
}
}
$tag = $parser->findNextTag;
}
return ( length($prefix), @words );
}
}
return;
}
sub auto {
my $self = shift;
my $nextchar = $self->{nextchar};
my $prefix = $self->{prefix};
$prefix =~ s{^.*?((\w+::)*\w+)$}{$1};
my $suffix = substr $self->{post_text}, 0, List::Util::min( 15, length $self->{post_text} );
$suffix = $1 if $suffix =~ /^(\w*)/; # Cut away any non-word chars
if ( defined($nextchar) ) {
return if ( length($prefix) + 1 ) < $self->{minimum_prefix_length};
} else {
return if length($prefix) < $self->{minimum_prefix_length};
}
my $regex;
eval { $regex = qr{\b(\Q$prefix\E\w+(?:::\w+)*)\b} };
if ($@) {
return ("Cannot build regular expression for '$prefix'.");
}
my %seen;
my @words;
push @words, grep { !$seen{$_}++ } reverse( $self->{pre_text} =~ /$regex/g );
push @words, grep { !$seen{$_}++ } ( $self->{post_text} =~ /$regex/g );
if ( @words > $self->{maximum_number_of_choices} ) {
@words = @words[ 0 .. ( $self->{maximum_number_of_choices} - 1 ) ];
}
# Suggesting the current word as the only solution doesn't help
# anything, but your need to close the suggestions window before
# you may press ENTER/RETURN.
if ( ( $#words == 0 ) and ( $prefix eq $words[0] ) ) {
return;
}
# While typing within a word, the rest of the word shouldn't be
# inserted.
if ( defined($suffix) ) {
for ( 0 .. $#words ) {
$words[$_] =~ s/\Q$suffix\E$//;
}
}
# This is the final result if there is no char which hasn't been
# saved to the editor buffer until now
# return ( length($prefix), @words ) if !defined($nextchar);
# Finally cut out all words which do not match the next char
# which will be inserted into the editor (by the current event)
# and remove all which are too short
my @final_words;
for (@words) {
# Filter out everything which is too short
next if length($_) < $self->{minimum_length_of_suggestion};
# Accept everything which has prefix + next char + at least one other char
# (check only if any char is pending)
next if defined($nextchar) and ( !/^\Q$prefix$nextchar\E./ );
# All checks passed, add to the final list
push @final_words, $_;
}
return ( length($prefix), @final_words );
}
1;
# Copyright 2008-2012 The Padre development team as listed in Padre.pm.
# LICENSE
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl 5 itself.