view release on metacpan or  search on metacpan

lib/Config/Model/TermUI.pm  view on Meta::CPAN

        # print "Grabbing $cmd\n";
        eval {
            $new_item = $self->{current_node}->grab(
                step => $cmd, type => 'node', mode => 'strict', autoadd => 0
            );
        };
        chop $cmd;
    }

    #print "Grab got ",$new_item->location,"\n";

    my @choice;
    my $new_type = $new_item->get_type;

    my @children = $node_only ? $new_item->get_element_name( cargo_type => 'node' )
        : $new_item->get_element_name();
    # say "Children: @children";
    foreach my $elt_name (@children) {
        if ( $new_item->element_type($elt_name) =~ /^(hash|list)$/ ) {
            push @choice, "$elt_name:" unless $node_only;
            foreach my $idx ( $new_item->fetch_element($elt_name)->fetch_all_indexes ) {
                # my ($idx) = ($raw_idx =~ /([^\n]{1,40})/ );
                # $idx .= '...' unless $raw_idx eq $idx ;
                push @choice, "$elt_name:" . ($idx =~ /[^\w._-]/ ? qq("$idx") : $idx );
            }
        }
        else {
            push @choice, $elt_name;
        }
    }

    # filter possible choices according to input
    my @ret = grep { /^$text/ } @choice ;

    return @ret;
};

# like path completion, but allow only completion on a node
my $node_completion_sub = sub (@args) {
    return $path_completion_sub->(@args, 1);
};

my %completion_dispatch = (
    cd      => $cd_completion_sub,
    desc    => $completion_sub,
    display => $completion_sub,
    ll      => $ll_completion_sub,
    ls      => $path_completion_sub,
    tree    => $node_completion_sub,
    info    => $path_completion_sub,
    check   => $completion_sub,
    fix     => $fix_completion_sub,
    clear   => $completion_sub,
    set     => $leaf_completion_sub,
    delete  => $leaf_completion_sub,
    reset   => $completion_sub,
);

sub completion ($self, $text, $line, $start) {
    my $space_idx = index $line, ' ';
    my ( $main, $cmd ) = split m/\s+/, $line, 2;    # /;
            #warn " comp main cmd is '$main' (space_idx $space_idx)\n";

    if ( $space_idx > 0 and defined $completion_dispatch{$main} ) {
        my $i = $self->{current_node}->instance;
        # say "Input: ['$text', '$line', $start], ";

        my @choices = $completion_dispatch{$main}->( $self, $text, $line, $start );
        # say "Choices: ['", join("', '",@choices),"']";
        return @choices;
    }
    elsif ( not $cmd ) {
        return grep { /^$text/ } $self->simple_ui_commands() ;
    }

    return ();
}

sub new ($type, %args) {
    my $self = {};

    foreach my $p (qw/root title prompt/) {
        $self->{$p} = delete $args{$p}
            or croak "TermUI->new: Missing $p parameter";
    }

    $self->{current_node} = $self->{root};

    my $term = Term::ReadLine->new( $self->{title} );

    my $sub_ref = sub (@args) { $self->completion(@args); };

    my $word_break_string = "\\\t\n' `\@\$><;|&{(";

    if ( $term->ReadLine eq "Term::ReadLine::Gnu" ) {

        # See Term::ReadLine::Gnu / Custom Completion
        my $attribs = $term->Attribs;
        $attribs->{completion_function}             = $sub_ref;
        $attribs->{completer_word_break_characters} = $word_break_string;
        # this method is available only on Term::ReadLine::Gnu > 1.32
        $term->enableUTF8 if $term->can('enableUTF8');
    }
    elsif ( $term->ReadLine eq "Term::ReadLine::Perl" ) {
        ## no critic (TestingAndDebugging::ProhibitNoWarnings)
        no warnings "once";
        warn "utf-8 support has not beed tested with Term::ReadLine::Perl. ",
            "You should install Term::ReadLine::Gnu.\n";
        $readline::rl_completion_function = $sub_ref;
        &readline::rl_set( rl_completer_word_break_characters => $word_break_string );

        # &readline::rl_set('TcshCompleteMode', 'On');
    }
    else {
        warn "You should install Term::ReadLine::Gnu for autocompletion and utf-8 support.\n";
    }

    $self->{term} = $term;

    foreach my $p (qw//) {
        $self->{$p} = delete $args{$p} if defined $args{$p};