view release on metacpan or  search on metacpan

lib/Complete/File.pm  view on Meta::CPAN

        dep_all => [recurse_matching => ['recurse']],
    },
    result_naked => 1,
    result => {
        schema => 'array',
    },
};
sub complete_file {
    require Complete::Path;
    require Encode;
    require File::Glob;

    my %args   = @_;
    my $word   = $args{word} // "";
    my $handle_tilde = $args{handle_tilde} // 1;
    my $allow_dot   = $args{allow_dot} // 1;

    # if word is starts with "~/" or "~foo/" replace it temporarily with user's
    # name (so we can restore it back at the end). this is to mimic bash
    # support. note that bash does not support case-insensitivity for "foo".
    my $result_prefix;
    my $starting_path = $args{starting_path} // '.';
    if ($handle_tilde && $word =~ s!\A(~[^/]*)/!!) {
        $result_prefix = "$1/";
        my @dir = File::Glob::bsd_glob($1); # glob will expand ~foo to /home/foo
        return [] unless @dir;
        $starting_path = Encode::decode('UTF-8', $dir[0]);
    } elsif ($allow_dot && $word =~ s!\A((?:\.\.?/+)+|/+)!!) {
        # just an optimization to skip sequences of '../'
        $starting_path = $1;
        $result_prefix = $1;
        $starting_path =~ s#/+\z## unless $starting_path =~ m!\A/!;
    }

    # bail if we don't allow dot and the path contains dot
    return [] if !$allow_dot &&
        $word =~ m!(?:\A|/)\.\.?(?:\z|/)!;

    # prepare list_func
    my $list = sub {
        my ($path, $intdir, $isint) = @_;
        opendir my($dh), $path or return undef;
        my @res;
        for (sort readdir $dh) {
            # skip . and .. if leaf is empty, like in bash
            next if ($_ eq '.' || $_ eq '..') && $intdir eq '';
            next if $isint && !(-d "$path/$_");
            push @res, Encode::decode('UTF-8', $_);
        }
        \@res;
    };

    # prepare filter_func

    # from the filter option
    my $filter;
    if ($args{filter} && !ref($args{filter})) {
        my @seqs = split /\s*\|\s*/, $args{filter};
        $filter = sub {
            my $name = shift;
            my @st = stat($name) or return 0;
            my $mode = $st[2];
            my $pass;
          SEQ:
            for my $seq (@seqs) {
                my $neg = sub { $_[0] };
                for my $c (split //, $seq) {
                    if    ($c eq '-') { $neg = sub { $_[0] ? 0 : 1 } }
                    elsif ($c eq 'r') { next SEQ unless $neg->($mode & 0400) }
                    elsif ($c eq 'w') { next SEQ unless $neg->($mode & 0200) }
                    elsif ($c eq 'x') { next SEQ unless $neg->($mode & 0100) }
                    elsif ($c eq 'f') { next SEQ unless $neg->($mode & 0100000)}
                    elsif ($c eq 'd') { next SEQ unless $neg->($mode & 0040000)}
                    else {
                        die "Unknown character in filter: $c (in $seq)";
                    }
                }
                $pass = 1; last SEQ;
            }
            $pass;
        };
    } elsif ($args{filter} && ref($args{filter}) eq 'CODE') {
        $filter = $args{filter};
    }

    # from the file_regex_filter option
    my $filter_fregex;
    if ($args{file_regex_filter}) {
        $filter_fregex = sub {
            my $name = shift;
            return 1 if -d $name;
            return 0 unless -f _;
            return 1 if $name =~ $args{file_regex_filter};
            0;
        };
    }

    # from the file_ext_filter option
    my $filter_fext;
    if ($args{file_ext_filter} && ref $args{file_ext_filter} eq 'Regexp') {
        $filter_fext = sub {
            my $name = shift;
            return 1 if -d $name;
            return 0 unless -f _;
            my $ext = $name =~ /\.(\w+)\z/ ? $1 : '';
            return 1 if $ext =~ $args{file_ext_filter};
            0;
        };
    } elsif ($args{file_ext_filter} && ref $args{file_ext_filter} eq 'ARRAY') {
        $filter_fext = sub {
            my $name = shift;
            return 1 if -d $name;
            return 0 unless -f _;
            my $ext = $name =~ /\.(\w+)\z/ ? $1 : '';
            if ($Complete::Common::OPT_CI) {
                $ext = lc($ext);
                for my $e (@{ $args{file_ext_filter} }) {
                    return 1 if $ext eq lc($e);
                }
            } else {
                for my $e (@{ $args{file_ext_filter} }) {