#!/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;

# 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.0308);

# 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_COLORS[23] (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
# 1.0303  15 Aug 2008	Use "use lib" vs "unshift @INC"
# 1.0304  12 Feb 2009	Use &quote($_) vs $_q in &run
# 1.0305  28 May 2009	Add L flag to &run
# 1.0306   3 Aug 2009	Add f and F flags to &run
# 1.0307   7 Jan 2011	Add $dotdotdot; Add lazy command evaluation
# 1.0308  21 Sep 2011	Fix &df to always refresh and &diskspace align bug

# To Consider and Do:
# * Add choose mode key commands for per-file versions of : and ; commands
#   + Like a built-in `apply 'foo %1 bar' @chosen`
# * 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
# * Preserve data state across restarts with Storable module
# * 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
# * Package for CPAN as App::Vshnu (ala App::Ack)
# * Package for Ubuntu/Debian
# * UTF-8 support
# * Use terminfo instead of termcap, which is losing support
# * use ttyrec, ttyplay and www.playterm.org to make samples and tutorials

###############################################################################
## 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
#se	Term::ReadLine::Gnu;	# for ckperl(1)
	# but on Ubuntu, may need `apt-get install libterm-readline-gnu-perl`

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(' ', &quote(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;
$dotdotdot ||= '...';

@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);
	$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;			# =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;
	$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;
}

###############################################################################
## 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)
						- 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, 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/;
	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);
}

###############################################################################
## Color and tag subroutines ##################################################

sub tag {
	if    (-l $_[0])   { return '@' }	# -l first to force lstat
	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 {
	return $_[0]	    if $_[0] eq '' || $#_ <= 0 || ! &opt('*');
	return &colored(@_) if $color;
	($_[1] eq 'bold')    ? $bold    . $_[0] . $normal :
	($_[1] eq 'reverse') ? $reverse . $_[0] . $normal :
	($_[1] eq '')	     ?		  $_[0]		  : &colored(@_);
}

sub decolor {	# vs Term::ANSIColor's "uncolor"
	my @r = @_;
	foreach (@r) { s/\e\[[^m]*m//gs }
	$#r ? @r : shift @r;
}

# We assume the visible segment of the given colored text does not also
# appear in either non-visible segment.
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 = '';

	# We sacrifice orphan detection to avoid automounts via symlinks.
	if    (-l $file)   { $c = 'ln' }  #(-e readlink $file) ? 'ln' : 'or' }
	elsif (-f _)	   { $c = 'ex' if (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 { $ansicolor{$_ + 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;
	$_;
}

###############################################################################
## File selection subroutines #################################################

sub dotypepath {
	my $t = &untilde($_[0]);
#	return &dotype($t) if $t =~ /^(\/|$)/;	# old behavior
	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;
	}
#	&dotype($t);	# old behavior if file not found
	&beep(); &win();
}

# There's a glitch here in that the uncompleted word is also considered a
# potential completion match even if it doesn't exist.  Shifting it off from
# the beginning of what completion_matches returns causes worse problems.

sub completetypepath {		# only call if $rlmodule eq 'Gnu'
	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 {	# ala csh's variable modifiers ($var:m)
	($_r = $_) =~ s/\.([^.]*)$//; $_e = $1;
	(/\//) ? (($_h = $_) =~ s/\/([^\/]*)$//, $_t = $1) :
		 ( $_h = '',			 $_t = $_);
	$_f  = &absfile($_);
	$_m  = &mimetype($_);
	($_q, $_rq, $_eq, $_hq, $_tq, $_fq, $_mq) =
		map { &quote($_) } ($_, $_r, $_e, $_h, $_t, $_f, $_m);
	$_d  = ($_ eq '') ? '' : `file -L $_q 2> /dev/null`; chomp $_d;
	$_dq = &quote($_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] . '/') }

###############################################################################
## File operation subroutines #################################################

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");
}

###############################################################################
## Change directory subroutines ###############################################

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'});
}

###############################################################################
## Mark subroutines ###########################################################

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);
}

###############################################################################
## Listing subroutines ########################################################

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(' ', &quote(@_))/eg unless $p;
	if ($long =~ /\$_\b/) {
		foreach (@_) {
			last if $_ eq '';
			my $c = $cmd;
			$c =~ s/\$_\b/&quote($_)/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;
}

###############################################################################
## Options subroutines ########################################################

sub initopts { %opts = () }
sub opts     { join('', sort keys %opts) }

sub setopt {
	my($opt, $val) = @_;		# set opt to bool val, toggle if no val
	return(($val || ! exists $opts{$opt})
	       ? do { $opts{$opt} = 1 } : do { delete $opts{$opt}; 1 })
			if length($opt) == 1 && index($optkeys, $opt) >= 0;
	0;				# return whether valid opt
}

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] : ());
}

###############################################################################
## Sorting subroutines ########################################################

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]);
}

###############################################################################
## Directory expansion subroutines ############################################

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 {		# depth < 0 means no limit
	my $dir = shift; my $dep = shift; my @ret = ();
	return @ret if $dep == 0; # || ! -d $dir;
	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'}};
}

###############################################################################
## Mouse subroutines ##########################################################

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 {				# See also xterm doc ctlseqs.*
	return 0 unless $mouse;
	print((($_[0] =~ /^tog/i) ? ($moused = $moused ? 0 : 1) :
	       ($_[0] =~ /./)	  ? $_[0] : $moused) ?
# X10 compatibility mode: only unmodified Button 1-3 down
#			"\e[?9h"    : "\e[?9l"
# VT200-style normal tracking mode: adds modifiers, Button up, Wheel
			"\e[?1000h" : "\e[?1000l"
	     );
}						

# In some older terms, it's been observed that Wheel events are detected
# as Button up events. *shrug*
# It's been seen that a very quick Button 1 down/up may not be detected
# correctly, leading to a confusing series of unexpected vshnu commands
# being executed.  Don't know where the cause is, but it doesn't appear
# to ever happen on fast computers with a locally running new xterm.

# Since Button 1-3 up events don't identify their Button, we track the
# last Button 1-3 down event and assume a Button 1-3 up event was on that
# last Button, even though it may not be so if Button 1-3 up/down events
# are interleaved.  Then the stray Button up events are beeped and ignored.

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);	# ';' .. 'z'
	}
	$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;	# sic
}

###############################################################################
## Help and prompt subroutines ################################################

sub help {	# -u* = list unused keys, -U* = list unused key ranges
	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 '' &&	# kludge, non-recursive
		    $$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 {	# limited to 26 default keys (a-z), not guaranteed unique
	my $a = 'a';
	foreach my $cmd (@{$_[0]}) {
		next if defined $$cmd[2];
		$$cmd[2] = $a++;
		last if length($a) > 1;
	}
	@{$_[0]};
}

###############################################################################
## Operation subroutines ######################################################

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;				# clear space from readline completion
}

sub get      { &rlhistget(\@rlhist_,	  @_) }
sub getshell { &rlhistget(\@rlhist_shell, @_) }
sub getjunk  { &rlhistget(\@rlhist_junk,  @_) }

sub getfile  {
	local $_ = &rlhistget(\@rlhist_file, @_);
	s/ $// unless s/\\ $/ /;	# clear space from readline completion
	$_;
}

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 {	# run a command with perl if initial ";" or ":" else shell
	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(' ', ' --', &quote(@choose))))  :
	($opts =~/\+/) ? (($marg) ? push(@args, @choose)
				  : ($args[$#args] .=
					join(' ', '',    &quote(@choose))))  :
	($opts =~ /F/) ? (($marg) ? push(@args, '--', $_f)
				  : ($args[$#args] .= ' -- ' . &quote($_f))) :
	($opts =~ /f/) ? (($marg) ? push(@args, $_f)
				  : ($args[$#args] .= ' '    . &quote($_f))) :
	($opts =~ /=/) ? (($marg) ? push(@args, '--', $_)
				  : ($args[$#args] .= ' -- ' . &quote($_)))  :
	($opts =~ /_/) ? (($marg) ? push(@args, $_)
				  : ($args[$#args] .= ' '    . &quote($_)))  :
	undef;

	@args = join(' ', ($marg) ? &quote(@args) : @args)
		if $opts =~ /[gPpb]/;
	($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', /;
	$_;
}

###############################################################################
## Perl environment subroutines ###############################################

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;
}

###############################################################################
## MIME-related subroutines ###################################################

# We circumvent the Mail::Cap methods a bit here (see comments), so this
# may break.  Also, we may miss some valid mailcap entries because their
# 'test' clauses fail with our fake file '%s'.

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) {		# Mail::Cap circumvention
		next if $type =~ /^_|'/;	# Mail::Cap circumvention
		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;
}

# Non-standard field extensions to mailcap entries are:
#   dontneedterminal = an X11 command not needing a terminal
#	(note that the standard needsterminal is otherwise assumed true)
#   shortview, shortedit, shortprint = shorter command versions for description

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]/;	# unsupported macros
	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 = &quote($_);
				       $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;
}

###############################################################################
## Disk subroutines ###########################################################

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();
}

sub diskdevs {
	return () unless &df();
	grep { /^\// && ! /^\/\// } map { $df->device($_) } $df->disks();
}

sub diskspace {
	my @args = @_ ? @_ : (&pwd());	# &df trashes @_
	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;
	$_;
}

###############################################################################
## System interface subroutines ###############################################

# With perl 5.8's safe signals, vshnu's behavior when suspending from within
# readline will differ.  With earlier perls, suspension is immediate.
# With perl 5.8, the suspension is postponed until a return is typed
# in readline.  This behavior is suboptimal, but tolerable.  I don't see
# a way around it.

# With perl 5.8's safe signals, vshnu's behavior when suspending from
# within a subprocess will differ.  With earlier perls, continuation works
# as expected.  With perl 5.8, continuation results in both vshnu and
# the subprocess active and sharing input.  This behavior is problematic.
# Hence the following kludge to set $SIG{'TSTP'} = 'DEFAULT' with perls
# >= 5.8.  This works at the sacrifice of directory and environment
# coordination between vshnu and its invoking shell when suspending from
# a subprocess.

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() };
	# These stty commands can have the unfortunate side-effect of
	# changing a setting that the user may not want changed, even
	# outside of vshnu -- eg -istrip for 8-bit characters.  You
	# can run `setty -istrip` in tcsh, at least, to prevent it
	# from being changed in tcsh's context.  You may also define
	# $stty_cooked and $stty_raw to make corrections.
	#
	# Should we use POSIX termios here instead of `stty`?
	# See eg http://tit.irk.ru/perlbookshelf/cookbook/ch15_09.htm
	# But Term::Screen is `stty` based ...
}

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();	# partly broken in Term::Screen 1.00- *shrug*
	&mousemode();
	$ch . '';
}

sub getstr {
	&bakescr($cooked = 1);
	&winch_off();
	my $str = $rl->readline((! @_) ? '' : join(' ',
	    ($rlmodule ne 'Gnu') ? @_ :	# Perl RL breaks, but nice indic anyway
	    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;
}

###############################################################################
## System accomodation subroutines ############################################

# With Term::Screen 1.03's attempted Solaris fixes, vshnu resizing broke
# under Solaris.  So we temporarily pretend not to be solaris to avoid these
# "fixes" and stick with the old solution of putting /usr/ucb at the head
# of the PATH.

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;
	}
}

###############################################################################
## Master shell interface subroutines #########################################

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;
}

###############################################################################
## Wrapper subroutines ########################################################

sub myeval {
	my $cmd = &run_syntax(@_);
	@_	= @_argv;
	my @r	= eval $cmd;
	&err($@) if $@;
	@r;
}

sub myctime {		# Internet (Swatch) Time
	(($_[1]) ? sprintf("@%03d ", int(($_[0] + 3600) % 86400 / 86.4)) : '')
	. localtime($_[0]);
}

sub xsh {
	&err('DISPLAY not defined'), return unless $ENV{'DISPLAY'};
	&sh(join(' ', ($#_ > 0) ? &quote(@_) : @_, '&'));
}

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);
}

###############################################################################
## Text subroutines ###########################################################

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;
	$_;
}

###############################################################################
## General subroutines ########################################################

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;
}