Initial commit of OpenSPARC T2 design and verification files.

[OpenSPARC-T2-DV] / tools / perl-5.8.0 / lib / site_perl / 5.8.0 / Psh / Completion.pm

package Psh::Completion;

use strict;
require Psh::Util;
require Psh::OS;

my $APPEND="not_implemented";

@Psh::Completion::bookmarks= ();
@Psh::Completion::autoload=();

my %module_loaded=();

sub init
{
       my $attribs=$Psh::term->Attribs;

       # The following is ridiculous, but....
       if( $Psh::term->ReadLine eq 'Term::ReadLine::Perl') {
               $APPEND='completer_terminator_character';
       } elsif( $Psh::term->ReadLine eq 'Term::ReadLine::Gnu') {
               $APPEND='completion_append_character';
       }

       # Only ::Gnu understand it, and ::Perl ignores it silently.
       $attribs->{completion_display_matches_hook}
           = \&display_match_list;
}

sub start_module {
       my $command= shift;
       my $file= $Psh::Completion::modules{$command};
       return unless $file;
       return if $module_loaded{$file};
       open(FILE, "< $file");
       my @lines= <FILE>;
       close(FILE);
       if (@lines) {
               my $text= join('',@lines);
               Psh::process_variable($text);
               $module_loaded{$file}=1;
       }
}

{
       my $kh_loaded=0;
       sub bookmarks {
               return @Psh::Completion::bookmarks if $kh_loaded;
               push @Psh::Completion::bookmarks, Psh::OS::get_known_hosts();
               $kh_loaded=1;
               return @Psh::Completion::bookmarks;
       }
}

# Returns a list of possible file completions
sub cmpl_filenames
{
       my $text= shift;
       my $executable_only= shift||0;

       my $exclam=0;

       # HACK HACK HACK - this needs to be fixed some other way -
       # the completion code is severly messed I fear
       $text= Psh::Parser::unquote($text);
       $text=~ s/\\//g;
       # HACK END

       if ( $executable_only) {
           if ($text=~s/^\!//) {
               $exclam=1;
           }
       }

       my $globtext= $text;
       my $prepend= '';

       if( substr($text,0,1) eq '"') {
               $prepend='"';
               $globtext= substr($text,1);
       }

       my @result;

       if (substr($globtext,0,1) eq '~' and !($globtext=~/\//)) {
               # after ~ try username completion
               @result= cmpl_usernames($globtext);
               $Psh::Completion::ac="/" if @result;
               return @result;
       }

       @result= Psh::OS::glob("$globtext*");

       if( Psh::Options::has_option('fignore')) {
               my @ignore= Psh::Options::get_option('fignore');
               @result= grep {
                       my $item= $_;
                       my $result= ! grep { Psh::Util::ends_with($item,$_) } @ignore;
                       $result;
               } @result;
       }

       if ( $executable_only) {
           @result= grep { -x $_ || -d _ } @result;
       }

       @result= map { -d $_ ? "$_/" : $_ } @result;

       # HACK: This won't help much if user tries to do another completion
       # on the same item afterwards
       @result= map { s/([ \'\"\´\`])/\\$1/g; $_ } @result unless $prepend eq '"';

       if(@result==1) {
               if (substr($result[0],-1) eq '/') {
                       $Psh::Completion::ac='';
               }
               $Psh::Completion::ac=$prepend.$Psh::Completion::ac if $prepend;
       }

       foreach (@result) {
               if( m|/([^/]+\/?)$| ) {
                       $_=$1;
               }
       }

       return @result;
}


# Returns a list of possible directory completions
sub cmpl_directories
{
       my $text= shift;
       my $globtext= $text;
       my $prepend= '';

       if( substr($text,0,1) eq '"') {
               $prepend='"';
               $globtext= substr($text,1);
       }

       my @result;
       if (substr($globtext,0,1) eq '~' and !($globtext=~/\//)) {
               # after ~ try username completion
               @result= cmpl_usernames($globtext);
               $Psh::Completion::ac="/" if @result;
               return @result;
       }

       @result= grep { -d $_ } Psh::OS::glob("$globtext*");

       $Psh::Completion::ac=$prepend||'';

       @result= map { $_.'/' } @result;

       foreach (@result) {
               if( m|/([^/]+/?)$| ) {
                       $_=$1;
               }
       }

       return @result;
}


# Returns an array with possible username completions
sub cmpl_usernames
{
       my $text= shift;
       my @result= grep { Psh::Util::starts_with($_,$text) } Psh::OS::get_all_users();
       return @result;
}


#
# Tries to find executables for possible completions
sub cmpl_executable
{
       my $cmd= shift;
       my @result = ();
       my $exclam=0;

       if ($cmd=~s/^\!//) {
               $exclam=1;
       }

       if (Psh::Strategy::active('built_in')) {
               if ($Psh::Support::Alias::loaded) {
                       push @result, grep { Psh::Util::starts_with($_,$cmd) } Psh::Support::Alias::get_alias_commands();
               }
               push @result, grep { Psh::Util::starts_with($_,$cmd) } Psh::Support::Builtins::get_builtin_commands();
       }
       push @result, cmpl_directories($cmd) if $Psh::Completion::complete_first_word_dirs;
       
       local $^W= 0;

       Psh::Util::which($cmd);
       # set up absed_path if not already set and check
       
       foreach my $dir (@Psh::absed_path) {
           push( @result, map { $exclam?'!'.$_:$_ }
                 grep { -x $dir.'/'.$_ && ! -d _ } Psh::OS::glob("$cmd*",$dir) );
       }
       return @result;
}


#
# Completes perl symbols

{
       my %type;

       BEGIN {
               %type = ('$' => 'SCALAR', '*' => 'SCALAR',
                        '@' => 'ARRAY', '$#' => 'ARRAY',
                        '%' => 'HASH',
                        '&' => 'CODE');
       }

       sub cmpl_symbol {
               my ($text, $line, $start) = @_;
       
               my ($prefix, $pre, $pkg, $sym);
                       no strict qw(refs);
               ($prefix, $pre, $pkg) = ($text =~ m/^((\$#|[\@\$%&])(.*::)?)/);
               my @packages = grep /::$/, $pkg ? keys %$pkg : keys %::;
               $pkg = ($Psh::PerlEval::current_package eq 'main' ? '::' : $Psh::PerlEval::current_package . '::') unless $pkg;
               
               my @symbols;
               if ($pre eq '$') {
                       no strict 'vars'; # make `eval' quiet
                       # I cannot use `defined *$sym{SCALAR}',
                       # since it is always true.
                       @symbols = grep (/^\w+$/
                                        && (eval "defined $prefix$_"
                                            || ($sym = $pkg . $_,
                                                defined *$sym{ARRAY}
                                                || defined *$sym{HASH})),
                                            keys %$pkg);
                       } else {
                       @symbols = grep (/^\w+$/
                                        && ($sym = $pkg . $_,
                                            defined *$sym{$type{$pre}}),
                                        keys %$pkg);
               }
               # Do we need a user customizable variable to ignore @packages?
               return grep(/^\Q$text/,
                           map($prefix . $_, @packages, @symbols));
       }
}

#
# Completes key names for Perl hashes
#
sub cmpl_hashkeys {
       my ($text, $line, $start) = @_;

       my $tmp= substr($line, 0, $start + 1);
       my ($var,$arrow) = ($tmp =~ m/^[\$\%]([\w:]+)\s*(->)?\s*\{\s*['"]?/);
       return () unless $var;

       no strict 'refs';
       $var = "$Psh::PerlEval::current_package::$var" unless ($var =~ m/::/);
       return () unless $var;
       if ($arrow) {
               my $hashref = eval "\$$var";
               return grep(/^\Q$text/, keys %$hashref);
       } else {
               return grep(/^\Q$text/, keys %$var);
       }
}

sub _search_ISA {
       my ($mypkg) = @_;
               no strict qw(refs);
       my $isa = "${mypkg}::ISA";
       return $mypkg, map _search_ISA($_), @$isa;
}

sub cmpl_method {
       my ($text, $line, $start) = @_;
       
       my ($var, $pkg, $sym, $pk);
       $var = (substr($line, 0, $start + 1)
               =~ m/\$([\w:]+)\s*->\s*$/)[0];
       $pkg = ref eval (($var =~ m/::/) ? "\$$var" : "\$$Psh::PerlEval::current_package::$var");
       no strict qw(refs);
       return grep(/^\Q$text/,
                   map { $pk = $_ . '::';
                         grep (/^\w+$/
                               && ($sym = "${pk}$_", defined *$sym{CODE}),
                               keys %$pk);
                 } _search_ISA($pkg));
}

{

       # complete perl bare words (Perl function, subroutines, filehandle)
       sub cmpl_perl_function {
               my ($text) = @_;

               my ($prefix, $pkg, $sym);
               no strict qw(refs);
               ($prefix, $pkg) = ($text =~ m/^((.*::)?)/);
               my @packages = grep /::$/, $pkg ? keys %$pkg : keys %::;
               $pkg = ($Psh::PerlEval::current_package eq 'main' ? '::' : $Psh::PerlEval::current_package . '::') unless $pkg;
               
               my @subs = grep (/^\w+$/
                                && ($sym = $pkg . $_,
                                    defined *$sym{CODE}
                                    || defined *$sym{FILEHANDLE}),
                                keys %$pkg);
               # Do we need a user customizable variable to ignore @packages?
               my @result= grep(/^\Q$text/,
                                                !$prefix && @Psh::Completion::keyword,
                                                map($prefix . $_, @packages, @subs));
               if (@result==1) {
                       $Psh::Completion::ac='';
               }
               return @result;
   }

       BEGIN {
               # from perl5.004_02 perlfunc
               @Psh::Completion::keyword = qw(
                   chomp chop chr crypt hex index lc lcfirst
                   length oct ord pack q qq
                   reverse rindex sprintf substr tr uc ucfirst
                   y
                   
                   m pos quotemeta s split study qr

                   abs atan2 cos exp hex int log oct rand sin
                   sqrt srand

                   pop push shift splice unshift

                   grep join map qw reverse sort unpack
                   
                   delete each exists keys values
                   
                   binmode close closedir dbmclose dbmopen die
                   eof fileno flock format getc print printf
                   read readdir rewinddir seek seekdir select
                   syscall sysread sysseek syswrite tell telldir
                   truncate warn write
                   
                   pack read syscall sysread syswrite unpack vec
                   
                   chdir chmod chown chroot fcntl glob ioctl
                   link lstat mkdir open opendir readlink rename
                   rmdir stat symlink umask unlink utime
                   
                   caller continue die do dump eval exit goto
                   last next redo return sub wantarray
                   
                   caller import local my package use
                   
                   defined dump eval formline local my reset
                   scalar undef wantarray
                   
                   alarm exec fork getpgrp getppid getpriority
                   kill pipe qx setpgrp setpriority sleep
                   system times wait waitpid
                   
                   do import no package require use
                   
                   bless dbmclose dbmopen package ref tie tied
                   untie use
                   
                   accept bind connect getpeername getsockname
                   getsockopt listen recv send setsockopt shutdown
                   socket socketpair
                   
                   msgctl msgget msgrcv msgsnd semctl semget
                   semop shmctl shmget shmread shmwrite
                   
                   endgrent endhostent endnetent endpwent getgrent
                   getgrgid getgrnam getlogin getpwent getpwnam
                   getpwuid setgrent setpwent
                   
                   endprotoent endservent gethostbyaddr
                   gethostbyname gethostent getnetbyaddr
                   getnetbyname getnetent getprotobyname
                   getprotobynumber getprotoent getservbyname
                   getservbyport getservent sethostent setnetent
                   setprotoent setservent
                   
                   gmtime localtime time times
                   
                   abs bless chomp chr exists formline glob
                   import lc lcfirst map my no prototype qx qw
                   readline readpipe ref sub sysopen tie tied
                   uc ucfirst untie use
                   
                   dbmclose dbmopen
                  );
       }
}

#
# completion(text,line,start,end)
#
# Main Completion function
#

sub completion
{
       my ($text, $line, $start) = @_;
       my $attribs               = $Psh::term->Attribs;


       my @tmp=();
       my $cut= 0;
       my $starttext= substr($line, 0, $start);

       if ($starttext =~ /((?:\S|\\\s)+\\\s)$/) {
               $text= $1.$text;
               $cut= length($1);
               $start-= $cut;
               $starttext= substr($line, 0, $start);
       }


       my $startchar= substr($line, $start, 1);

       $starttext =~ /^\s*(\S+)\s+/;
       my $command= $1 || '';

       my $pretext= '';
       if( $starttext =~ /--\w+=(\S*)$/) {
               $pretext= $1;
       } elsif ( $starttext =~ /\s(\S*)$/) {
               $pretext= $1;
       } elsif( $starttext =~ /^(\S*)$/) {
               $pretext= $1;
       }

       # are we in backticks or after a pipe ?
       if( $starttext =~ /.*[\|\`]\s*(\S+)\s+/) {
               $command= $1;
       }

       my $firstflag= $starttext !~/\s/ || 0;

       $Psh::Completion::ac=' ';

       $command =~ m|^\s*(\S*/)?(\S*)|;

       if ($Psh::debugging and
               ($Psh::debugging eq '1' or
                $Psh::debugging =~ /c/)) {
               Psh::Util::print_debug_class('c',"\n");
               Psh::Util::print_debug_class('c',"Completion: text=$text, line=$line, start=$start, starttext=$starttext, command=$command, first=$firstflag\n");
       }


       my $dir=$1||'';
       my $base=$2||'';
       my $cmd;

       if ($Psh::Completion::modules{$cmd= $dir.$base} or
               $Psh::Completion::modules{$cmd= $base}) {
               start_module($cmd);
       }

       if ($Psh::PCompletion::LOADED) {
               # Check completion-spec is defined or not.
               my $cmd;
               my $cs = $Psh::PCompletion::COMPSPEC{$cmd = $dir . $base}
                 || $Psh::PCompletion::COMPSPEC{$cmd = $base};
               my $universal=0;
               unless (defined $cs) {
                       $cs= $Psh::PCompletion::COMPSPEC{'*'};
                       $cmd= $dir.$base;
                       $universal=1;
               }

               # Do programmable completion if completion-spec is defined.
               # This is done here to keep the compatibility with bash.
               if (defined $cs) {
                       # remove prefix string if it is already prefixed.
                       $text =~ s/^\Q$cs->{prefix}//
                         if (defined $cs->{prefix});
                       @tmp = Psh::PCompletion::pcomp_list($cs, $text, $line, $start, $cmd);
                       if (!@tmp) {
                               if ($cs->{option} and $cs->{option} eq 'default') {
                               } elsif ($universal) {
                                       # ignore both cases
                               } else {
                                       return ();
                               }
                       } else {
                               $attribs->{$APPEND}=$Psh::Completion::ac;
                               return @tmp;
                       }
               }
       }

       if ($starttext =~ m/\$([\w:]+)\s*(->)?\s*{\s*['"]?$/) {
               # $foo{key, $foo->{key
               @tmp= cmpl_hashkeys($text, $line, $start);
               $Psh::Completion::ac = '}';
       } elsif ($starttext =~ m/\$([\w:]+)\s*->\s*['"]?$/) {
               # $foo->method
               @tmp= cmpl_method($text, $line, $start);
               $Psh::Completion::ac = ' ';
       } elsif ( $text =~ /^\$#|[\@\$%&]/) {
               # $foo, @foo, $#foo, %foo, &foo
               @tmp= cmpl_symbol($text, $line, $start);
               $Psh::Completion::ac = '';
       } elsif( $firstflag || $starttext =~ /[\|\`]\s*$/) {
               # we have the first word in the line or a pipe sign/backtick in front
               # of the current item, so we try to complete executables
               
               if ($pretext=~m/\//) {
                       @tmp = cmpl_filenames($pretext.$text,1)
               } else {
                       @tmp= cmpl_executable($text);
               }
               unless ($pretext) {
                       # Afterwards we add possible matches for perl barewords
                       push @tmp, cmpl_perl_function($text);
               }
       } else {
               @tmp = cmpl_filenames($pretext.$text);
       }

       if (Psh::Strategy::active('built_in') and
               grep { $_ eq $command } Psh::Support::Builtins::get_builtin_commands() ) {
               my $pkg= ucfirst($command);
               eval "require Psh::Builtins::$pkg";
               Psh::Util::print_debug_class('e',"Error: $@") if $@;
               my @tmp2= eval 'Psh::Builtins::'.$pkg.'::cmpl_'."$command('$text','$pretext','$starttext','$line')";
               if( @tmp2 && $tmp2[0]) {
                       shift(@tmp2);
                       @tmp= @tmp2;
               } else {
                       shift(@tmp2);
                       push @tmp, @tmp2;
               }
       }

       $attribs->{$APPEND}=$Psh::Completion::ac;

       if ($cut) {
               @tmp= map { substr($_, $cut)} @tmp;
       }
       return @tmp;
}

sub display_match_list {
   my($matches, $num_matches, $max_length) = @_;
       my @matches= @$matches; # make a copy, otherwise there's memory managment trouble
       shift @matches;

   map { $_ =~ s/^((\$#|[\@\$%&])?).*::(.+)/$3/; }(@matches);
       my $col='01;34';
       if ($ENV{LS_COLORS}) {
               my @tmp= split /:/, $ENV{LS_COLORS};
               foreach (@tmp) {
                       if (substr($_,0,3) eq 'di=') {
                               $col= substr($_,3);
                               last;
                       }
               }
       }
       map { $_ =~ s/^([^\/]+)\/$/\001\e[${col}m\002$1\001\e[00m\002\//; } (@matches);
       print STDOUT "\n";
       Psh::Util::print_list(\@matches,$max_length);
#       eval {
#               local $^W=0;
#               $Psh::term->display_match_list($matches);
#       };
   eval {
               local $^W=0;
               $Psh::term->forced_update_display if defined $Psh::term;
       };
}

1;
__END__

=head1 NAME

Psh::Completion - containing the completion routines of psh.
Currently works with Term::ReadLine::Gnu and Term::ReadLine::Perl.

=head1 SYNOPSIS


=head1 DESCRIPTION


=head1 AUTHOR

Markus Peter, warp@spin.de
Hiroo Hayashi, hiroo.hayashi@computer.org

=head1 SEE ALSO


=cut