App-hr
view release on metacpan or search on metacpan
# },
# },
# 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} }) {
#use YAML::Old::Mo; # XXX
#
#sub yaml_dump {
# my $self = shift;
# my ($value) = @_;
# my ($class, $type) = YAML::Old::Mo::Object->node_info($value);
# no strict 'refs';
# my $kind = lc($type) . ':';
# my $tag = ${$class . '::ClassTag'} ||
# "!perl/$kind$class";
# if ($type eq 'REF') {
# YAML::Old::Node->new(
# {(&YAML::Old::VALUE, ${$_[0]})}, $tag
# );
# }
# elsif ($type eq 'SCALAR') {
# $_[1] = $$value;
# YAML::Old::Node->new($_[1], $tag);
# }
# elsif ($type eq 'GLOB') {
# # blessed glob support is minimal, and will not round-trip
# # initial aim: to not cause an error
# return YAML::Old::Type::glob->yaml_dump($value, $tag);
# } else {
# YAML::Old::Node->new($value, $tag);
# }
#}
#
##-------------------------------------------------------------------------------
#package YAML::Old::Type::undef;
#
#sub yaml_dump {
# my $self = shift;
#}
#
#sub yaml_load {
# my $self = shift;
#}
#
##-------------------------------------------------------------------------------
#package YAML::Old::Type::glob;
#
#sub yaml_dump {
# my $self = shift;
# # $_[0] remains as the glob
# my $tag = pop @_ if 2==@_;
#
# $tag = '!perl/glob:' unless defined $tag;
# my $ynode = YAML::Old::Node->new({}, $tag);
# for my $type (qw(PACKAGE NAME SCALAR ARRAY HASH CODE IO)) {
# my $value = *{$_[0]}{$type};
# $value = $$value if $type eq 'SCALAR';
# if (defined $value) {
# if ($type eq 'IO') {
# my @stats = qw(device inode mode links uid gid rdev size
# atime mtime ctime blksize blocks);
# undef $value;
# $value->{stat} = YAML::Old::Node->new({});
# if ($value->{fileno} = fileno(*{$_[0]})) {
# local $^W;
# map {$value->{stat}{shift @stats} = $_} stat(*{$_[0]});
# $value->{tell} = tell(*{$_[0]});
# }
# }
# $ynode->{$type} = $value;
# }
# }
# return $ynode;
#}
#
#sub yaml_load {
# my $self = shift;
# my ($node, $class, $loader) = @_;
# my ($name, $package);
# if (defined $node->{NAME}) {
# $name = $node->{NAME};
# delete $node->{NAME};
# }
# else {
# $loader->warn('YAML_LOAD_WARN_GLOB_NAME');
# return undef;
# }
# if (defined $node->{PACKAGE}) {
# $package = $node->{PACKAGE};
# delete $node->{PACKAGE};
# }
# else {
# $package = 'main';
# }
# no strict 'refs';
# if (exists $node->{SCALAR}) {
# *{"${package}::$name"} = \$node->{SCALAR};
# delete $node->{SCALAR};
# }
# for my $elem (qw(ARRAY HASH CODE IO)) {
# if (exists $node->{$elem}) {
# if ($elem eq 'IO') {
# $loader->warn('YAML_LOAD_WARN_GLOB_IO');
# delete $node->{IO};
# next;
# }
# *{"${package}::$name"} = $node->{$elem};
# delete $node->{$elem};
# }
# }
# for my $elem (sort keys %$node) {
# $loader->warn('YAML_LOAD_WARN_BAD_GLOB_ELEM', $elem);
# }
# return *{"${package}::$name"};
#}
#
##-------------------------------------------------------------------------------
#package YAML::Old::Type::code;
#
#my $dummy_warned = 0;
#my $default = '{ "DUMMY" }';
#
#sub yaml_dump {
# my $self = shift;
# my $code;
# my ($dumpflag, $value) = @_;
( run in 1.451 second using v1.01-cache-2.11-cpan-39bf76dae61 )