Another useful perl tool

[Johan Vromans]

This package defines some useful functions on the formatting of "stat"
values.

It defines one main'function:

  &lsinfo($filename)

which returns a string like

  "-rw-r--r--   1 jv       bsp         3272 Dec  8 22:01 lsinfo.pl"

Other useful entry points are:

  &lsinfo'fmt_time(time)	-> "Nov 30 16:30"
  &lsinfo'fmt_mode(0755)	-> "-rwx-rx-rx-"
  &lsinfo'fmt_uid($<)		-> user-name
  &lsinfo'fmt_gid($()		-> group-name

The demo program "ll" is just fun to have.

Don't call this "ls in perl", or you'll start another perl vs.
whatever war :-) .

#!/bin/sh
# This is a shell archive.  Remove anything before this line,
# then unpack it by saving it in a file and typing "sh file".
#
# Wrapped by Johan Vromans <jv at mhres> on Fri Dec  8 22:23:08 1989
#
# This archive contains:
#	README		ll		lsinfo.pl	
#
# Error checking via wc(1) will be performed.

LANG=""; export LANG

echo x - README
cat >README <<'@EOF'
This package defines some useful functions on the formatting of "stat"
values.

It defines one main'function:

  &lsinfo($filename)

which returns an "ls -l" compatible string for the given file.

Other useful entry points are:

  &lsinfo'fmt_time(time)	-> "Nov 30 16:30"
  &lsinfo'fmt_mode(0755)	-> "-rwx-rx-rx-"
  &lsinfo'fmt_uid($<)		-> user-name
  &lsinfo'fmt_gid($()		-> group-name

The demo program "ll" is just fun to have.

@EOF
set `wc -lwc <README`
if test $1$2$3 != 1856432
then
	echo ERROR: wc results of README are $* should be 18 56 432
fi

chmod 644 README

echo x - ll
cat >ll <<'@EOF'
#!/usr/bin/perl

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

# Demo for "lsinfo" package.
#
# Any resemblance to the semantics of a certain "ls -l" command is not 
# by accident :-).

do "lsinfo.pl"; die "Error loading \"lsinfo.pl\"\n$@" if $@;

if ( $#ARGV < 0 ) {
  @ARGV = readdir (dot) if opendir (dot, ".");
}

foreach $f ( @ARGV ) {
  if ( $info = &lsinfo ($f) ) {
    $info{$f} = $info;
  }
  else { print "$f not found.\n"; }
}

foreach $f (sort (keys (%info))) {
  print $info{$f}, "\n";
}
@EOF
set `wc -lwc <ll`
if test $1$2$3 != 2596521
then
	echo ERROR: wc results of ll are $* should be 25 96 521
fi

chmod 755 ll

echo x - lsinfo.pl
cat >lsinfo.pl <<'@EOF'
# This package defines one function:
#
#	&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
#  &lsinfo'fmt_gid($()		-> group-name
#
# Copyright 1989 Johan Vromans
#
# This package is hereby declared public domain

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

package lsinfo;

sub main'lsinfo {

  local ($name) = shift(@_);
  local (@st);
  local ($res);


  return unless @st = lstat ($name);

  $res =
    sprintf ("%s%4s %-9s%-9s %6s %s %s",
	     &fmt_mode ($st[2]),
	     $st[3], &fmt_uid ($st[4]), &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;
}

@types = (" ","f","c"," ","d"," ","b"," ","-","n","l"," ","s"," "," "," ");
sub fmt_mode {
  local ($mode) = shift (@_);

  return
    $types[($mode & 0170000) >> 12] .
    (( $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);
}
@EOF
set `wc -lwc <lsinfo.pl`
if test $1$2$3 != 1465573272
then
	echo ERROR: wc results of lsinfo.pl are $* should be 146 557 3272
fi

chmod 644 lsinfo.pl

exit 0
-- 
Johan Vromans				       jv at mh.nl via internet backbones
Multihouse Automatisering bv		       uucp: ..!{uunet,hp4nl}!mh.nl!jv
Doesburgweg 7, 2803 PL Gouda, The Netherlands  phone/fax: +31 1820 62944/62500
------------------------ "Arms are made for hugging" -------------------------