/
perlquery
executable file
·107 lines (80 loc) · 7.11 KB
/
perlquery
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
#!/usr/bin/perl
# JQuery emulation for the command line.
# This program implements jQuery-style selectors over files and directories. It also provides manipulation and traversal methods that you can use on collections of files. Not all of the concepts
# have a clear mapping between jQuery and the file system, but because the structures are so similar most of them map reasonably well.
# Selector syntax.
# Selector syntax is generally identical to jQuery's where applicable. I've made some changes to be more useful for files. Note that spaces are required around all operators.
# | x y select y's that are descendants of x's
# x > y select y's that are direct children of x's
# .x select files with extension X
# :selector select things of a given class (these match Perl file operators, listed in perlfunc (1perl))
# So, for example, here's how you might go about doing some basic things (I assume you've named this script $ because you're a die-hard jQuery user):
# | $ '/usr/lib .pl' print the name of all Perl files that are descendants of /usr/lib
# $ './ .js' print the name of all Javascript files that are descendants of the current directory
# $ .js same as above
# $ :l print the name of all links that are descendants of the current directory
# $ :rwx print the name of all descendants of the current directory that you can read, write, and execute
# $ './.git refs:d' prints descendants of ./.git named 'refs' and which are directories
# Doing things.
# Once you've got a collection, you can do some things with it. Perlquery supports some methods that you can call on collections. For example:
# | $ .js .map 's/.js$//' prints the name of all javascript files without their extensions
# $ .js .grep '/[A-Z]/' prints the name of all javascript files whose name contains a capital letter
# $ .js .each awk '{print $1}' executes "awk '{print $1}'" on each file individually, building a new collection of the results
# $ .js .all awk '{print $1}' executes "awk '{print $1}'" on all files at once (by passing each filename as a separate argument), building a new collection of the resulting lines
# $ .js .eachi vim executes "vim" on each file interactively -- that is, with stdout and stdin piped to the terminal normally
# $ .js .alli vim executes "vim" on all of the files at once interactively -- that is, with stdout and stdin piped to the terminal normally
# Methods would be lame if they didn't compose, so of course they do:
# | $ .js .map 's/.js$//' .each echo echoes the name of each javascript descendant of the current directory, but without its extension
use Cwd qw/cwd/;
use File::Find qw/find/;
sub strip {$_[0] =~ s/^\s*(.*?)\s*$/\1/; $_[0]}
sub functional_find {my ($f, @directories) = @_;
my @result;
find {wanted => sub {push @result, $_ if &$f($_)}, no_chdir => 1}, @directories;
@result}
sub sub_for {eval "sub {$_[0]}"}
sub sub_for_noun {return sub{1} if $_[0] eq '*';
my @parts = grep length, split /(:[^:\.]+|\.(?![\/\.])[^:\.]+)/, join '', @_;
s/\//\\\//g for @parts;
$parts[0] = "/^(.*\\/)?$parts[0]([^a-z\\/][^\\/]*)?\$/" unless $parts[0] =~ /^[:\.](?![\/\.])/;
@parts = map /^:(.*)/ ? (map("-$_", grep /[a-z]/, split('', $1)), map("!-" . lc($_), grep /[A-Z]/, split('', $1))) : $_, @parts;
@parts = map /^\.[^\/\.]/ ? "/\\$_(?![a-zA-Z0-9])/" : $_, @parts;
eval "sub {\$_ = \$_[0] if \@_; " . join('&&', @parts) . "}"}
my %methods = (map => sub {my ($self, @args) = @_; my $f = sub_for join ' ', @args; my $x; [map {($x = &$f($_)) eq 1 || $x eq '' ? $_ : $x} @$self]},
grep => sub {my ($self, @args) = @_; my $f = sub_for join ' ', @args; [grep {&$f($_)} @$self]},
log => sub {my ($self, @args) = @_; my $count = @$self; my $name = $args[0] // 'log'; print STDERR "$name: $count entries\n"; $self},
each => sub {my ($self, @args) = @_; my @quoted = map "'$_'", @args; [map strip(join '', qx/@quoted '$_'/), @$self]},
all => sub {my ($self, @args) = @_; my @quoted = map "'$_'", @args, @$self; [split /\n/, join '', qx/@quoted/]},
eachi => sub {my ($self, @args) = @_; my @quoted = map "'$_'", @args; system("@quoted '$_'") for @$self; $self},
alli => sub {my ($self, @args) = @_; my @quoted = map "'$_'", @args, @$self; system("@quoted"); $self},
test => sub {my ($self, @args) = @_; my @quoted = map "'$_'", @args; [grep !system("@quoted '$_'"), @$self]},
detect => sub {my ($self, @args) = @_; my @quoted = map "'$_'", @args; !system("@quoted '$_'") and return [$_] for @$self},
at => sub {my ($self, @args) = @_; [@$self[@args]]},
first => sub {my ($self, @args) = @_; [@$self[0 .. ($args[0] || 1) - 1]]},
uniq => sub {my ($self) = @_; my %keys; $keys{$_} = 1 for @$self; [sort keys %keys]},
size => sub {my ($self) = @_; [scalar @$self]},
parent => sub {my ($self) = @_; [map {s/\/[^\/]+$//, $_} @$self]});
sub evaluate_receiver {my ($x) = @_;
return [$x] if -e $x && $x !~ /^[:\.](?![\/\.])/;
[sort(functional_find(sub_for_noun($x), cwd))]}
sub evaluate {my ($lhs, $operator, $rhs) = @_;
my $f = sub_for_noun $rhs;
return [sort map(grep(!/\/\.{1,2}$/ && &$f(), <$_/*>, <$_/.*>), @$lhs)] if $operator eq '>';
return @$lhs ? [sort(functional_find($f, @$lhs))] : [] if $operator eq ''}
sub selector {sub is_noun {$_[0] !~ /^[>]?$/}
my ($receiver, $text) = @_;
my @tokens = map strip($_), split /(\s+[>]\s+|\s+)/, $text;
$receiver //= evaluate_receiver shift @tokens if is_noun $tokens[0];
$receiver = evaluate($receiver, $tokens[$_], $tokens[$_ + 1]) for map $_ << 1, @tokens > 1 ? 0 .. ($#tokens >> 1) : ();
$receiver}
my ($selector, @xs) = @ARGV;
my $selection = selector undef, $selector;
while (@xs) {
my ($m, @arguments) = shift @xs;
$m =~ s/^\.//;
push @arguments, shift @xs while @xs && !exists $methods{substr($xs[0], 1)};
unshift @arguments, $m and $m = 'alli' unless exists $methods{$m};
my $f = $methods{$m};
$selection = &$f($selection, @arguments)}
print map("$_\n", @$selection);
# Generated by SDoc