#!/usr/bin/perl
use lib "$ENV{'HOME'}/perl", "$ENV{'HOME'}/libp/perl", "$ENV{'HOME'}/lib/perl",
"$ENV{'HOME'}/libp", "$ENV{'HOME'}/lib";
$default_vshnucfg = '';
$debug = 0;
$debug_ch = 0;
($VNAME, $VERSION) = qw(vshnu 1.0500);
$tmpcwd = (! defined $ENV{'VSHNUTMP'}) ? '' :
(($ENV{'VSHNUTMP'} ne '') ? $ENV{'VSHNUTMP'} : '/tmp') .
(($ENV{'VSHNUCWD'} ne '') ? "/$ENV{'VSHNUCWD'}" : "/vsh$$");
$tmpenv = (! defined $ENV{'VSHNUTMP'}) ? '' :
(($ENV{'VSHNUTMP'} ne '') ? $ENV{'VSHNUTMP'} : '/tmp') .
(($ENV{'VSHNUENV'} ne '') ? "/$ENV{'VSHNUENV'}" : "/env$$");
$tmpcwd =~ s:/+:/:g; $tmpenv =~ s:/+:/:g;
require 5.002;
use Config;
use English '-no_match_vars';
use Getopt::Std; $Getopt::Std::STANDARD_HELP_VERSION = 1;
use Sys::Hostname;
eval 'use Data::Dumper';
eval 'use Filesys::DiskFree';
eval 'use MIME::Types';
eval 'use Mail::Cap';
require Term::Screen;
use Term::ANSIColor;
use Term::ReadLine;
$usage = "usage: $0 [ -v | -V ]
$0 [ -c code | -C code ] [ -k keys | -K keys ]
[ -f file ... | [ -- ] dir ... ]
-v just print the version number of $VNAME
-V just print the versions list of $VNAME components
-c $VNAME perl code to run at startup
-C $VNAME perl code to run at startup, then exit
-k string of raw keystrokes to emulate at startup
-K string of raw keystrokes to emulate at startup, then exit
-f all remaining arguments are initially chosen files
By default, arguments are the initial directory and directory history.
Version $VERSION\n";
die $usage if ! getopts('hvVc:C:k:K:f') || $opt_h;
print("$VERSION\n"), exit if $opt_v;
die "$0: stdin not a tty\n" unless -t;
sub HELP_MESSAGE { select $_[0]; print $usage; }
sub VERSION_MESSAGE { select $_[0]; print "$VERSION\n"; }
$disksgvfs = 0;
$file_i = `file -Lib /etc/passwd 2> /dev/null` =~ /^text/i;
$mimetypes = (defined $MIME::Types::VERSION) ? new MIME::Types : undef;
&winch_off();
$rl = new Term::ReadLine 'vshnu' or &quit("$0: can't create readline ($!)");
&winch_on();
($rlmodule = $rl->ReadLine) =~ s/.*Term::ReadLine:://;
$rl->ornaments(0) if $rlmodule =~ /^Stub/i;
$rl->add_defun('insert-vshnu', \&rl_insert_vshnu) if $rlmodule eq 'Gnu';
@rlhist_ = @rlhist_shell = @rlhist_junk = @rlhist_file = ();
sub rl_insert_vshnu {
&home(), $scr->clreos() if ref $$insertcmd[0];
my $text = join(' ', "e(eval { &cmdeval($insertcmd) }));
$rl->insert_text($text . ' ') if $text ne '';
$rl->forced_update_display if ref $$insertcmd[0];
}
sub rl_bind_insert_vshnu {
return unless $rlmodule eq 'Gnu';
$rl->parse_and_bind("$_[0]: insert-vshnu");
}
@versions = (
'perl' => "$Config{'version'} $Config{'archname'}",
'Getopt::Std' => $Getopt::Std::VERSION,
'Sys::Hostname' => $Sys::Hostname::VERSION,
'Data::Dumper' => $Data::Dumper::VERSION
|| 'NOT INSTALLED',
'Filesys::DiskFree' => $Filesys::DiskFree::VERSION
|| 'NOT INSTALLED',
'MIME::Types' => $MIME::Types::VERSION
|| 'NOT INSTALLED',
'Mail::Cap' => $Mail::Cap::VERSION
|| 'NOT INSTALLED',
'Term::Screen' => $Term::Screen::VERSION,
'Term::ANSIColor' => $Term::ANSIColor::VERSION,
'Term::ReadLine' => $rlmodule,
$rl->ReadLine => $rl->ReadLine->VERSION,
($rlmodule ne 'Gnu') ? () :
('GNU Readline Library' => $rl->Attribs->{'library_version'}),
'ReadLine Features' => join(' ', sort keys %{$rl->Features}),
$VNAME => $VERSION);
%versions = @versions;
do { my $n = 1; @versions = grep { $n++ % 2 } @versions };
sub addversions {
while (@_) {
push(@versions, $_[0]), $versions{$_[0]} = $_[1]
unless exists $versions{$_[0]};
shift; shift;
}
}
sub versions {
my @v = (@_) ? @_ : @versions;
my $fmt = '%' . &max(map { length($_) } @v) . 's %s';
join("\n", map { sprintf($fmt, $_, $versions{$_}) } @v) . "\n";
}
print(&versions()), &quit() if $opt_V;
$getch = $ch = $ch_list = $err = $stty_cooked = $stty_raw = '';
$cooked = $getch_only = 0;
&sttyfix(1);
$scr = new Term::Screen or &quit("$0: cannot create screen ($!)");
&sttyfix();
$scr->noecho();
&sigs_on();
$ncolors = $scr->{TERM}->{_Co};
$color = $ncolors > 1;
$bold = $scr->{TERM}->Tputs('md', 1);
$reverse = $scr->{TERM}->Tputs('mr', 1) ||
$scr->{TERM}->Tputs('so', 1);
$normal = $scr->{TERM}->Tputs('me', 1) ||
$scr->{TERM}->Tputs('se', 1);
if (%Term::ANSIColor::ATTRIBUTES) {
$colornum = \%Term::ANSIColor::ATTRIBUTES;
$colorname = \%Term::ANSIColor::ATTRIBUTES_R;
} else {
$colornum = \%Term::ANSIColor::attributes;
$colorname = \%Term::ANSIColor::attributes_r;
}
$aubeep = $scr->{TERM}->Tputs('bl', 1) || "\a";
$vibeep = $scr->{TERM}->Tputs('vb', 1);
$user = &uid2name($>);
$hostname = $ENV{'HOST'} || $ENV{'HOSTNAME'} ||
eval { &hostname } || 'UNKNOWN';
($host = $hostname) =~ s/\..*//;
$userhost = "$user\@$host";
$depth = 1;
%keymap_ = ("\034" => ['last', 'quit $VNAME']);
&setnorun('off'); &longlen('min'); $long = 0; &longtrunc();
require($vshnucfg = $ENV{'VSHNUCFG'} || $default_vshnucfg ||
((-f "$ENV{'HOME'}/.vshnucfg") ? "$ENV{'HOME'}/.vshnucfg"
: 'vshnucfg.pl'));
&typemap('', 1); &keymap('', 1); &mousemap('', 1);
&initopts();
$hostr = (defined &hostr) ? &hostr($hostname) : $hostname;
$userhostr = "$user\@$hostr";
$mouse = &mouse($forcemouse ? 1 : ());
$scr->def_key('mous', $mouse) if $mouse;
($Button, $Brow, $Bcol) = (undef) x 3;
&mousemode($moused = ($initmouse =~ /^on/i) ? 1 : 0);
$mail = -f $mailbox;
$dotdotdot ||= '...';
@cdhist = @cdhist || map({'ls' => $_}, $opt_f ? () : @ARGV);
$pwd = (@cdhist) ? $cdhist[0]{'ls'} : &pwd();
$pwd ne '' && &cd($pwd) or &quit("$0: cannot cd '$pwd'\n");
undef $pwd;
&choose(@ARGV) if $opt_f;
if ($insertkey ne '') {
&rl_bind_insert_vshnu($insertkey);
&mapadd('keymap_', ":$insertkey",
$insertcmd) if $insertcmd;
}
require 'dumpvar.pl' if $debug;
&win();
&myeval($opt_c) if $opt_c;
&myeval($opt_C), &quit() if $opt_C;
$opt_k .= $opt_K, $getch_only = 1 if $opt_K;
$getch .= $opt_k;
while (1) {
$ch = (length($getch) > 0) ? do { $getch =~ s/^.//; $& } :
($getch_only) ? &quit()
: $scr->getch();
$scr->flush_input();
$ch_list = &scrtruncr($ch_list . ((length($ch) > 1) ? " $ch" :
sprintf(' 0%o', ord $ch))) if $debug_ch;
$cmd = &keymapcmd();
$cdhistp = 0 unless grep { /\bcdhist\b/ } &cmdstrs($cmd);
&cmdeval($cmd);
&win_err() if $err ne '';
}
&quit();
sub keymapcmd {
my $map = $keymap;
eval "\$map = \\\%keymap_$_[0]" if defined $_[0];
my $c = (defined $_[1]) ? $_[1] : $ch;
(exists $$map{$c}) ? $$map{$c} : $$map{''};
}
sub cmdeval {
my($cmd, $key) = @_;
&echo(&helpstr($ch, '', ($ch eq 'mous') ? $mousemaptab : 8, $cmd,
($ch eq 'mous') ? \&c12mev : '', $key)), &ret(),
$norun eq 'once' && &setnorun('off'), &win(), return
if $norun &&
grep { ! /\b(cmdeval|dotype(in)?|setnorun|domouse)\b/ }
&cmdstrs($cmd);
$cmd = &$cmd() if ref $cmd eq 'CODE';
return &myeval($cmd) unless ref $cmd;
return &myeval($$cmd[0]) unless ref $$cmd[0];
&myeval(&cmdprompt($txt_cmdprompt || 'Choice:', $cmd, $key));
}
sub keymap { &pushmap('key', @_) }
sub typemap { &pushmap('type', @_) }
sub mousemap { &pushmap('mouse', @_) }
sub pushmap {
my $xxx = shift;
my $_0 = $_[0]; $_0 =~ s/^[=!*]*//;
my $flg = $&; my $m = '';
my $map = eval "\\\@${xxx}map";
return if $flg =~ /=/ && $_0 eq $$map[$#$map];
($flg =~ /!/) ? do { push(@$map, $m = $_0) } :
($_0 ne '' && $_0 eq $$map[$#$map] ||
! defined $_[0]) ? do { pop(@$map); $m = $$map[$#$map] } :
($_0 eq '') ? do { @$map = () } :
($flg =~ /\*/) ? do { pop(@$map); push(@$map, $m = $_0) } :
push(@$map, $m = $_0);
eval "\$${xxx}map = \\\%${xxx}map_$m";
eval "\$a${xxx}map = \\\@${xxx}map_$m" if $xxx eq 'type';
&win_time(), &home() unless $_[1];
}
sub cmdstrs {
my $c = shift;
$c = &$c() if ref $c eq 'CODE';
(! ref $c) ? ($c) : (! ref $$c[0]) ? ($$c[0]) : map { $$_[0] } @$c;
}
sub setnorun {
$norun = ($_[0] eq 'toggle') ? ! $norun :
($_[0] eq 'once') ? 'once' :
($_[0] eq 'on') ? 1 : 0;
}
sub mapadd {
my($map, $key, $val, $before, $del) = @_;
my($hmap, $amap) = eval "(\\\%$map, \\\@$map)";
delete $$hmap{$key}, @$amap = grep { $_ ne $key } @$amap if $del;
return if $del < 0 || exists $$hmap{$key};
$$hmap{$key} = $val;
return unless @$amap || (keys %$hmap) + 0 == 1;
my $n = ($before =~ s/^<//) ? 0 : ($before =~ s/^>//) ? 1 : 0;
splice(@$amap, &max(0, &aindex($before, @$amap) + $n), 0, $key);
}
sub mapdeladd { &mapadd(@_[0 .. 3], 1) }
sub mapdel { &mapadd(@_[0 .. 3], -1) }
sub mapget {
my($map, $key, $idx) = @_;
my($hmap) = eval "\\\%$map";
return $$hmap{$key}[$idx] if defined $idx;
$$hmap{$key};
}
sub mapset {
my($map, $key, $val, $idx) = @_;
my($hmap) = eval "\\\%$map";
return $$hmap{$key}[$idx] = $val if defined $idx;
$$hmap{$key} = $val;
}
sub maporder {
my($map) = @_;
my($hmap, $amap) = eval "(\\\%$map, \\\@$map)";
my(@map) = (@$amap && ! &opt('k')) ? @$amap
: sort bykeyorder keys %$hmap;
map { ($_, $$hmap{$_}) } @map;
}
sub bykeyorder { ($b eq '') ? -1 : ($a eq '') ? 1 :
($a =~ /^TTL/ && $b =~ /^TTL/) ? $a cmp $b :
($a =~ /^TTL/) ? -1 : ($b =~ /^TTL/) ? 1 :
(length($a) == 1 && length($b) != 1) ? -1 :
(length($a) != 1 && length($b) == 1) ? 1 : $a cmp $b }
sub winat { &win(($_[0]) x 3) }
sub win {
$time = time;
&ls(); &lscolors();
$filerows = &min($#ls + 1, $scr->{ROWS} - 4);
$pages = ($filerows) ? &ceil(($#ls + 1) / $filerows) : 0;
$havefilecols = &min($pages, int($scr->{COLS} / ($minfilelen + 4)));
&filecols(); &longlen();
$filecols = &min($havefilecols, ($long) ? 1 :
($maxfilecols > 0) ? $maxfilecols : 1024);
$longlen = &max(0, &min($minlonglen,
$scr->{COLS} - $minfilelen - 5));
$filelen = int(($scr->{COLS} - (($long) ? $longlen + 1 : 0)) /
($filecols || 1)) - 4;
&page(@_);
@lstable = ();
foreach ($filecol .. $filecol + $filecols - 1) {
my @col = @ls[$_ * $filerows .. ($_ + 1) * $filerows - 1];
push(@lstable, \@col);
}
my $endc = &min($filecol + $filecols, $pages);
my $ptxt = ($filecol <= 0 && $pages <= $filecols) ? '' :
($filecol + 1 == $endc) ? "$endc/$pages" :
($filecol + 1) . "-$endc/$pages";
$scr->clrscr();
&setsm();
my @z = &win_decor("$userhost:", $cwd, $ptxt, 0);
&setsm(@z[0], $scr->{COLS} - 1 - (4 + $minfilelen), 4 + $minfilelen,
[$$mousemap{'page'}, \$ptxt]) if $ptxt eq '';
&setsm(@z[0, 1, 2], [$$mousemap{'user'}, \$userhost]);
&setsm(@z[0, 3, 4], [$$mousemap{'dir'}, \$cwd]);
&setsm(@z[0, 5, 6], [$$mousemap{'dir...'}, \$cwd]);
&setsm(@z[0, 7, 8], [$$mousemap{'dir'}, \$cwd]);
&setsm(@z[0, 9, 10], [$$mousemap{'page'}, \$ptxt]);
&win_row2();
%drawn = (); &setcdhist('file0', '');
$scr->at(2, 0);
foreach my $row (0 .. $filerow - 1) {
my $col = 0; my $file; my $out = '';
foreach (@lstable) {
last if ($file = $_->[$row]) eq '';
$drawn{$file} = [$row, $col];
my($s, $sv, $g, $l) = &viewfile($file, $filelen);
my $t = ' ' x $filelen;
substr($t, 0, $l) = $s;
$out .= ' ' . ((! $choose{$file}) ? ' ' :
&color($choose{$file}, $co_decor));
$out .= $t;
&setsm($row + 2, $col, 1,
[$$mousemap{'bag'}, \($_->[$row])]);
&setsm($row + 2, $col + 1, 1,
[$$mousemap{'point'}, \($_->[$row])]);
&setsm($row + 2, $col + 2, 1,
[$$mousemap{'chose#'}, \($_->[$row]),
$choose{$file}]);
&setsm($row + 2, $col + 3, $l,
[$$mousemap{'file'}, \($_->[$row])]);
my $p = &ceil(($filelen - length($g)
- length($dotdotdot)) / 2);
&setsm($row + 2, $col + 3 + $p, length($dotdotdot),
[$$mousemap{'file...'}, \($_->[$row])])
if $filelen == $l
&& $sv =~ /^.{$p}\Q$dotdotdot\E/;
&setsm($row + 2, $col + 2 + $l, 1,
[$$mousemap{'filetag'}, \($_->[$row]), $g])
if $g;
&setsm($row + 2, $col + 2 + $l - length($g), 1,
[$$mousemap{'file/'}, \($_->[$row])])
if $sv =~ /\\$/;
&setcdhist('file0', $file) if $file0 eq '';
$col += 4 + $filelen;
}
$out =~ s/^ //; $out =~ s/\s*$//;
print $out, "\n\r";
}
&win_bag(1);
&win_long() if $long;
&win_time();
&setsm($filerow + 3, undef, undef, [$$mousemap{'home'}]);
&win_err();
}
sub win_err {
&home();
&setsm() if &msgoverfull($err);
$scr->puts(&color($err, $co_error)), $err = '', return if $err ne '';
return unless $mail;
my $size = -s $mailbox;
&msg($txt_mail || 'You have mail') if $mail ne 'old' && $size;
&msg($txt_newmail || 'You have new mail')
if $mail eq 'old' && $size > $mailsize;
($mail, $mailsize) = ('old', $size);
}
sub win_row2 {
$where =~ s/^\s+$//;
my @bits = (); my $bits;
push(@bits, "depth=$depth") if $depth != 1;
push(@bits, "opts=" . &viewas(&opts()))
if %opts;
push(@bits, "where={$where}") if $where =~ /\S/ &&
! grep($altls == $_, \@choose, \@cdhist, \@dohist);
push(@bits, "long=$longlabel") if $longlabel;
push(@bits, "cols=$maxfilecols") if ! $long && $maxfilecols;
push(@bits, "mouse=" . ($moused ? 'on' : 'off'))
if $mouse &&
($moused xor $initmouse =~ /^on/i);
$bits = join(', ', @bits);
my @z = &win_decor('', $lstitle, $bits, 1);
&setsm($z[0]);
&setsm(@z[0], $scr->{COLS} - 1 - (4 + $minfilelen),
4 + $minfilelen, [$$mousemap{'state'}, \$bits])
if $bits eq '';
&setsm(@z[0], 0, 4 + $minfilelen, [$$mousemap{'title'}, \$lstitle])
if $lstitle eq '';
&setsm(@z[0, 3, 4], [$$mousemap{'title'}, \$lstitle]);
&setsm(@z[0, 5, 6], [$$mousemap{'title...'}, \$lstitle]);
&setsm(@z[0, 7, 8], [$$mousemap{'title'}, \$lstitle]);
&setsm(@z[0, 9, 10], [$$mousemap{'state'}, \$bits]);
}
sub win_time {
my @bits = (); my $bits;
push(@bits, 'run=OFF') if $norun;
push(@bits, $#choose + 1 . ' chosen') if @choose;
push(@bits, "keys=$keymap[$#keymap]") if $keymap[$#keymap] ne '';
push(@bits, "types=$typemap[$#typemap]") if $typemap[$#typemap] ne '';
push(@bits, "mouse=$mousemap[$#mousemap]")
if $mousemap[$#mousemap] ne '';
$bits = join(', ', @bits);
my @z = &win_decor('', $bits, &myctime($time, &opt('s')), $filerow + 2,
($long && $filelen + 5 + 57 <= $scr->{COLS})
? $filelen + 5 + 57 : '');
&setsm($z[0]);
&setsm(@z[0], 0, 4 + $minfilelen, [$$mousemap{'mode'}, \$bits])
if $bits eq '';
&setsm(@z[0, 3, 4], [$$mousemap{'mode'}, \$bits]);
&setsm(@z[0, 5, 6], [$$mousemap{'mode...'}, \$bits]);
&setsm(@z[0, 7, 8], [$$mousemap{'mode'}, \$bits]);
&setsm(@z[0, 9, 10], [$$mousemap{'time'}]);
&setsm($z[0], $z[9] + $z[10], 1, [$$mousemap{'time_'}]);
}
sub win_decor {
my($a, $b, $c, $r, $w) = @_; my @b = (); my $s;
($a, $b, $c) = (&view($a), &view($b), &view($c));
$w = $w || $scr->{COLS};
$scr->at($r, 0)->clreol();
if ($a ne '' || $b ne '') {
@b = &truncm($b, $w - length($a) - 1 -
(($c ne '') ? length($c) + 1 : 0));
$s = &color("$a$b[0]", $co_decor);
$s .= $b[1] . &color($b[2], $co_decor) if $#b > 0;
$scr->at($r, 0)->puts($s);
}
$scr->at($r, $w - length($c) - 1)->puts(&color($c, $co_decor))
if $c ne '';
my @r = ($r); local $i = 0;
my $colrange = sub { my $j = $i;
($j, do { $i += length($_[0]); length($_[0]) }) };
map { push(@r, &$colrange($_)) } $a, @b[0 .. 2];
$i = $w - length($c) - 1;
push(@r, &$colrange($c));
@r;
}
sub win_bag {
my $row = 0; my($key, $file, $qfile, $qkey);
my @keys = @bagkeys;
my $x = $bagrow * ($#bagkeys + 1);
my $y = ($bagcol - $filecol) * (4 + $filelen);
my @files = @{$lstable[$bagcol - $filecol]}[$x .. $x + $#keys];
my @keys2 = @keys; my @files2 = @files;
&setcdhist('file1', ''); $point = '';
&setcdhist('fileptr', $bagkeys[0])
unless grep($fileptr eq $_, @bagkeys);
map(&mapdel("keymap_$_", 'POINT'), keys %bagmap);
@usedbagkeys = @bagfiles = ();
while (@keys2 && @files2) {
last if ($file = shift @files2) eq '';
push(@usedbagkeys, $key = shift @keys2);
push(@bagfiles, $file) if $_[0];
$fileptr = $key if $file eq $pendptr;
}
&fileptr('+0'); undef $pendptr;
foreach (@usedbagkeys) {
($key, $file) = (shift @keys, shift @files);
($_[1]) ? $key eq $fileptr &&
($scr->at(2 + $x + $row, $y + 1)
->puts($_[0] ? '>' : ' '),
&setsmarg(2 + $x + $row, $y, 2, 3, $_[0]))
: ($scr->at(2 + $x + $row, $y)
->puts(($_[0] ? &color($key, $co_decor) : ' ')
. ($_[0] && $key eq $fileptr ? '>' : ' ')),
&setsmarg(2 + $x + $row, $y, 2,
2, $_[0] ? $key : '',
$_[0] && $key eq $fileptr));
$row++;
($qfile, $qkey) = (&evalquote($file), &evalquote($key));
$qkey =~ s/^'?/$&\\/;
my $fill = sub { my @__ = @_;
grep { s/<FILE>/$qfile/g; s/<KEY>/$qkey/g; 1 } @__ };
foreach (keys %bagmap) {
my $act = $bagmap{$_};
$act = &$act() if ref $act eq 'CODE';
$act = (! ref $act) ? [&$fill($act), ''] :
(! ref $$act[0]) ? [&$fill(@$act)] :
[map { [&$fill(@$_)] } @$act];
&mapdeladd("keymap_$_", 'POINT', $_[0] ? $act : undef)
if $key eq $fileptr;
&mapdeladd("keymap_$_", $key, $_[0] ? $act : undef);
}
$point = $file if $key eq $fileptr && $_[0];
&setcdhist('file1', $file) if $file1 eq '';
}
&setcdhist('file1', $point) if $point ne '';
foreach $key (@keys) {
map { &mapdeladd("keymap_$_", $key,
eval($nobag{"$_:$key"} || $nobag{"$_:"} ||
$nobag{ ":$key"} || $nobag{''} ||
'undef')) } keys %bagmap;
}
}
sub win_choose {
my($x, $y);
foreach (@_) {
next unless $drawn{$_};
($x, $y) = @{$drawn{$_}};
$scr->at($x + 2, $y + 2)->puts(($choose{$_} eq '') ? ' ' :
&color($choose{$_}, $co_decor));
&setsmarg($x + 2, $y + 2, 1, 2, $choose{$_});
}
&win_time();
}
sub win_long {
my($row, $zone, $i) = (2, 'long', 0);
&win_row2() if shift;
if ($long =~ /(^\d+$|\$_\b)/) {
$zone = 'longls' if $long =~ /^\d+$/;
foreach (@{$lstable[0]}) {
my($l) = &long($longlen, $_);
my($s) = &decolor($l);
&setsm($row, $filelen + 4);
&setsm($row, $filelen + 4, length($s),
[$$mousemap{$zone}, \$_, \$s]);
$scr->at($row++, $filelen + 4)->clreol()->puts($l);
}
} else {
foreach (&long($longlen, @{$lstable[0]})) {
my($s) = &decolor($_);
&setsm($row, $filelen + 4);
&setsm($row, $filelen + 4, length($s),
[$$mousemap{$zone}, \${$lstable[0]}[$i++], \$s]);
$scr->at($row++, $filelen + 4)->clreol()->puts($_);
}
}
}
sub home {
$scr->at($filerow + 3, 0)->clreol();
$scr->puts(&scrtruncr($ch_list))->at($filerow + 3, 0) if $debug_ch;
}
sub msg {
&home();
&setsm() if &msgoverfull(@_);
$scr->puts(&color(join(' ', @_), $co_msg))->clreol();
}
sub msgoverfull {
local $_ = join(' ', @_);
s/\t/' ' x 8/egs;
s/\n/' ' x $scr->{COLS}/egs;
length >= ($scr->{ROWS} - ($filerow + 3)) * $scr->{COLS};
}
sub viewfile {
my($file, $n) = @_;
my $f; my @f = (); my $tag = '';
$tag = &tag($file) if &opt('T');
$n-- if $tag;
$f = &view($file);
$f =~ s/[\040\240]+$/join('', map { sprintf('\\%03o', ord($_)) }
split(\/\/, $&))/e;
$f = ($f =~ /\//) ? join('', @f = &truncm($f, $n)) : &trunc($f, $n)
if length($f) > $n;
((&opt('C') ? &colorfile($file, $f, @f) : $f) . $tag,
$f, $tag, length($f . $tag));
}
sub setsm {
undef %screenmap, return unless @_;
return unless $mouse && $moused;
my($row, $col, $n, $val) = @_;
$col = 0 unless defined $col;
$n = $scr->{COLS} - $col unless defined $n;
return if $val && ! $$val[0];
foreach ($col .. $col + $n - 1) {
delete $screenmap{join(',', $_ + 0, $row + 0)}, next
unless defined $val;
$screenmap{join(',', $_ + 0, $row + 0)} = $val;
}
}
sub setsmarg {
return unless $mouse && $moused;
my($row, $col, $n, $i, @v) = @_;
foreach ($col .. $col + $n - 1) {
@{$screenmap{join(',', $_ + 0, $row + 0)}}[$i .. $i+$#v] = @v;
}
}
sub scrtruncr {
substr(' ' x $scr->{COLS} . join('', @_),
-($scr->{COLS} - 1), $scr->{COLS});
}
sub bag {
&win_bag(0); &page('', @_); &win_bag(1); &home();
}
sub rebag {
&win_bag(0); @bagkeys = @_; &page(); &win_bag(1); &home();
}
sub columns {
&filecols(@_); &win();
}
sub point {
return &fileptr() unless @_;
&win_bag(0, 1); &fileptr(@_); &win_bag(1, 1); &home();
}
sub page {
my @args = @_; my %col = (); my %row = ();
@args = @pendpage unless @args; undef @pendpage;
@args = ($args[0], '', $args[1]) if $args[1] =~ /^[[\]{}]/;
local $_ = shift @args;
s/^([-+<>\[\]]?)#/$1$filecols/;
s/^([-+<>\[\]]?)\$/$1$pages/;
$filecol =
(/^$/) ? $filecol :
(s/^\+//) ? $filecol + $_ :
(s/^\-//) ? $filecol - $_ :
(s/^>//) ? ($filecol + $_) % ($pages || 1) :
(s/^]//) ? (($filecol + $_ >= $pages) ? 0 : $filecol + $_) :
(s/^<//) ? ($filecol - $_) % ($pages || 1) :
(s/^\[//) ? (($filecol == 0) ? $pages - ($pages % $_ || $_) :
($filecol - $_ < 0) ? 0 : $filecol - $_) :
(/^\d/) ? $_ - 1 :
(s/^\\?//) ? (($col{$_}, $row{$_}) = &pageto($_))[0] : 0;
$filecol = &max(0, &min($filecol, $pages - 1));
$filerow = ($filecol + 1 < $pages || $filerows == 0)
? $filerows : $#ls % $filerows + 1;
$_ = shift @args;
s/^([-+<>]?)#/$1$filecols/;
s/^([-+<>]?)\$/$1$pages/;
$bagcol =
(/^$/) ? $bagcol :
(s/^\+//) ? $bagcol + $_ :
(s/^\-//) ? $bagcol - $_ :
(s/^>//) ? ($bagcol + $_ - $filecol) %
(&min($filecols, $pages - $filecol) || 1) + $filecol :
(s/^<//) ? ($bagcol - $_ - $filecol) %
(&min($filecols, $pages - $filecol) || 1) + $filecol :
(/^\d/) ? $filecol + $_ - 1 :
(s/^\\?//) ? ((exists $col{$_}) ? $col{$_} :
(($col{$_}, $row{$_}) = &pageto($_))[0]) : 0;
$bagcol = &max($filecol, &min($bagcol,
&min($filecol + $filecols - 1, $pages - 1)));
$_ = shift @args;
s/^([-+<>]?)\$/$1$filerows/;
$bagrows = &ceil((($bagcol < $pages - 1 || $filerows == 0) ?
$filerow : $#ls % $filerows + 1)
/ ((@bagkeys) ? ($#bagkeys + 1) : 1));
$bagrow =
(/^$/) ? $bagrow :
(s/^\+//) ? $bagrow + $_ :
(s/^\-//) ? $bagrow - $_ :
(s/^>//) ? ($bagrow + $_) % ($bagrows || 1) :
(s/^<//) ? ($bagrow - $_) % ($bagrows || 1) :
(s/^]//) ? return((! $bagrows) ? 0 : &page('',
'>' . int(($bagrow + 1) / $bagrows),
($bagrow + 1) % $bagrows + 1)) :
(s/^\[//) ? return(&page('',
($bagrow) ? '<0' : '<1',
($bagrow) ? $bagrow : "+$filerows")) :
(/^\d/) ? $_ - 1 :
(s/^\\?//) ? ((exists $row{$_}) ? $row{$_} :
(&pageto($_))[1]) : 0;
$bagrow = &max(0, &min($bagrow, $bagrows - 1));
}
sub pageto {
my $p = -1;
foreach (@ls) {
$p++;
last if $_ ge $_[0];
}
($filerows ? int($p / $filerows) : 0,
int(($filerows ? $p % $filerows : 0)
/ (@bagkeys ? ($#bagkeys + 1) : 1)));
}
sub filecols {
local $_ = shift;
$maxfilecols =
(/^$/) ? $maxfilecols :
(s/^\+//) ? (($maxfilecols > 0) ? $maxfilecols + $_ : 0) :
(s/^\-//) ? &max(1, (($maxfilecols > 0) ? $maxfilecols
: $havefilecols) - $_) :
(s/^>//) ? ($maxfilecols + $_) % ($havefilecols || 1) :
(s/^<//) ? ($maxfilecols - $_) % ($havefilecols || 1) :
(/^\d/) ? $_ : 0;
$maxfilecols = &max(0, &min($maxfilecols, $havefilecols));
}
sub fileptr {
local $_ = shift;
s/^([-+<>]?)\$/$1$#usedbagkeys/;
return &cmdeval($$keymap{'POINT'}) if /^$/;
my $n = &aindex($fileptr, @bagkeys);
$n = 0 if $n < 0;
$fileptr =
(s/^\+//) ? $usedbagkeys[&min($n + $_, $#usedbagkeys)] :
(s/^\-//) ? $usedbagkeys[&max(0, $n - $_)] :
(s/^>//) ? $usedbagkeys[($n + $_) % ($#usedbagkeys + 1 || 1)] :
(s/^<//) ? $usedbagkeys[($n - $_) % ($#usedbagkeys + 1 || 1)] :
(s/^\\?//) ? $_ : $_;
$fileptr = $usedbagkeys[$#usedbagkeys]
if &aindex($fileptr, @usedbagkeys) < 0;
&setcdhist('fileptr', $fileptr);
}
sub longlen {
local $_ = shift;
my($min, $max) = (57, $scr->{COLS} - $minfilelen - 5);
$_ = ($minlonglen <= $min) ? 'max' : 'min' if /^t/i;
$minlonglen =
(/^$/) ? $minlonglen :
(/^\+(.*)%/) ? $minlonglen + int(($max - $min) * $1 / 100 + .5) :
(/^\-(.*)%/) ? $minlonglen - int(($max - $min) * $1 / 100 + .5) :
(s/^\+//) ? $minlonglen + $_ :
(s/^\-//) ? $minlonglen - $_ :
(/^max/i) ? $max :
(/^min/i) ? $min :
(/^\d/) ? $_ + 0 : $min;
$minlonglen = ($minlonglen < $min) ? $max :
($minlonglen > $max) ? $min : $minlonglen if /r$/i;
$minlonglen = &max(0, $minlonglen);
}
sub tag {
if (-l $_[0]) { return '@' }
elsif (-f _) { return '*' if (lstat(_))[2] & 0111 }
elsif (-d _) { return '/' }
elsif (-S _) { return '=' }
elsif (-p _) { return '|' }
elsif (-b _) { return '#' }
elsif (-c _) { return '%' }
elsif (! -e $_[0]) { return '?' }
'';
}
sub color {
my $s = shift; my $c = join(' ', grep(/\S/, @_));
return $s if $s eq '' || $c !~ /\S/ || ! &opt('*');
return &colored($s, $c) if $color;
($c eq 'bold') ? $bold . $s . $normal :
($c eq 'reverse') ? $reverse . $s . $normal : &colored($s, $c);
}
sub decolor {
my @r = @_;
foreach (@r) { s/\e\[[^m]*m//gs }
$#r ? @r : shift @r;
}
sub rl_prompt_mark_ignore {
return $_[0] unless $rlmodule eq 'Gnu' &&
$_[0] ne '' && $_[0] =~ /^(.*)\Q$_[1]\E(.*)$/;
(($1 ne '') ? "\001$1\002" : '') . $_[1] .
(($2 ne '') ? "\001$2\002" : '');
}
sub colorfile {
my($file, $f, @f) = @_;
$f = $file if $f eq '';
return &color($f, &filecolor($file)) unless $file =~ /\//;
$f =~ /.*\//, @f = ($&, '', $')
if $file =~ s:/:/:g eq $f =~ s:/:/:g || $f[2] =~ /\//;
&color($f[0], &num2color($lscolors{'di'})) . $f[1] .
&color($f[2], &filecolor($file));
}
sub filecolor {
my $file = shift; my $c = '';
if (-l $file) { $c = 'ln' }
elsif (-f _) { $c = 'ex' if ! &opt('x') && (lstat(_))[2] & 0111 }
elsif (-d _) { $c = 'di' }
elsif (-S _) { $c = 'so' }
elsif (-p _) { $c = 'pi' }
elsif (-b _) { $c = 'bd' }
elsif (-c _) { $c = 'cd' }
elsif (! -e $file) { $c = 'mi' }
return &num2color($lscolors{$c}) if $c;
$c = (sort bylengthr grep(s/^\*// && substr($file, -length($_)) eq $_,
keys %lscolors))[0];
return &num2color($lscolors{"*$c"}) if $c ne '';
&num2color($lscolors{(-f _) ? 'fi' : 'no'});
}
sub bylengthr { length($b) <=> length($a) }
sub num2color {
join(' ', map { $$colorname{$_ + 0} } split(/;/, join(';', @_)));
}
sub lscolors {
%lscolors = ();
foreach (split(/:/, ($ENV{'LS_COLORS'} || $ENV{'LS_COLOURS'})
. ($ENV{'LS_COLORS2'} || $ENV{'LS_COLOURS2'})
. ($ENV{'LS_COLORS3'} || $ENV{'LS_COLOURS3'}))) {
next if $_ eq '';
my($k, $v) = split(/=/, $_, 2);
$lscolors{$k} = $v;
}
%lscolors;
}
sub colorperms {
my($t, $ur, $uw, $ux, $gr, $gw, $gx, $or, $ow, $ox) = split(//, shift);
my($uid, $gid) = @_;
my($co_u, $co_g, $co_o, $co); $co_u = $co_g = $co_o = $co_perms;
my $co_w = ($t eq 'l') ? '' : $co_write;
$ur = "$ur$uw";
$t = &color($t, $co_ftype) if $co_ftype;
if ($> == 0 || $> == $uid) {
$co_u = $co_myper if $>;
$gw = &color($gw, $co)
if $co = ($gw eq 'w' && $co_w) ? $co_w : $co_g;
$ow = &color($ow, $co)
if $co = ($ow eq 'w' && $co_w) ? $co_w : $co_o;
} elsif (grep($gid == $_, split(/\s+/, $) ))) {
$co_g = $co_myper;
$gw = &color($gw, $co_g) if $co_g;
$ow = &color($ow, $co)
if $co = ($ow eq 'w' && $co_w) ? $co_w : $co_o;
} else {
$co_o = $co_myper;
$gw = &color($gw, $co_g) if $co_g;
$ow = &color($ow, $co_o) if $co_o;
}
$ur = &color($ur, $co_u) if $co_u;
$gr = &color($gr, $co_g) if $co_g;
$or = &color($or, $co_o) if $co_o;
$ux = &color($ux, $co)
if $co = ($ux =~ /[st]/i && $co_sbits) ? $co_sbits : $co_u;
$gx = &color($gx, $co)
if $co = ($gx =~ /[st]/i && $co_sbits) ? $co_sbits : $co_g;
$ox = &color($ox, $co)
if $co = ($ox =~ /[st]/i && $co_sbits) ? $co_sbits : $co_o;
"$t$ur$ux$gr$gw$gx$or$ow$ox";
}
sub colorkey {
local $_ = join('', @_);
return $_ unless &opt('H');
return &color($_, $co_ckey) if $co_ckey && /^\^./;
return &color($_, $co_nkey) if $co_nkey && /^\\./;
return &color($_, $co_wkey) if $co_wkey && /^<.*>$/;
return &color($_, $co_0key) if $co_0key && /^\d$/;
return &color($_, $co_Akey) if $co_Akey && /^[A-Z]$/;
return &color($_, $co_akey) if $co_akey && /^[a-z]$/;
($co_key) ? &color($_, $co_key) : $_;
}
sub colorcmd {
local $_ = join('', @_);
return &color($_, &opt('H') ? $co_desc : ()) if s/^\\\\?//;
return $_ unless &opt('H');
my $re = join('|', @tail); my $tail = '';
my $com = (s/(^|\s)(#.*)/$1/) ? $2 : '';
eval { $tail = ($re && s/((^|;)\s*)((($re)\s*(;|$)\s*)+)$/$1/)
? $3 : '' }; &err($@) if $@;
$com = &color($com, $co_com) if $co_com && $com ne '';
$tail = &color($tail, $co_tail) if $co_tail && $tail ne '';
$_ = &color($_, $co_cmd) if $co_cmd && $_ ne '';
"$_$tail$com";
}
sub colorlong {
local $_ = join('', @_); my $s;
($s = &cfgcolorlong($_)) ne '' && ($_ = $s) if defined &cfgcolorlong;
$_ = &colordiskspace($_) if $long =~ /^\s*;.*diskspace/;
s/(^\\|\\$)/&color($&, $co_tail)/ge;
s/\b(error|warning|fail(ure|ed))\b[\t -~]*/&color($&, $co_error)/ige;
$_;
}
sub colorlongline {
local $_ = $_[0]; my $co = $_[1];
s/^(\\)?(.*?)(\\)?$/$1 . &color($2, $co) . $3/e;
$_;
}
sub dotypepath {
my $t = &untilde($_[0]);
return &dotype($t) if $t eq '' || $t =~ /^\// && -e $t;
&beep(), &win(), return if $t =~ /^\// && ! -e $t;
foreach ('', &histpaths(split(':', $ENV{'CD_PATH'}))) {
my $file = ((/\/$/) ? &untilde($_) :
(/./) ? &untilde($_) . '/' : '') . $t;
return &dotype($file) if -e $file;
}
&beep(); &win();
}
sub completetypepath {
my $fcf = $rl->Attribs->{'filename_completion_function'};
my @r = ();
foreach (($_[0] =~ /^[\/~]/) ? ('') :
('', &histpaths(split(':', $ENV{'CD_PATH'})))) {
my $head = (/\/$/) ? $_ : (/./) ? $_ . '/' : '';
push(@r, map { substr($_, length($head)) }
$rl->completion_matches($head . $_[0], $fcf));
}
@r;
}
sub histpaths {
&unique(@_, (map { $_->{'ls'} || () } @cdhist),
(map { /\/*[^\/]*\/*$/; $` || '/' } @dohist));
}
sub dotypein { &typemap('!' . shift); &dotype(@_); &typemap(); }
sub dotype {
local $_ = @_ ? shift : $_;
local( $_r, $_e, $_h, $_t, $_f, $_m, $_d );
local($_q, $_rq, $_eq, $_hq, $_tq, $_fq, $_mq, $_dq);
&set_x();
@dohist = ($_f, grep($_ ne $_f, @dohist)) unless -d;
my $max = eval $maxdohist;
splice(@dohist, $max) if $max >= 0;
foreach my $test (@$atypemap ? @$atypemap : sort keys %$typemap) {
return &cmdeval($$typemap{$test})
if $test && $test !~ /^TTL/ && eval &ext_syntax($test);
}
&cmdeval($$typemap{''});
}
sub set_x {
($_r = $_) =~ s/\.([^.]*)$//; $_e = $1;
(/\//) ? (($_h = $_) =~ s/\/([^\/]*)$//, $_t = $1) :
( $_h = '', $_t = $_);
$_f = &absfile($_);
$_m = &mimetype($_);
($_q, $_rq, $_eq, $_hq, $_tq, $_fq, $_mq) =
map { "e($_) } ($_, $_r, $_e, $_h, $_t, $_f, $_m);
$_d = ($_ eq '') ? '' : `file -L $_q 2> /dev/null`; chomp $_d;
$_dq = "e($_d);
}
sub ext { my $patt = join('|', @_); /\.($patt)$/i }
sub Ext { my $patt = join('|', @_); /\.($patt)$/ }
sub ext_syntax {
local $_ = join(' ', @_);
s/^([eE]xt) ([^\cA]*)$/$1 qw\cA$2\cA/ if ! /^[eE]xt\s+(['"]|qw\b)/;
$_;
}
sub choose {
&unchoose(@_), &win(), return if $altls == \@choose;
foreach (@_) {
next if $_ eq '';
push(@choose, $_);
$choose{$_} = &digit($#choose)
}
&win_choose(@_);
&home();
}
sub unchoose {
my $n = 0;
@unchosen = @_ if @_;
%choose = ();
&win_choose(@choose);
map(splice(@choose, $#choose - &aindex($_, reverse @choose), 1), @_);
map($choose{$_} = &digit($n++), @choose);
&win_choose(@choose);
&home();
}
sub rechoose {
&choose(@unchosen);
@unchosen = ();
}
sub choosebyn {
my $i = &undigit($_[0]);
&home(), return if $i < 0 || $i > $#choose;
&choose($choose[$i]), return if $altls != \@choose;
splice(@choose, $i, 1);
&choose();
}
sub grepls { &myeval("grep { $_[0] } \@ls") }
sub lsall { ($altls) ? @ls : grep { ! /^\.\.?$/ } @ls }
sub matchfiles { &grepls('/' . $_[0] . '/') }
sub untilde {
local $_ = $_[0];
! /^\~/ || s:^\~(\/|$):$ENV{'HOME'}$1:
|| s:^\~([^/]+):(getpwnam($1))[7] || $&:e;
$_;
}
sub atabsfile { "$userhostr:" . &absfile(@_) }
sub absfile {
my($f, $d) = @_;
return $f if $f =~ /^\//;
$d = $cwd if $d eq '';
$d . (($d =~ /\/$/) ? '' : '/') . $f;
}
sub remove {
my @bad;
foreach (@_) {
$! = 0;
(-l $_ || ! -d _) ? unlink $_ : rmdir $_;
push(@bad, "$_ ($!)") if $! + 0;
}
&err('Cannot remove', join(', ', @bad)) if @bad;
}
sub filecounts {
my($d, $f, $l, $e) = (0) x 4;
foreach (&lsall()) {
&opt('L') ? stat $_ : lstat $_;
(! -e _) ? $e++ : (! &opt('L') && -l _) ? $l++ :
( -d _) ? $d++ : $f++;
}
($d, $f, $l, $e);
}
sub filecount {
my @n = &filecounts();
join(', ', grep { ! /^0 / }
"$n[0] director" . (($n[0] == 1) ? 'y' : 'ies'),
"$n[1] file" . (($n[1] == 1) ? '' : 's'),
"$n[2] symlink" . (($n[2] == 1) ? '' : 's'),
"$n[3] non-existant");
}
sub cdpath {
local $_ = $_[0];
$_ = (ref eq 'HASH') ? $$_{'ls'} : (ref eq 'ARRAY') ? $$_[0] : $_;
return &cd($_[0]) if /^(\/|$)/;
my $pre = $err;
foreach my $dir ('', split(':', $ENV{'CD_PATH'})) {
$err = $pre, return $cwd if &cd(((/./) ? "$dir/" : '') . $_);
}
$err = $pre; &err("Cannot cd $_ in CD_PATH");
0;
}
sub cd {
local $_ = $_[0];
$_ = (ref eq 'HASH') ? $$_{'ls'} : (ref eq 'ARRAY') ? $$_[0] : $_;
return 1 if $_ eq '';
$_ = &untilde($_);
$cwd ||= &pwd(), $_ = &absfile($_) unless /^\//;
1 while s:/\.(/|$):/:;
1 while s:(^|/[^/]+)/+\.\.(/|$):/:;
s:([^/])/+$:$1:;
&err("Cannot chdir $_ ($!)"), return 0 unless chdir $_;
map(/^\// || ($choose{$_ = &absfile($_)} = $choose{$_}), @choose);
map(/^\// || delete $choose{$_}, keys %choose);
$cwd = $_;
my %p = (); my $p = \%p; my @new = ();
foreach (@cdhist) { ($$_{'ls'} eq $cwd) ? do { $p = $_ unless %$p }
: push(@new, $_) }
%$p = %{$_[0]}, $$p{'ls'} = $cwd if ref $_[0];
@cdhist = (%$p ? $p : {'ls' => $cwd}, @new);
my $max = eval $maxcdhist || 1;
splice(@cdhist, $max) if $max >= 0;
&cdrestore(%$p ? $p : '');
&cmdeval($onsub{'cd'}) if exists $onsub{'cd'};
$cwd;
}
sub pwd { local $_; chomp($_ = `pwd`); $_ }
sub cdrestore {
&page(1, 1, 1), &fileptr("-\$"), return unless my $p = shift;
@pendpage = (($$p{'file0'} ne '') ? "\\$$p{'file0'}" : 1,
($$p{'file1'} ne '') ? ("\\$$p{'file1'}",
"\\$$p{'file1'}") : (1, 1));
$fileptr = ($$p{'fileptr'} ne '') ? $$p{'fileptr'} : $bagkeys[0];
$pendptr = $$p{'file1'};
}
sub setcdhist {
my($k, $v) = @_;
($k eq 'file0') ? do { $file0 = $v } :
($k eq 'file1') ? do { $file1 = $v } :
($k eq 'fileptr') ? do { $fileptr = $v } : return;
$cdhist[0]{$k} = $v unless $altls;
$v;
}
sub cdhist {
my $p;
if ($_[0] =~ /^back$/i) {
$p = 1;
} elsif ($_[0] =~ /^prev$/i) {
$p = (++$cdhistp > $#cdhist) ? '' : $cdhistp;
} elsif ($_[0] =~ /^start$/i) {
$p = &min($cdhistp, $#cdhist);
$cdhistp = 0;
}
&cd($cdhist[$p]{'ls'});
}
sub setmark {
my $mark = shift;
return 0 if grep($mark eq $_, @_);
$mark{$mark} = {%{$cdhist[0]}};
}
sub getmark {
my $mark = exists $mark{$_[0]} ? $mark{$_[0]} : return;
return $mark->{'ls'} if $_[1] =~ /^d/i;
return $mark->{'file1'} if $_[1] =~ /^f/i;
return join('/', $mark->{'ls'}, $mark->{'file1'}) if $_[1] =~ /^p/i;
return $mark;
}
sub clearmarks { %mark = () }
sub helpmarks {
return &pipeto(shift, "No marks are defined.\n") unless %mark;
&help(map { ($_, "$mark{$_}->{ls} @ $mark{$_}->{file1}") }
sort keys %mark);
}
sub lsdir {
my $dir = (@_) ? $_[0] : '.'; my @ls = ();
&err("Cannot opendir $dir ($!)"), return @ls unless opendir DIR, $dir;
my @dir = readdir DIR;
closedir DIR;
while (@dir) {
local $_ = shift @dir;
next if @_ && /^\.\.?$/;
$_ = $_[0] . ((! @_ || $_[0] =~ /\/$/) ? '' : '/') . $_;
push(@ls, $_);
push(@ls, &lsdir($_)) if $cdhist[0]{'expand'}{$_} && -d $_;
}
@ls;
}
sub ls {
if ($altls) {
@ls = (ref $$altls[0] eq 'HASH') ? map($$_{'ls'}, @$altls) :
(ref $$altls[0] eq 'ARRAY') ? map($$_[0], @$altls) :
@$altls;
return @ls if grep($altls == $_, \@choose, \@cdhist, \@dohist);
} else {
@ls = &lsdir();
}
&myeval("\@ls = grep { $where } \@ls") if $where =~ /\S/;
@ls = grep(! /(^|\/)\.[^\/]*$/, @ls) if &opt('a');
@ls = grep(! /(^|\/)\.\.?$/, @ls) if &opt('A');
if (&opt('B')) {
foreach my $bak (@bak) {
eval { @ls = grep(! /$bak/, @ls) };
&err($@) if $@;
}
}
%sortcache = %sortcache2 = ();
@ls = &opt('f') ? @ls :
&opt('/') ? sort bydepth @ls :
&opt('F') ? sort bycolor @ls :
&opt('P') ? sort bybase @ls :
&opt('X') ? sort byext @ls :
&opt('m') ? sort bymode @ls :
&opt('l') ? sort bynlink @ls :
&opt('o') && ! &opt('N') ? sort byowner @ls :
&opt('o') && &opt('N') ? sort byuid @ls :
&opt('g') && ! &opt('N') ? sort bygroup @ls :
&opt('g') && &opt('N') ? sort bygid @ls :
&opt('S') ? sort bysize @ls :
&opt('t') ? sort bymtime @ls :
&opt('u') ? sort byatime @ls :
&opt('c') ? sort byctime @ls :
&opt('I') ? sort byinode @ls :
&opt('b') ? sort bydot @ls :
&opt('D') || &opt('d') ? sort bydir @ls :
&opt('i') ? sort bynocase @ls :
sort @ls;
%sortcache = %sortcache2 = ();
@ls = reverse @ls if &opt('r');
@ls;
}
sub altls {
my $r = shift; my $old = $altls;
$altls = ($r && $altls != $r) ? $r : undef;
$lstitle = ($altls) ? join(' ', @_) : '';
&cdrestore(($altls) ? '' : $cdhist[0]) if $altls != $old;
&cmdeval($onsub{'altls'}) if exists $onsub{'altls'};
$altls;
}
sub longls {
my $win = 0; $win = shift if $_[0] =~ /^-w/;
my $old = $long;
if ((my $arg = join(' ', @_)) =~ /^[-+\d\s]*$/) {
$long = ($arg =~ /^[-+]/) ? $long + $arg : $arg;
$long = 0 if $long < 1;
$long = ($long - 1) % 3 + 1 if $long > 3;
$longlabel = ('', 'user+mtime',
'group+atime', 'other+ctime')[$long];
} else {
$long = $arg . (($arg =~ /[\@\$]_/) ? '' : ' @_');
$longlabel = "{$long}";
}
&page($bagcol + 1) if $long;
(! $old || ! $long) ? &win() : do { &win_long(1); &home() }
if $win && $old ne $long;
}
sub long {
my $len = shift; my @ret = ();
if ($long =~ /^\d+$/) {
foreach (@_) {
last if $_ eq '';
push(@ret, &longstr($_, $len));
}
return @ret;
}
my $cmd = $long; my $p = $cmd =~ s/^[;:]//;
$cmd =~ s/\@_\b/join(' ', "e(@_))/eg unless $p;
if ($long =~ /\$_\b/) {
foreach (@_) {
last if $_ eq '';
my $c = $cmd;
$c =~ s/\$_\b/"e($_)/eg unless $p;
push(@ret, &longfix(($p) ? join(' ', eval $c)
: scalar `$c`, $_, $len));
}
} else {
my @r = (! @_) ? () : ($p) ? eval $cmd : `$cmd`;
foreach (@_) {
last if $_ eq '';
push(@ret, &longfix(shift @r, $_, $len));
}
}
@ret;
}
sub longfix {
local $_ = shift; my $label = shift; my $len = shift;
(my $prog = $long) =~ s/^\s+//; $prog =~ s/\s.*//;
chomp;
s/^\Q$prog\E:\s*//mg;
s/^\Q$label\E(:\s*|\s+)//mg;
s/\s+\Q$label\E$//mg;
s/\s*$//mg;
&colorlong(&{$longtrunc}(&view(&expandtabs($_)), $len));
}
sub longstr {
$! = 0;
my($Dev, $inode, $mode, $nlink, $uid, $gid, $Rdev, $size,
$atime, $mtime, $ctime) = &opt('L') ? stat shift : lstat shift;
return &color(&{$longtrunc}($!, $_[0]), $co_error) if $! + 0;
return &color(&{$longtrunc}(readlink $_, $_[0]), $co_symln)
if ! &opt('h') && ! &opt('L') && -l _;
my $perms;
if (-f _) { $perms = '-' }
elsif (-d _) { $perms = 'd' }
elsif (! &opt('L') && -l _) { $perms = 'l' }
elsif (-S _) { $perms = 's' }
elsif (-p _) { $perms = 'p' }
elsif (-b _) { $perms = 'b'; $size = '-' }
elsif (-c _) { $perms = 'c'; $size = '-' }
else { $perms = '?' }
$perms .= join('',
('---', '--x', '-w-', '-wx', 'r--', 'r-x', 'rw-', 'rwx')
[($mode & 0700) >> 6, ($mode & 0070) >> 3, $mode & 0007]);
substr($perms, 3, 1) =~ tr/-x/Ss/ if -u _;
substr($perms, 6, 1) =~ tr/-x/Ss/ if -g _;
substr($perms, 9, 1) =~ tr/-x/Tt/ if -k _;
$nlink = ($nlink > 99 || $nlink < 0) ? '**' : sprintf('%2d', $nlink);
my $user = &opt('N') ? $uid : &uid2name($uid);
my $group = &opt('N') ? $gid : &gid2name($gid);
$user = ('', $user, $group, 'other')[$long];
$size = &opt("#") ? $inode : $size;
$user = &trunc($user, &max(8, 18 - length($size) - 1))
if length("$user $size") > 18;
$size = sprintf('%.' . (18 - length($user) - 7) . 'e', $size)
if length("$user $size") > 18;
my $usize = ' ' x 18;
substr($usize, 0, length($user)) = $user;
substr($usize, -length($size)) = $size if $size ne '';
my $ftime = ('', $mtime, $atime, $ctime)[$long];
my $ctime = &myctime($ftime);
my $r = "$perms $nlink $usize $ctime";
return &{$longtrunc}($r, $_[0]) if ! &opt('n') || length($r) > $_[0];
$perms = &colorperms($perms, $uid, $gid);
$nlink =~ s/\S+/&color($&, $co_nlink)/e if $co_nlink;
my $co = $co_user{$user} ||
$co_user{('', $uid, $gid, '')[$long]} || $co_user{''};
substr($usize, 0, length($user)) = &color($user, $co) if $co;
if ($size =~ /^\d+$/ && ($co_size1 || $co_size2)) {
my $n = 0; my @size = ();
unshift(@size, &color($&, (++$n % 2) ? $co_size1
: $co_size2))
while $size =~ s/.?.?.$//;
$usize =~ s/\d+$/join('', @size)/e;
}
$ctime = &color($ctime, (time - $ftime > &txt2secs($aged))
? $co_aged : $co_xaged);
"$perms $nlink $usize $ctime";
}
sub longtrunc {
return $longtrunc = ($longtrunc eq 'trunc') ? 'truncr' : 'trunc'
if $_[0] eq 'toggle';
return $longtrunc = $_[0] if $_[0] =~ /^\w+$/ && defined &{$_[0]};
$longtrunc = 'trunc';
}
sub txt2secs {
local $_ = shift;
return $_ * 31557600 if /\bye?a?r?s?\s*$/i;
return $_ * 2629800 if /\bmon?t?h?s?\s*$/i;
return $_ * 604800 if /\bwe?e?k?s?\s*$/i;
return $_ * 86400 if /\bda?y?s?\s*$/i;
return $_ * 60 if /\bmi?n?u?t?e?s?\s*$/i;
return $_ * 1 if /\bse?c?o?n?d?s?\s*$/i;
return $_ * 3600 if /\bh?o?u?r?s?\s*$/i;
}
sub initopts { %opts = () }
sub opts { join('', sort keys %opts) }
sub setopt {
my($opt, $val) = @_;
return(($val || ! exists $opts{$opt})
? do { $opts{$opt} = 1 } : do { delete $opts{$opt}; 1 })
if length($opt) == 1 && index($optkeys, $opt) >= 0;
0;
}
sub opt {
my $opt = shift;
return 0 unless length($opt) == 1 && index($optkeys, $opt) >= 0;
index($optons, $opt) >= 0 xor $opts{$opt};
}
sub ifopt {
( &opt($_[0])) ? (($#_ >= 1) ? $_[1] : '-' . $_[0])
: (($#_ >= 2) ? $_[2] : ());
}
sub unlessopt {
(! &opt($_[0])) ? (($#_ >= 1) ? $_[1] : '-' . $_[0])
: (($#_ >= 2) ? $_[2] : ());
}
sub bybase {
my($abase, $bbase) = ($a, $b);
$abase =~ s/\/*$//; $abase =~ s/.*\///;
$bbase =~ s/\/*$//; $bbase =~ s/.*\///;
$abase cmp $bbase || &byname();
}
sub byext {
my($aext, $bext);
$aext = '' unless ($aext = $a) =~ s/..*\.//;
$bext = '' unless ($bext = $b) =~ s/..*\.//;
$aext cmp $bext || &byname();
}
sub bydepth { $a =~ s:/:/:g <=> $b =~ s:/:/:g || &byname() }
sub bycolor { &colorval($a) cmp &colorval($b) || &byname() }
sub byinode { &statval($a, 1) <=> &statval($b, 1) || &byname() }
sub bymode { &statval($b, 2) <=> &statval($a, 2) || &byname() }
sub bynlink { &statval($b, 3) <=> &statval($a, 3) || &byname() }
sub byuid { &statval($a, 4) <=> &statval($b, 4) || &byname() }
sub bygid { &statval($a, 5) <=> &statval($b, 5) || &byname() }
sub bysize { &statval($b, 7) <=> &statval($a, 7) || &byname() }
sub byatime { &statval($b, 8) <=> &statval($a, 8) || &byname() }
sub bymtime { &statval($b, 9) <=> &statval($a, 9) || &byname() }
sub byctime { &statval($b, 10) <=> &statval($a, 10) || &byname() }
sub byowner { &uid2name(&statval($a, 4)) cmp &uid2name(&statval($b, 4)) ||
&byname() }
sub bygroup { &gid2name(&statval($a, 5)) cmp &gid2name(&statval($b, 5)) ||
&byname() }
sub byname { &opt('b') ? &bydot() :
&opt('D') || &opt('d') ? &bydir() : &byascii() }
sub bydot {
my $adot = $a =~ /^\./; my $bdot = $b =~ /^\./;
! ($adot xor $bdot) ? (&opt('D') || &opt('d') ? &bydir() : &byascii())
: ($adot) ? 1 : -1;
}
sub bydir {
my $adir = &statval($a, 2, \%sortcache2) & 040000;
my $bdir = &statval($b, 2, \%sortcache2) & 040000;
! ($adir xor $bdir) ? &byascii() :
&opt('D') ? (($adir) ? -1 : 1)
: ($adir) ? 1 : -1;
}
sub byascii { &opt('i') ? &bynocase() : $a cmp $b }
sub bynocase {
(my $A = $a) =~ tr/A-Z/a-z/;
(my $B = $b) =~ tr/A-Z/a-z/;
$A cmp $B || $a cmp $b;
}
sub colorval {
my $f = shift;
(exists $sortcache{$f}) ? $sortcache{$f} :
($sortcache{$f} = &filecolor($f));
}
sub statval {
my($f, $n) = (shift, shift);
my($cache) = (@_) ? shift : \%sortcache;
(exists $$cache{$f}) ? $$cache{$f} :
($$cache{$f} = (&opt('L') ? stat $f : lstat $f)[$n]);
}
sub expand { &expanddir('e', @_) }
sub collapse { &expanddir('c', @_) }
sub expandtoggle { &expanddir('t', @_) }
sub expanddir {
return unless $depth;
my $act = shift;
$act = ($act =~ /^e/i) ? 1 : ($act =~ /^c/i) ? -1 : 0;
foreach (@_) {
my $def = undef;
$def = exists $cdhist[0]{'expand'}{$_} unless $act;
map($cdhist[0]{'expand'}{$_} = 1, &subdirs($_, $depth)), next
if ($act > 0 || ! $act && ! $def) && -d $_;
map(delete $cdhist[0]{'expand'}{$_}, &expdirs($_, $depth))
if $act < 0 || ! $act && $def;
}
}
sub subdirs {
my $dir = shift; my $dep = shift; my @ret = ();
return @ret if $dep == 0;
push(@ret, $dir);
return @ret if $dep == 1 || ! opendir SUB, $dir;
my @ls = readdir SUB;
closedir SUB;
while (@ls) {
local $_ = shift @ls;
next if /^\.\.?$/;
$_ = $dir . (($dir =~ /\/$/) ? '' : '/') . $_;
next if -l && ! &opt('L') || ! -d;
push(@ret, &subdirs($_, $dep - 1));
}
@ret;
}
sub expdirs {
my $dir = quotemeta shift; my $dep = shift;
return () if $dep == 0;
my $patt = "^$dir" . (($dep < 0) ? '(\/|$)' :
'(\/+[^\/]+){0,' . ($dep - 1) . '}\/*$');
grep { /$patt/ } keys %{$cdhist[0]{'expand'}};
}
sub mouse {
return(($scr->{TERM}->Tputs('Km', 1) eq "\e[M" ||
$scr->{TERM}->Tputs('Km', 1) eq '' &&
$ENV{'TERM'} =~ /(\b|_)(xterm|kterm|linux)/) ?
"\e[M" : undef) if ! @_;
($_[0]) ? "\e[M" : undef;
}
sub mousemode {
return 0 unless $mouse;
print((($_[0] =~ /^tog/i) ? ($moused = $moused ? 0 : 1) :
($_[0] =~ /./) ? $_[0] : $moused) ?
"\e[?1000h" : "\e[?1000l"
);
}
sub domouse {
my $ch = ord($scr->getch());
local $btn = ($ch & 0103) + 1;
local $bup = 2;
local $col = ord($scr->getch()) - 040 - 1;
local $row = ord($scr->getch()) - 040 - 1;
local($s, $c, $m) = (($ch & 04) ? 's' : '',
($ch & 020) ? 'c' : '',
($ch & 010) ? 'm' : '');
$bup = 1, $btn = $Button if $btn == 4;
$bup = $btn - 64, $btn = 4 if $btn >= 65;
$bup = ($bup == 1) ? 'u' : '';
&beep(), return if $bup && ! $btn;
local($_, $_r, $_e, $_h, $_t, $_f, $_m, $_d, @_argv);
local($_q, $_rq, $_eq, $_hq, $_tq, $_fq, $_mq, $_dq);
my $cell = $screenmap{"$col,$row"};
my $cmd = $cell ? $$cell[0] : undef;
$cmd = &$cmd() if ref $cmd eq 'CODE';
$ch = &mev2c();
if ($cell && (! ref $cmd || ! ref $$cmd[0] ||
&cmdprompt('', $cmd, $ch))) {
@_argv = @$cell;
$_ = $_argv[1];
$_ = $$_ if ref eq 'SCALAR';
&set_x() unless ref;
&cmdeval(shift @_argv, $ch);
} else {
&cmdeval($$mousemap{''}, $ch);
}
($Button, $Brow, $Bcol) = ($btn >= 1 && $btn <= 3 && ! $bup) ?
($btn, $row, $col) : (undef) x 3;
}
sub mousetxt {
($m ? 'Mod1-' : '') . ($c ? 'Ctrl-' : '') . ($s ? 'Shft-' : '') .
join(' ', grep(/./, ($btn == 4) ? 'Wheel' : ('Button', $btn || ''),
($bup) ? 'up' : 'down', "at ($col, $row)", @_));
}
sub mev {
join(' ', grep(/./, "$m$c$s" . (($btn == 0 && $bup) ? $bup :
($btn != 4 && $bup) ? "$btn$bup" :
($btn != 4) ? "${btn}d" :
($bup) ? "W$bup" : 'Wd'), @_));
}
sub mev2c {
my $r = '';
foreach my $mev (@_ ? @_ : &mev()) {
local $_ = $mev;
s/W/4/gi;
$r .= chr((/m/i ? 32 : 0) +
(/c/i ? 16 : 0) +
(/s/i ? 8 : 0) +
(/4/ ? 6 : /3/ ? 4 : /2/ ? 2 : 0) +
(/u/i ? 1 : 0) + 59);
}
$r;
}
sub c12mev { &c2mev(substr(join('', @_), 0, 1)) }
sub c2mev {
my $c, $mev, @r = ();
foreach (split(//, join('', @_))) {
$c = ord($_);
$mev = '', $c -= 59;
$mev .= 'm', $c -= 32 if $c >= 32;
$mev .= 'c', $c -= 16 if $c >= 16;
$mev .= 's', $c -= 8 if $c >= 8;
$mev .= 'W', $c -= 6 if $c >= 6;
$mev .= '3', $c -= 4 if $c >= 4;
$mev .= '2', $c -= 2 if $c >= 2;
$mev .= '1' if $mev !~ /[W32]/i;
$mev .= 'u' if $c >= 1;
$mev .= 'd' if $c < 1;
push(@r, $mev);
}
$#r ? $r[0] : @r;
}
sub help {
my $unused = 0; $unused = shift if $_[0] =~ /^-u/i;
my $tab = 8; my($key, $val); my $fnc = undef;
my %list = (); my @list = (); my @out = (); my %uplist = ();
@_ = ('=keymap') unless @_;
while (@_) {
$key = shift;
unshift(@_, &maporder("keymap_$keymap[$#keymap]")),
next if $key eq '=keymap';
unshift(@_, &maporder("typemap_$typemap[$#typemap]")),
$tab = $typemaptab, next if $key eq '=typemap';
unshift(@_, &maporder("mousemap_$mousemap[$#mousemap]")),
$tab = $mousemaptab,
$fnc = \&c12mev, next if $key eq '=mousemap';
unshift(@_, &maporder($1)), next if $key =~ /^=(\w+)$/;
$val = shift;
$list{$key} = $val, push(@list, $key)
unless exists $list{$key};
if ($key eq '' &&
$$val[0] =~ /^\W*cmdeval\W+keymapcmd\W+(\w*)\W*$/) {
eval "\%uplist = \%keymap_$1";
}
}
foreach (@list) {
push(@out, &helpstr($_, '', $tab, $list{$_}, $fnc)) }
if ($unused) {
my @seq = grep(! exists $list{pack('c', $_)} &&
! exists $uplist{pack('c', $_)}, 001 .. 0177);
@seq = &seqshort(@seq) if $unused =~ /^-U/;
foreach (@seq) {
$_ = &viewas(pack('c', $_)), next unless ref;
$_ = &viewas(pack('c', $$_[0])) . '-' .
&viewas(pack('c', $$_[1]));
}
push(@out, &color('UNUSED ' . join(' ', @seq),
&opt('H') ? $co_xuse : ()));
}
&pipeto($pagerr, @out);
}
sub helpstr {
my($key, $prk, $tab, $cmd, $fnc, $chc) = @_; my($v1, $v2) = (0, 0);
return &color(&view($cmd), &opt('H') ? $co_title : ()) . "\n"
if $key =~ /^TTL/;
return () if $cmd eq '';
$fnc = sub { @_ } unless ref $fnc;
$cmd = &$cmd() if ref $cmd eq 'CODE';
$cmd = (! ref $cmd) ? $cmd : (! ref $$cmd[0])
? (($$cmd[1] ne '' && ! &opt('p'))
? "\\" . eval("qq^$$cmd[1]^") : $$cmd[0])
: return map(&helpstr($key, &$fnc(substr($$_[2], 0, 1)),
$tab, $_),
grep((defined $chc) ? substr($$_[2], 0, 1) eq $chc
: 1, &cmds($cmd)));
$key = (length($key) == 1) ? &colorkey($v1 = &viewas($key)) :
&color($v1 = &view('no-double-backslash', $key),
&opt('H') ? $co_code : ());
$prk = (length($prk) == 0) ? '' :
(length($prk) == 1) ? &colorkey($v2 = &viewas($prk)) :
&color($v2 = &view($prk), &opt('H') ? $co_code : ());
$key = $key . (($prk ne '') ? " $prk" : '');
$v1 = length($v1) + (($prk ne '') ? 1 + length($v2) : 0);
$v1 = ($v1 >= $tab) ? "\n" . ' ' x $tab : ' ' x ($tab - $v1);
($key . $v1 . &colorcmd(&view($cmd)) . "\n");
}
sub cmdprompt {
my($get, $cmd, $c) = @_; my $cm;
$c = &keyprompt(@_) unless $c;
$cm = ($c eq '') ? '' : (grep { index($$_[2], $c) >= $[ } @$cmd)[0];
$cm = (grep { $$_[2] eq '' } @$cmd)[0]
unless $c eq '' || $c eq "\r" || ref $cm;
$c ne "\r" && ! defined $_[2] && &beep(), return '' unless ref $cm;
$$cm[0];
}
sub keyprompt {
my($get, $cmd) = @_; my @p = (); my($v, $n, $c);
foreach (&cmds($cmd)) {
$n++;
push(@p, &colorkey($v = &viewas(substr($$_[2], 0, 1))),
' ' x (8 - length($v)),
($$_[3] ne '') ?
&color(&view(eval("qq^$$_[3]^")),
&opt('H') ? $co_prmt : ()) :
($$_[1] ne '' && ! &opt('p')) ?
&color(&view(eval("qq^$$_[1]^")),
&opt('H') ? $co_desc : ()) :
&colorcmd(&view($$_[0])), "\n");
}
&home(); &echo(@p);
$c = &getkey($get);
($filerow + 3 + $n + 1 > $scr->{ROWS}) ?
&winch() : do { &home(); $scr->clreos() };
$c;
}
sub cmds {
my $a = 'a';
foreach my $cmd (@{$_[0]}) {
next if defined $$cmd[2];
$$cmd[2] = $a++;
last if length($a) > 1;
}
@{$_[0]};
}
sub setcomplete {
my $fn = shift;
if ($fn eq 'function') {
$rl->Attribs->{'completion_function'};
} elsif (ref $fn) {
$rl->Attribs->{'completion_function'} = $fn
if ! @_ || grep($rlmodule eq $_, @_);
} else {
eval { delete $rl->Attribs->{'completion_function'} };
$rl->Attribs->{'completion_entry_function'} = undef;
}
}
sub rlhistget {
my $hist = shift;
my $feat = $hist && $rl->Features->{'setHistory'}
&& $rl->Features->{'getHistory'};
$rl->SetHistory(@$hist) if $feat;
my $str = &getstr(@_);
@$hist = $rl->GetHistory if $feat;
$str =~ s/ $// if ! s/\\ $/ / && &setcomplete('function');
$str;
}
sub get { &rlhistget(\@rlhist_, @_) }
sub getshell { &rlhistget(\@rlhist_shell, @_) }
sub getjunk { &rlhistget(\@rlhist_junk, @_) }
sub getfile {
local $_ = &rlhistget(\@rlhist_file, @_);
s/ $// unless s/\\ $/ /;
$_;
}
sub gets {
my $s = &get(@_);
($filerow + 4 >= $scr->{ROWS}) ? &winch() : &home(), die "\n"
if $s eq '';
$s;
}
sub getcmd {
my $cmd = join(' ', @_);
my $arg = &get($cmd);
($filerow + 4 >= $scr->{ROWS}) ? &winch() : &home(), die "\n"
if $arg =~ /^\s+$/;
$cmd . (($arg eq '') ? '' : ' ') . $arg;
}
sub getoutput {
my @r; my $s = &getshell(@_);
return &myeval($s) if $s =~ s/^[;:]//;
chomp(@r = `$s`);
@r;
}
sub ask {
&home(), die "\n" if index('Yy' . ((length($ch) == 1 && $ch !~ /n/i) ?
$ch : ''), &getkey(@_)) < 0;
&home();
}
sub shellp {
my $n = ($_[0] eq '-noecho') ? 1 : 0;
return &perl(@_) if $_[$n] =~ s/^[;:]//;
&shell(@_);
}
sub shellv {
my $prompt = shift; my @r = ();
my $cmd = &getshell($prompt);
while ($cmd !~ /^\s*([vV]|exit|lo(gout)?)\s*$/) {
@r = &shellp('-noecho', $cmd);
$cmd = &getshell($prompt);
}
@r;
}
sub evalnext {
my $a = shift;
&cmdeval($$a[0]);
push(@$a, shift @$a);
}
sub clear {
($altls == \@cdhist) ? splice(@cdhist, 1) :
($altls == \@choose || ! $altls) ? &unchoose(@choose) :
do { @$altls = () };
}
sub ret {
my $prompt = join(' ', @_);
return &getjunk($prompt) =~ /^\s*y/i if $prompt;
my $cmd = &getshell('Press Return');
($cmd) ? &shellp($cmd) : 0;
}
sub err {
chomp(my $e = join(' ', @_));
$err .= (($err ne '' && $e ne '') ? '; ' : '') . &view($e);
}
sub beep {
print $aubeep if &opt('V');
print $vibeep if &opt('v');
}
sub run {
my @args = @_;
my $opts = undef; $opts = $', shift @args if $args[0] =~ /^-/;
my $marg = $opts =~ /[xs]/ && $#args > 0;
($opts =~ /#/) ? (($marg) ? push(@args, '--', @choose)
: ($args[$#args] .=
join(' ', ' --', "e(@choose)))) :
($opts =~/\+/) ? (($marg) ? push(@args, @choose)
: ($args[$#args] .=
join(' ', '', "e(@choose)))) :
($opts =~ /F/) ? (($marg) ? push(@args, '--', $_f)
: ($args[$#args] .= ' -- ' . "e($_f))) :
($opts =~ /f/) ? (($marg) ? push(@args, $_f)
: ($args[$#args] .= ' ' . "e($_f))) :
($opts =~ /=/) ? (($marg) ? push(@args, '--', $_)
: ($args[$#args] .= ' -- ' . "e($_))) :
($opts =~ /_/) ? (($marg) ? push(@args, $_)
: ($args[$#args] .= ' ' . "e($_))) :
undef;
@args = join(' ', ($marg) ? "e(@args) : @args)
if $opts =~ /[gPpb]/;
($opts =~ /2/) ? ($args[0] .= ' 2>&1') : undef;
($opts =~ /g/) ? ($args[0] .= " | $pagerr") :
($opts =~ /P/) ? ($args[0] .= " | $pagera") :
($opts =~ /p/) ? ($args[0] .= " | $pager") : undef;
($opts =~ /b/) ? ($args[0] = "($args[0]; echo \a\a |"
. " tr -d '\\012') &") : undef;
($opts =~ /x/) ? &xsh(@args) :
($opts =~ /s/) ? &sh(@args) :
($opts =~ /X/) ? &xshell(@args) :
&shell(@args);
($opts =~ /b/) ? sleep 1 : undef;
($opts =~/\//) ? &setcomplete() : undef;
($opts =~ /C/) ? &ret('Remove?') && &remove(@choose) :
($opts =~ /R/) ? &ret('Remove?') && &remove($_) :
($opts =~ /r/) ? &ret() : undef;
($opts =~ /u/) ? &unchoose(@choose) : undef;
($opts =~ /k/) ? &keymap() : undef;
($opts =~ /L/) ? do { &longls(1); &win() } :
($opts =~ /n/) ? undef :
($opts =~ /W/) ? &winch() :
($opts =~ /w/) ? &win() :
($opts =~ /x/ || $opts =~ /X/ && $opts !~ /s/)
? &win() : &winch();
}
sub run_syntax {
local $_ = join(' ', @_);
s/^run (-\S*) /run '$1', /;
$_;
}
sub vardump {
return '# Requires Data::Dumper module, standard with perl 5.004_71'
. " and later.\n" unless defined $Data::Dumper::VERSION;
my($r) = '';
local $_ = join(',', @_); s/^[\s,;]*$/\\%::/;
foreach (grep { /./ } split(/[\s,;]+/)) {
$r .= "# scalar, reference or object = $_\n"
. Data::Dumper->new([eval $_])
->Purity(1)->Terse(1)->Deepcopy(1)->Dump;
}
$r;
}
sub mailcap2typemap {
my($file, $pfx, $args, @except) = @_;
return () if ! defined $Mail::Cap::VERSION || $file && ! -e $file;
my $cap = ($file) ? new Mail::Cap $file
: new Mail::Cap @$args;
my @r = (); my $cmd;
foreach my $type (keys %$cap) {
next if $type =~ /^_|'/;
next if grep(&mimetypeeq($type, $_), @except);
$cmd = [&capcmd2cmd($cap, $type, 'view'),
&capcmd2cmd($cap, $type, 'edit'),
&capcmd2cmd($cap, $type, 'print')];
push(@r, $pfx . "mimetypeeq \$_m, '$type'" => $cmd) if @$cmd;
}
@r;
}
sub capcmd2cmd {
my($cap, $type, $verb) = @_; my $key = substr($verb, 0, 1);
my $cmd = ($key eq 'e') ? $cap->editCmd( $type, '%s') :
($key eq 'p') ? $cap->printCmd($type, '%s') :
$cap->viewCmd( $type, '%s');
return () if $cmd =~ /^\s*$|\%[Fnu]/;
my $scmd = ($key eq 'e') ? $cap->field($type, 'shortedit') :
($key eq 'p') ? $cap->field($type, 'shortprint') :
$cap->field($type, 'shortview');
$scmd = $cmd unless $scmd;
local $_ = &evalquote($cmd);
$_ .= ' . " < $_q"' unless /\%s/;
$_ .= ' . " | $pagera"' if $cap->field($type, 'copiousoutput')
&& $key ne 'e' && $key ne 'p';
s/\%s'$/' . \$_q/s;
s/\%s/' . \$_q . '/gs;
return ["run -x $_",
"$verb this file", $key . uc $key,
"$verb with `$scmd`"]
if $cap->field($type, 'dontneedterminal')
&& $key ne 'e' && $key ne 'p';
(["run -s $_",
"$verb this file from this terminal", $key,
"$verb from this term with `$scmd`"],
["run -x \"xterm -e '\" . " . do { s/\\'/\\'"\\'"\\'/gs; $_ }
. " . \"'\"",
"$verb this file from a new terminal", uc $key,
"$verb from new term with `$scmd`"]);
}
sub mimetype {
my $type;
my @r = map { ($file_i && do { $type = "e($_);
$type = "''" if $type eq '';
$type = `file -Lib $type 2> /dev/null`;
chomp $type; $type })
? $type :
($mimetypes && do { $type = $mimetypes->mimeTypeOf($_) })
? $type->type : '' } @_;
$#r ? @r : shift @r;
}
sub mimetypeeq {
my($a, $b) = @_;
$a =~ s/\s*[,;\s].*//;
$b =~ s/\s*[,;\s].*//;
return 2 if $a =~ /\*$/ && $b =~ /^\Q$`\E/;
return 3 if $b =~ /\*$/ && $a =~ /^\Q$`\E/;
$a eq $b;
}
sub df {
&err('Filesys::DiskFree not available'), return ''
unless defined $Filesys::DiskFree::VERSION;
$df = new Filesys::DiskFree;
$df->df();
}
sub disks {
return () unless &df();
($df->disks(), $disksgvfs ? </run/user/$\>/gvfs/*> : ());
}
sub diskdevs {
return () unless &df();
grep { /^\// && ! /^\/\// } map { $df->device($_) } $df->disks();
}
sub diskspace {
my @args = @_ ? @_ : (&pwd());
return () unless &df();
my @r = ();
my %mag = (1 => 'K', 2 => 'M', 3 => 'G', 4 => 'T',
5 => 'P', 6 => 'E', 7 => 'Z', 8 => 'Y');
my $cmnt = $df->mount(&pwd());
foreach (@args) {
my($u, $a) = ($df->used($_), $df->avail($_));
my($t, $f, $s) = ($u + $a, 1, ' ');
my $mnt = $df->mount($_);
foreach (sort keys %mag) {
($f, $s) = (1024 ** $_, $mag{$_}), last
if length(sprintf('%.0f', $t / 1024 ** $_)) <= 6;
}
push(@r, join(' ',
sprintf("%6.0f$s", $u / $f), '/' .
sprintf("%6.0f$s", $t / $f), '=' .
sprintf('%5.1f%%', $t ? 100 * $u / $t : 0), 'used' .
(($mnt eq $cmnt) ? ';' : ',') .
sprintf("%6.0f$s", $a / $f), 'avail',
$df->device($_), $mnt));
}
$#r ? @r : shift @r;
}
sub colordiskspace {
local $_ = join('', @_);
s/\d+[MT]/&color($&, $co_size1)/ge;
s/\d+[KG]/&color($&, $co_size2)/ge;
s/([\d.]+)%/($1 >= $full) ? &color($&, $co_write) : $&/ge;
s/([\d.]+)%/($1 < $full) ? &color($&, $co_ftype) : $&/ge;
$_;
}
sub sigs_off { @SIG{qw/INT PIPE WINCH/} = qw/DEFAULT IGNORE DEFAULT/;
$SIG{'TSTP'} = ($Config{'PERL_REVISION'} > 5 ||
$Config{'PERL_VERSION'} >= 8)
? 'DEFAULT' : 'tstp' }
sub sigs_on { @SIG{qw/INT PIPE WINCH TSTP/} = qw/IGNORE DEFAULT winch stop/ }
sub winch_off { $SIG{'WINCH'} = 'DEFAULT' }
sub winch_on { $SIG{'WINCH'} = 'winch' }
sub bakescr {
(($_[0] =~ /./) ? $_[0] : $cooked)
? do { &mousemode(0);
eval { system("stty -raw echo $stty_cooked") } }
: do { eval { system("stty raw -echo $stty_raw") };
&mousemode() };
}
sub winch {
&sttyfix(1);
$scr->resize();
eval { $rl->resize_terminal() };
&sttyfix();
&cmdeval($onsub{'winch'}) if exists $onsub{'winch'};
&win(($_[0] == 1) ? () : ("\\$file0", "\\$file1", "\\$file1"));
}
sub getkey {
&mousemode(0);
$scr->puts(join(' ', map(&color($_, $co_decor), @_)) . ' ')
->clreol() if @_;
my $ch = $scr->getch();
$scr->flush_input();
&mousemode();
$ch . '';
}
sub getstr {
&bakescr($cooked = 1);
&winch_off();
my $str = $rl->readline((! @_) ? '' : join(' ',
($rlmodule ne 'Gnu') ? @_ :
map(&rl_prompt_mark_ignore(&color($_, $co_decor), $_), @_)) . ' ');
&winch_on();
&bakescr($cooked = 0);
$rl->addhistory($str) if $str =~ /\S/
&& ! $rl->Features->{'autohistory'};
$rl->SetHistory(&uniq($rl->GetHistory))
if $rl->Features->{'getHistory'}
&& $rl->Features->{'setHistory'};
$str . '';
}
sub sh {
my $no = ($_[0] eq '-noecho') ? shift : 0;
$scr->puts(join(' ', map(&color(&view($_), $co_decor), @_)))
->clreol() unless $no;
&bakescr($cooked = 1);
print "\n" unless $no;
&sigs_off();
$! = 0;
my @r = eval { system(@_) };
&err("sh: $!") if $!;
&sigs_on();
&bakescr($cooked = 0);
@r;
}
sub shell {
my $no = ($_[0] eq '-noecho') ? shift : 0;
my $cmd = join(' ', @_);
my $pre = $err;
1 while $cmd =~ s/\{\{(.*?)\}\}/join(' ', &myeval($1))/e;
return if $pre ne $err;
$scr->puts(&color(&view($cmd), $co_decor))->clreol() unless $no;
&bakescr($cooked = 1);
print "\n" unless $no;
&sigs_off();
$! = 0;
my $s = $shell || $ENV{'SHELL'} || '/bin/sh';
my @r = eval { system($s, '-c', $cmd) };
&err("shell: $s: $!") if $!;
&sigs_on();
&bakescr($cooked = 0);
@r;
}
sub perl {
my $no = ($_[0] eq '-noecho') ? shift : 0;
$scr->puts(&color(&view(join(' ', @_)), $co_decor))->clreol() if ! $no;
&bakescr($cooked = 1);
print "\n" if ! $no;
&sigs_off();
my @r = &myeval(@_);
&sigs_on();
&bakescr($cooked = 0);
@r;
}
sub echo {
&bakescr($cooked = 1);
print @_;
&bakescr($cooked = 0);
}
sub pipeto {
my $prog = shift;
$prog = ($prog) ? "| $prog" : '> -';
&bakescr($cooked = 1);
&sigs_off() if $prog;
open(PIPE, $prog) ? do { print PIPE @_; close PIPE }
: &err("Cannot open '$prog' ($!)");
&sigs_on() if $prog;
&bakescr($cooked = 0);
}
sub tstp { &stop('tstp') }
sub stop {
&wtmpcwd() if $tmpcwd;
&bakescr(1) unless $_[0] eq 'tstp';
kill 'STOP', $$;
&bakescr() unless $_[0] eq 'tstp';
my $nwd;
($nwd = &rtmpcwd()) ne $cwd && &cd($nwd), unlink $tmpcwd
if $tmpcwd && -e $tmpcwd;
do $tmpenv, $@ && &err($@), unlink $tmpenv
if $tmpenv && -e $tmpenv;
}
sub restart {
&onrestart() if defined &onrestart;
&mousemode(0);
exec $0;
}
sub quit {
&onquit() if defined &onquit;
&wtmpcwd() if $tmpcwd;
&bakescr(1);
undef $scr;
undef $rl;
warn "\r", @_ if @_;
exit;
}
sub sttyfix {
if ($_[0] =~ /./) {
$sttypath = $ENV{'PATH'},
$ENV{'PATH'} = "/usr/ucb:$ENV{'PATH'}" if ! defined $sttypath;
$OSNAME = 'not-solaris' if $OSNAME eq 'solaris';
} else {
$OSNAME = 'solaris' if $OSNAME eq 'not-solaris';
$ENV{'PATH'} = $sttypath,
undef $sttypath if defined $sttypath;
}
}
sub rtmpcwd {
my $r = '';
open(TMPCWD, "< $tmpcwd") or &err("Cannot read $tmpcwd ($!)");
chomp($r = <TMPCWD>);
close TMPCWD;
$r;
}
sub wtmpcwd {
my $u = umask;
umask 077;
open(TMPCWD, "> $tmpcwd") or &err("Cannot write $tmpcwd ($!)");
print TMPCWD $cwd, "\n";
print TMPCWD join("\n", @choose), "\n";
umask $u;
close TMPCWD;
}
sub myeval {
my $cmd = &run_syntax(@_);
@_ = @_argv;
my @r = eval $cmd;
&err($@) if $@;
@r;
}
sub myctime {
(($_[1]) ? sprintf("@%03d ", int(($_[0] + 3600) % 86400 / 86.4)) : '')
. localtime($_[0]);
}
sub xsh {
&err('DISPLAY not defined'), return unless $ENV{'DISPLAY'};
&sh(join(' ', ($#_ > 0) ? "e(@_) : @_, '&'));
}
sub xshell {
&err('DISPLAY not defined'), return unless $ENV{'DISPLAY'};
&shell(@_, '&');
}
sub users {
local $_; my @r = ();
setpwent; push(@r, $_) while $_ = getpwent; endpwent;
sort @r;
}
sub groups {
local $_; my @r = ();
setgrent; push(@r, $_) while $_ = getgrent; endgrent;
sort @r;
}
sub uid2name {
my($uid) = @_;
(exists $users{$uid}) ? $users{$uid}
: ($users{$uid} = (getpwuid($uid))[0] || $uid);
}
sub gid2name {
my($gid) = @_;
(exists $groups{$gid}) ? $groups{$gid}
: ($groups{$gid} = (getgrgid($gid))[0] || $gid);
}
sub trunc {
my($s, $n) = @_;
return $s if length($s) <= $n;
substr($s, 0, $n - 1) . '\\';
}
sub truncr {
my($s, $n) = @_;
return $s if length($s) <= $n;
'\\' . substr($s, -($n - 1));
}
sub truncm {
my($s, $n) = @_;
return $s if length($s) <= $n;
$n -= length($dotdotdot);
return '' if $n < 0;
my $p = &ceil($n / 2);
(substr($s, 0, $p), $dotdotdot, substr($s, -($n - $p), $n - $p));
}
sub quote {
my @r = @_;
grep { s/[^-\w\.\/]/\\$&/g } @r;
$#r ? @r : shift @r;
}
sub evalquote {
local $_ = join('', @_);
s/['\\]/\\$&/g;
"'$_'";
}
sub expandtabs {
my $s = join('', @_);
while ((my $t = index($s, "\t")) >= $[) {
substr($s, $t, 1) = ' ' x (8 - $t % 8);
}
$s;
}
sub view {
my $ndbs = undef;
$ndbs = shift if $_[0] eq 'no-double-backslash' && $#_;
local $_ = join('', @_);
s/\\/\\\\/g unless $ndbs;
s/\n/\\n/g;
s/[\000-\007\013\016-\037\177-\237]/sprintf('\\%03o', ord($&))/eg;
s/\010/\\b/g; s/\f/\\f/g;
s/\r/\\r/g; s/\t/\\t/g;
$_;
}
sub viewas {
local $_ = join('', @_);
s/\n/^J/g;
s/[\000-\037]/'^' . pack('c', ord($&) + 64)/eg;
s/ /<sp>/g;
s/\177/<del>/g;
s/[\200-\237]/sprintf('\\%03o', ord($&))/eg;
s/\240/<nbsp>/g;
$_;
}
sub min { my $x = shift; foreach (@_) { $x = ($x <= $_) ? $x : $_ } $x }
sub max { my $x = shift; foreach (@_) { $x = ($x >= $_) ? $x : $_ } $x }
sub ceil {
my $n = int $_[0];
($_[0] - $n == 0) ? $n : ++$n;
}
sub digit {
($_[0] > 60) ? '*' : (1 .. 9, 'a' .. 'z', 'A' .. 'Z')[$_[0]];
}
sub undigit {
&aindex($_[0], (1 .. 9, 'a' .. 'z', 'A' .. 'Z'));
}
sub aindex {
my($s, $n) = (shift, $[);
foreach (@_) {
last if $_ eq $s;
$n++;
}
($n > $#_) ? -1 : $n;
}
sub akeys { my $n = 1; grep { $n++ % 2 } @_ }
sub uniq {
my @r = ();
foreach (@_) { unshift(@r, $_) if ! @r || $r[0] ne $_ }
reverse @r;
}
sub unique {
my @r = (); my %seen = ();
foreach (@_) { push(@r, $_) unless $seen{$_}++ }
@r;
}
sub seqshort {
my @seq = @_; my @keep = ();
while (@seq) {
my($x, $l) = (0, 0);
while ($l + 1 <= $#seq) {
$l--, last if $seq[++$l] != $seq[$x] + 1;
$x = $l;
}
push(@keep, ($l < 2) ? @seq[0..$l] : [$seq[0], $seq[$l]]);
@seq = @seq[$l+1..$#seq];
}
@keep;
}