#!/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://kinzler.com/me/vshnu/
# http://kinzler.com/me/home.html#unix

###############################################################################
## Change log and To do #######################################################

($vname, $version) = qw(vshnu 1.0304);

# 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
# 1.0303  15 Aug 2008   Use "use lib" vs "unshift @INC"
# 1.0304  12 Feb 2009   Use &quote($_) vs $_q in &run

# 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)

###############################################################################
## 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(' ', &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;

@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/;
        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'}))) {
                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;
        $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 = (! 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 =~ /=/) ? (($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 =~ /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 unless $df;
        $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');
        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 (reverse sort keys %mag) {
                        ($f, $s) = (1024 ** $_, $mag{$_}), last
                                if $t > 1024 ** ($_ + 1);
                }
                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 -= 3;
        return '' if $n < 0;
        my $p = &ceil($n / 2);
        (substr($s, 0, $p), '...', 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;
}