#!/usr/bin/perl
BEGIN { unshift @INC, "$ENV{'HOME'}/perl",
"$ENV{'HOME'}/libp/perl", "$ENV{'HOME'}/lib/perl",
"$ENV{'HOME'}/libp", "$ENV{'HOME'}/lib" }
$default_vshnucfg = '';
$debug = 0;
$debug_ch = 0;
# vshnu - an enhanced vsh-like visual shell supplement in Perl
# Steve Kinzler, kinzler@cs.indiana.edu, Aug 99/Mar 00/Sep 00
# see website http://www.cs.indiana.edu/~kinzler/vshnu/
# http://www.cs.indiana.edu/~kinzler/home.html#unix
###############################################################################
## Change log and To do #######################################################
($vname, $version) = qw(vshnu 1.0302);
# 1.0000 7 Nov 2000 Initial public release
# 1.0003 13 Dec 2000 Version format x.y.z -> x.0y0z
# 1.0005 26 Jan 2001 Use most specific LS_COLORS match
# 1.0010 2 Jul 2001 Improve function key support
# 1.0013 27 Mar 2002 Use VSHNUTMP to enable tmp files and specify location
# 1.0100 29 Mar 2002 Recognize VSHNUCWD and VSHNUENV for tmp file basenames
# 1.0101 1 Apr 2002 Add ifopt and unlessopt utility subs
# 1.0102 3 Apr 2002 Fix bug in ifopt and unlessopt for older perls
# 1.0103 16 Apr 2002 Add "use Data::Dumper" and &vardump
# 1.0104 23 Apr 2002 Report $! errors from &sh and &shell
# 1.0105 14 Jun 2002 Add $stty_cooked and $stty_raw
# 1.0106 25 Nov 2002 Support non-ANSI non-color terminals
# 1.0107 23 Jan 2003 Fix readline for prompts w/ non-visible characters
# 1.0108 4 Jun 2003 Include ~/perl in @INC; Use HOSTNAME if no HOST
# 1.0109 11 Jun 2003 Fixes for non-Gnu ReadLines; Versions support
# 1.0110 13 Jun 2003 Use only one ReadLine instance, fix history doubling
# 1.0111 18 Jun 2003 Fixes for perl 5.8 safe signals and Gnu ReadLine resize
# 1.0112 19 Jun 2003 Suppress consecutive duplicates in readline histories
# 1.0113 1 Jul 2003 Suppress any program name label from long listings
# 1.0114 2 Jul 2003 Add insert-vshnu-chosen Gnu ReadLine function
# 1.0115 3 Jul 2003 Use Sys::Hostname if no HOST or HOSTNAME
# 1.0116 8 Jul 2003 Propogate @choose to shell; -V command line flag
# 1.0117 10 Jul 2003 Fix &long bug for @_ longls's on empty file sets
# 1.0118 11 Jul 2003 Use optional Filesys::DiskFree and add &disks
# 1.0119 11 Jul 2003 Separate ReadLine histories for shells, files, etc
# 1.0120 4 Dec 2003 Use LS_COLORS2 (appended to LS_COLORS) if available
# 1.0121 3 Jun 2004 View trailing spaces in filenames; Add &diskdevs
# 1.0122 4 Jun 2004 Add &longtrunc for truncation function spec/toggle
# 1.0123 7 Jun 2004 Add &pwd and &diskspace; Enhanced &getmark
# 1.0124 29 Jun 2004 Generalize insert-vshnu-chosen to insert-vshnu
# 1.0125 2 Nov 2004 Add $_f and $_fq dotype variables for full pathnames
# 1.0126 27 Nov 2004 Add &filecounts and &filecount
# 1.0127 28 Nov 2004 Color file paths as directories; Add sort bydepth
# 1.0128 31 Jan 2005 Add &expand, &collapse and &expandtoggle aliases
# 1.0129 1 Feb 2005 Workaround Term::Screen 1.03 "fixes"; Use English
# 1.0130 7 Feb 2005 Add &sttyfix to abstract Solaris stty workarounds
# 1.0131 20 Feb 2005 Enhance &long for perl commands; Fix &diskspace bug
# 1.0132 18 Mar 2005 Add &setcomplete for custom ReadLine completions
# 1.0133 29 Mar 2005 Show actual \ as \\ in &view; Fix &lsdir buglet
# 1.0134 14 Apr 2005 Identify shell in &shell error messages
# 1.0135 14 Apr 2005 Align &diskspace output; Strip up-mode keys from UNUSED
# 1.0136 15 Apr 2005 Add &colorlong*, &cfgcolorlong, &colordiskspace, $full
# 1.0137 20 Apr 2005 Fix some divide-by-zero errors in empty file sets
# 1.0138 21 Apr 2005 Add $_d and $_dq dotype vars for `file -L` output
# 1.0139 22 Apr 2005 Add &mimetype, $_m and $_mq dotype vars for MIME type
# 1.0140 23 Apr 2005 Change &dotypepath to beep on file not found
# 1.0141 24 Apr 2005 Use V and v options for audio and visual beeps
# 1.0142 27 Apr 2005 Don't show \ as \\ in help keys; Add $typemaptab
# 1.0200 29 Apr 2005 Add mailcap support with Mail::Cap; Add &xsh
# 1.0201 3 May 2005 Add xterm mouse mode support; Add &restart
# 1.0202 4 May 2005 Add starter &domouse for mouse event reporting
# 1.0203 6 May 2005 Add $hostname and $hostr (from any &hostr) globals
# 1.0204 9 May 2005 Use P option and add &bybase
# 1.0205 9 May 2005 Append dir and file hists to &dotypepath search path
# 1.0206 10 May 2005 Add &users and &groups
# 1.0207 11 May 2005 Add &completetypepath and enhance &setcomplete
# 1.0208 18 May 2005 Add &mapadd and &akeys
# 1.0209 1 Jul 2005 Fix $bagcol bug from 1.0137 and &diskspace align bug
# 1.0211 5 Jul 2005 Use &quit vs die or exit mostly
# 1.0212 28 Dec 2005 Use @*map_* for typemap and help ordering; Add &map*
# 1.0213 28 Jan 2006 Add &ext and &Ext
# 1.0214 6 Apr 2006 Delete &help and &helpmark pager args
# 1.0215 8 Apr 2006 Add &run, &run_syntax and &ext_syntax
# 1.0216 23 Apr 2006 Add &mousetxt, &mousemap, &mev2c, &c2mev and &pushmap
# 1.0217 14 May 2006 Add &setsm* and use for file*; Add &keyprompt
# 1.0218 21 May 2006 Run screenmap cmds; Use @_argv in &myeval; Add &set_x
# 1.0219 8 Feb 2007 Enhance &longlen argument syntax
# 1.0220 13 Feb 2007 Fix various Perl::Critic coding criticisms
# 1.0221 11 Apr 2007 Add = and ! flags to pushmap arg; Add &dotypein
# 1.0222 15 Apr 2007 Add new screen zones for mousemaps; Add &decolor
# 1.0223 20 Apr 2007 Add PIPE handling to &sigs_*; Fix mouse support
# 1.0224 17 May 2007 Add $userhostr and &atabsfile
# 1.0300 8 Jul 2007 Version normalization
# 1.0301 15 Jul 2007 Enhance &mapadd $before argument syntax
# 1.0302 16 Mar 2008 Add map titles; Use *, H and k options
# To Consider and Do:
# * Support special zones and mouse actions in longstr
# * Add a flag to &run that prompts for an okay before running the command
# * Add an "asif" feature to specify files' actions as if they were other types
# + Perhaps an $asif variable persistently set via # command
# + And/or perhaps a variable like $norun for 1-time exceptions (^O or N)
# * Add configurable per-directory/listing options (un)set on each entry/exit
# + Such as f in Favorites and i in Windows filesystems
# + Eg, %diropts = (dirpatt => 'opts', ...)
# + Provide a way to save the current options for the current directory
# * Enhance command line startup flags
# + To give an initial set of key input (Term::Screen &stuff_input($scr))
# + To reset options; To output the help listings (vc /Tip/)
# * Reorder, section and subtitle all the help listings
# * Provide refcards from the help listings (HTML::FromANSI)
# * Provide a man page or perldoc or such
# * Add a shorthand for the &mapadd $before arg meaning the map's 1st position
###############################################################################
## Modules setup ##############################################################
$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 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; # setenv PERL_RL {Gnu,Perl,false}, dflt best available
print("$version\n"), exit if $ARGV[0] eq '-v';
$ARGV_V = 1, @ARGV = () if $ARGV[0] eq '-V';
die "usage: $0 [ -v | -V | [ -- ] dir ... ]\nVersion $version\n"
if $ARGV[0] =~ /^-/ && $ARGV[0] ne '--';
die "$0: stdin not a tty\n" unless -t;
shift @ARGV if $ARGV[0] eq '--';
$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 setup and subroutines #############################################
@versions = (
'perl' => "$Config{'version'} $Config{'archname'}",
'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 $ARGV_V;
###############################################################################
## Initial setup ##############################################################
$ch = $ch_list = $err = $stty_cooked = $stty_raw = ''; $cooked = 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);
map($ansicolor{$Term::ANSIColor::attributes{$_} + 0} = $_,
keys %Term::ANSIColor::attributes);
$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;
@cdhist = @cdhist || map({'ls' => $_}, @ARGV);
$pwd = (@cdhist) ? $cdhist[0]{'ls'} : &pwd();
$pwd ne '' && &cd($pwd) or &quit("$0: cannot cd '$pwd'\n");
undef $pwd;
if ($insertkey ne '') {
&rl_bind_insert_vshnu($insertkey); # Gnu ReadLine only
&mapadd('keymap_', ":$insertkey", # only for help listing
$insertcmd) if $insertcmd;
}
require 'dumpvar.pl' if $debug; # to enable &dumpvar(PACKAGE, VARS)
# and &dumpValue(DATAPTR)
###############################################################################
## Main execution loop and subroutines ########################################
&win();
while (1) {
$ch = $scr->getch();
$scr->flush_input(); # partly broken in Term::Screen 1.00- *shrug*
$ch_list = &scrtruncr($ch_list . ((length($ch) > 1) ? " $ch" :
sprintf(' 0%o', ord $ch))) if $debug_ch;
$cmd = &keymapcmd();
# doesn't catch cdhist's in commands run via &domouse
$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);
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; # =map => noop if in map
my $_0 = $_[0]; $_0 =~ s/^[=!*]*//; # !map => push regardless
my $flg = $&; my $m = ''; # *map => switch not push
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;
(! 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;
}
###############################################################################
## Map management subroutines #################################################
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 }
###############################################################################
## Screen drawing subroutines #################################################
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) - 3) / 2);
&setsm($row + 2, $col + 3 + $p, 3,
[$$mousemap{'file...'}, \($_->[$row])])
if $filelen == $l && $sv =~ /^.{$p}\.\.\./;
&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 = (! 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, 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 { # heuristic, tries to err conservatively
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) { # couldn't get splice() to work
@{$screenmap{join(',', $_ + 0, $row + 0)}}[$i .. $i+$#v] = @v;
}
}
sub scrtruncr {
substr(' ' x $scr->{COLS} . join('', @_),
-($scr->{COLS} - 1), $scr->{COLS});
}
###############################################################################
## Screen navigation subroutines ##############################################
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