#!/usr/bin/perl -w

# mls - Fancy PERL version of the original mls, which was
# #alias mlsnoigc 'madr < ~/bin/madrls |& grep entry | sed s/".*file name: "// | sed s/FORTRAN// | awk -f ~/bin/madrfix.awk | sort -n | uniq'
# alias mlsnoigc 'madr < <a href="madrls">~/bin/madrls</a> | sed "s/^.*file name: //" | grep entry | awk -f <a href="madrfix.awk">~/bin/madrfix.awk</a> | sort -n | uniq'
# alias mls 'mlsnoigc | igc ".*\!*"'

# Unlike the original, it highlights definitions, knows when to supply
# empty slot info, and can take more than one pattern.  Despite all this,
# it seems to be somewhat faster.
#
# Highlighting
# ------------
# Bold:              File is readable, and madr will ask questions if you
#                    try to neg the definition.
# Cyan:              File is a symbolic link.
# Yellow background: The definition is not the only one to reference that file!

# Partly inspired by Example 4.18 of The Perl Cookbook.

# Wish list:
#
#    Make it more portable
#        i.e. it does not work on cass because cass does not have
#             Term::ANSIColor.  I do not need it much on cass, but YMMV.
#
#    Have a term width function that actually works!
#        cgps03 (PERL 5.8.3, Fedora) does not have Term::ReadKey.
#
#    mls -l anyone?  i.e.:
#        1 NP11.MQ21        256  1 mJy/b  21h08m15.88s, 89d00'00.0"
#        9 IA1ADQQACI.MQ21 1024  1 mJy/b  21h08m15.88s, 63d34'22.2"
#       10 IA1QQA.V21CJ     960  1 mJy/b  21h08m15.88s, 63d34'22.2"
#       17 IA1AJQQACK.P21  1024    none   21h08m15.88s, 63d34'22.2"
#
#       This should really take a format string (or even 2, for images and
#       visibilities) to customize what is displayed.
#       See DRAORed.pm's readdef().
#
# 4/26/2004: No longer needs write permission in the directory.

use strict;
use Term::ANSIColor qw(:constants);
#use DRAORed;

# Returns $dirna/$fn for the first $dirna in @dirposs for which $dirna/$fn
# would be writable.  Dies if none is found.
sub writable {
  my ($fn, @dirposs) = @_;

  foreach my $dirna (@dirposs){
    $dirna =~ s/^~/$ENV{HOME}/;    # Sadly necessary
    my $possres = "$dirna/$fn";
    return $possres if(-w $dirna && (!(-e $possres) || -f $possres));
  }

  # Only gets here on failure.
  die "$fn not writable in any of @dirposs";
}

# Returns a hash keyed by madr index of filenames (according to the madr
# definitions) matching any of the given list of madr patterns.  The list
# of patterns defaults to ". _" if none is given.
sub hashna {
  my @fnpatterns = @_;

  my $verbose = 0;
  if(@fnpatterns == 0){
    @fnpatterns = (".", "_");    # Default pattern.
    $verbose = 1;
  }

  # Use ./index.madrout if it is writable, otherwise ~/tmp/index.madrout if
  # that will work, otherwise ~/index.madrout, otherwise die!
  my $madroutput = writable("index.madrout", ".", "~/tmp", "~");

  open(MADR, "|madr > $madroutput 2> /dev/null")
     or die "Could not start |madr > $madroutput 2> /dev/null";
  print MADR "name\n";
  for my $mpat (@fnpatterns) {
    print MADR "$mpat\n";
  }
  print MADR "\n";
  print MADR "exit\n";
  close(MADR);

  my %mhash = ();
  open(MADROUT, $madroutput) or die "Could not open $madroutput";
  while (<MADROUT>) {
    if (/ (\S+)\s*, entry: (\d+)/) {
      $mhash{$2} = $1;
    }
    if($verbose){
      if(/(\d+ +empty slots, \d+ +is first one)/){
	my $info = $1;
	chomp $info;
	$info =~ s/\s+/ /g;
	print "${info}.\n\n";
      }
    }
  }
  close(MADROUT) or die "Could not close $madroutput";
  unlink($madroutput) or warn "Could not unlink $madroutput";

  return \%mhash;
}

my $mnfns = hashna(@ARGV);
my %seen = ();
my (@indnums, @filnams);

my $maxlen = 1;
for my $key (sort {$a <=> $b} keys %{$mnfns}){
  my $mylen = length($mnfns->{$key}) + 3;
  if($mylen > $maxlen){
    $maxlen = $mylen;
  }
  push(@indnums, $key);
  push(@filnams, $mnfns->{$key});
  ++$seen{$mnfns->{$key}};
}

# determine boundaries of screen
my ($item, $cols, $rows);
my ($xpixel, $ypixel, $mask);

#($cols, $rows, $ypixel, $xpixel) = GetTerminalSize();
getwinsize();

$cols = int($cols / ($maxlen + 4)) || 1;
$rows = int(($#indnums + $cols) / $cols);

# pre-create mask for faster computation
$mask = sprintf("%%-%ds ", $maxlen - 3);

# Subroutine to check if at last item on line.
sub EOL { ($item + 1) % $cols == 0 }

## Check for duplicate definitions.
#my %hssdf = reverse %mnfns;
#my %mnfns2 = reverse %hssdf;
#print "There is a dupe!\n" if(%mnfns2 ne %mnfns);

# now process each item, picking out proper piece for this position
for ($item = 0; $item < $rows * $cols; $item++) {
  my $target =  ($item % $cols) * $rows + int($item / $cols);
  my $piece;
  if($target < @indnums){
    # Putting the column separation space into the number makes background
    # coloring look better, but it requires testing for 1st columnness.
    if($item % $cols){
      $piece = sprintf("%5d ", $indnums[$target]);
    }
    else{
      $piece = sprintf("%3d ", $indnums[$target]);
    }
    print $piece;

    $piece = sprintf($mask, $filnams[$target]);
    $piece =~ s/\s+$// if EOL();                 # Don't blank-pad to EOL

    print ON_YELLOW if($seen{$filnams[$target]} > 1);
    print CYAN      if(-l $filnams[$target]);     # Apparently symbolic
    print BOLD      if(-r $filnams[$target]);     # links are also plain files.

    # Special check for madr families.
    if($filnams[$target] =~ /(\w+)\.@@/){
      print BOLD if(-f "${1}.01");        # At least it has its 1st member.
    }

    print $piece, RESET;
  }
  else{
    print "";
  }
  print "\n" if EOL();
}

print "\n" if EOL();                     # Finish up if needed.

# Not portable -- linux only (and not even Fedora! - RR), but it defaults
# to 80 columns.
sub getwinsize {
    my $winsize = "\0" x 8;
    my $TIOCGWINSZ = 0x40087468;
    if (ioctl(STDOUT, $TIOCGWINSZ, $winsize)) {
        ($rows, $cols, $xpixel, $ypixel) = unpack('S4', $winsize);
    } else {
        $cols = 80;
    }
}