#!/afs/athena/contrib/perl/perl

# lsinfo.pl -- ls -l for perl
# SCCS Status     : @(#)@ lsinfo.pl	1.3
# Author          : Johan Vromans
# Created On      : ***
# Last Modified By: Johan Vromans
# Last Modified On: Mon Sep 30 10:57:54 1991
# Update Count    : 9
# Status          : OK

# This package defines one function in package main:
#
#	&lsinfo($filename)
#
# which returns an "ls -l" compatible string for the given file.
#
# Other probably useful entry points are:
#
#  &lsinfo'fmt_time(time)	-> "Nov 30 16:30"
#  &lsinfo'fmt_mode(0755)	-> "-rwx-rx-rx-"
#  &lsinfo'fmt_uid($<)		-> user-name (with caching)
#  &lsinfo'fmt_gid($()		-> group-name (with caching)

# Copyright 1989 Johan Vromans
# This package is hereby declared public domain

# This program requires Perl version 3.0, patchlevel 4 or later.

package lsinfo;

$do_gid = 1;

sub main'lsinfo {

  local ($name) = shift(@_);
  local (@st);
  local ($res);
  local ($fmt) = sprintf ("%%s%%4s %%-9s%s%%8s %%s %%s", $do_gid ? "%-8s" : "%s");

  @st = lstat ($name);
  return undef if $#st < $[;	# empty array -> cannot stat

  $res =
    sprintf ($fmt,
	     &fmt_mode ($st[2]),
	     $st[3], &fmt_uid ($st[4]), 
	     $do_gid ? &fmt_gid ($st[5]) : "",
	     $st[7],
	     &fmt_time ($st[9]),
	     $name);

  # add real name if symbolic link
  if (($st[2] & 0170000) == 0120000) {
    eval ('$res .= " -> " . readlink ($name)');
  }
  return $res;
}

sub fmt_mode {
  local ($mode) = shift (@_);

  return
    substr(" fc d b -nl s   ", ($mode & 0170000) >> 12, 1) .
    (( $mode & 000400) ? "r" : "-") .
    (( $mode & 000200) ? "w" : "-") .
    (( $mode & 000100) 
	? (( $mode & 004000) ? "s" : "x")
	: (( $mode & 004000) ? "S" : "-")) .
    (( $mode & 000040) ? "r" : "-") .
    (( $mode & 000020) ? "w" : "-") .
    (( $mode & 000010)
	? (( $mode & 002000) ? "s" : "x")
	: (( $mode & 002000) ? "S" : "-")) .
    (( $mode & 000004) ? "r" : "-") .
    (( $mode & 000002) ? "w" : "-") .
    (( $mode & 000001)
	? (( $mode & 001000) ? "t" : "x")
	: (( $mode & 001000) ? "T" : "-"));
}

# Make a "ls" type time string

@months= ( "Jan", "Feb", "Mar", "Apr", "May", "Jun",
	   "Jul", "Aug", "Sep", "Oct", "Nov", "Dec");

# Amount of time after which to use "Nov 30  1989" instead of "Nov 30 16:30"
# Default is 180 days
$time_limit = 180*24*60*60;

sub fmt_time {
  local ($time) = shift (@_);
  local (@tm) = localtime ($time);
  return
    ( $time > (time - $time_limit) )
      ? sprintf ("%s %2d %2d:%02d",
		 $months[$tm[4]], $tm[3], $tm[2], $tm[1])
      : sprintf ("%s %2d  19%02d",
		 $months[$tm[4]], $tm[3], $tm[5]);
}

# get user name from id - with cacheing

%uids = ();
$uid_status = 0;	# 0: not started, 1: busy, 2: complete

sub fmt_uid {
  local ($id) = shift (@_);
  local (@a);

  if ( $uid_status == 0 ) {
    setpwent;
    $uid_status = 1;
  }
  else {
    return $uids{$id} if defined $uids{$id};
  }

  return $id if $uid_status > 1;

  while (@a = getpwent) {
    # enter in table, not overriding exisiting values
    $uids{$a[2]} = $a[0] unless defined $uids{$a[2]};
    return $a[0] if $a[2] == $id;
  }
  endpwent;
  $uid_status = 2;

  return ($id);
}

# get group name from id - with cacheing

%gids = ();
$gid_status = 0;	# 0: not started, 1: busy, 2: complete

sub fmt_gid {
  local ($id) = shift (@_);
  local (@a);

  if ( $gid_status == 0 ) {
    setpwent;
    $gid_status = 1;
  }
  else {
    return $gids{$id} if defined $gids{$id};
  }

  return $id if $gid_status > 1;

  while (@a = getgrent) {
    # enter in table, not overriding exisiting values
    $gids{$a[2]} = $a[0] unless defined $gids{$a[2]};
    return $a[0] if $a[2] == $id;
  }
  endgrent;
  $gid_status = 2;

  return ($id);
}

if ( $0 eq __FILE__ ) {		# standalone mode
    package main;
    die ("Usage: $0 files...\n") unless $#ARGV >= 0;
    foreach ( @ARGV ) {
	if ($retval = &lsinfo ($_)) {
	    print $retval, "\n";
	}
	else {
	    print "$_: $!\n";
	}
    }
}
1;
