File: [local] / misc / strmode / perl_strmode.pl (download)
Revision 1.2, Sun Mar 27 21:26:33 2011 UTC (13 years, 3 months ago) by andrew
Branch: MAIN
Changes since 1.1: +25 -11 lines
keep the university license, I don't think it is needed, but IANAL
|
#!/usr/bin/perl -T
# $AFresh1: perl_strmode.pl,v 1.2 2011/03/27 21:26:33 andrew Exp $
#
# Copyright (c) 2011 Andrew Fresh <andrew@afresh1.com>
# Copyright (c) 1990 The Regents of the University of California.
# All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions
# are met:
# 1. Redistributions of source code must retain the above copyright
# notice, this list of conditions and the following disclaimer.
# 2. Redistributions in binary form must reproduce the above copyright
# notice, this list of conditions and the following disclaimer in the
# documentation and/or other materials provided with the distribution.
# 3. Neither the name of the University nor the names of its contributors
# may be used to endorse or promote products derived from this software
# without specific prior written permission.
#
# THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
# ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
# SUCH DAMAGE.
use warnings;
use strict;
use 5.010;
use Fcntl ':mode';
sub strmode {
# Perl port of OpenBSD: lib/libc/string/strmode.c,v 1.7
# by Andrew Fresh <andrew@afresh1.com>
my ($mode) = @_;
my $p = '';
# print type
given ( $mode & S_IFMT ) {
when (S_IFDIR) { $p .= 'd' } # directory
when (S_IFCHR) { $p .= 'c' } # character special
when (S_IFBLK) { $p .= 'b' } # block special
when (S_IFREG) { $p .= '-' } # regular
when (S_IFLNK) { $p .= 'l' } # symbolic link
when (S_IFSOCK) { $p .= 's' } # socket
#ifdef S_IFIFO XXX How important is this ifdef?
when (S_IFIFO) { $p .= 'p' } # fifo
#endif
default { $p .= '?' } # unknown
}
# usr
$p .= ( $mode & S_IRUSR ) ? 'r' : '-';
$p .= ( $mode & S_IWUSR ) ? 'w' : '-';
given ( $mode & ( S_IXUSR | S_ISUID ) ) {
when (0) { $p .= '-' }
when (S_IXUSR) { $p .= 'x' }
when (S_ISUID) { $p .= 'S' }
when ( S_IXUSR | S_ISUID ) { $p .= 's' }
}
# group
$p .= ( $mode & S_IRGRP ) ? 'r' : '-';
$p .= ( $mode & S_IWGRP ) ? 'w' : '-';
given ( $mode & ( S_IXGRP | S_ISGID ) ) {
when (0) { $p .= '-' }
when (S_IXGRP) { $p .= 'x' }
when (S_ISGID) { $p .= 'S' }
when ( S_IXGRP | S_ISGID ) { $p .= 's' }
}
# other
$p .= ( $mode & S_IROTH ) ? 'r' : '-';
$p .= ( $mode & S_IWOTH ) ? 'w' : '-';
given ( $mode & ( S_IXOTH | S_ISVTX ) ) {
when (0) { $p .= '-' }
when (S_IXOTH) { $p .= 'x' }
when (S_ISVTX) { $p .= 'T' }
when ( S_IXOTH | S_ISVTX ) { $p .= 't' }
}
$p .= ' '; # will be a '+' if ACL's implemented
return $p;
}
my @files = @ARGV;
@files = '.' unless @files;
foreach my $file (@files) {
next unless -e $file;
my ( $mode, $nlink, $uid, $gid, $size, $mtime )
= ( stat(_) )[ 2 .. 5, 7, 9 ];
my $time = localtime($mtime);
$time =~ s/^\w+\s+//;
printf "%s %2s %-7s %-7s %8d %s %s\n",
strmode($mode),
$nlink,
( getpwuid($uid) )[0],
( getgrgid($gid) )[0],
$size, $time, $file;
}