jv@mhres.mh.nl (Johan Vromans) (12/09/89)
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@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@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" -------------------------