strmode in Perl (convert octal permissions to symbolic)

[afresh1]

In the opposite line of 'ls' with octal permissions, I had a need for strmode(3) while doing a perl rewrite of the OpenBSD's /etc/security. It was odd, but I couldn't find a BSD licensed port, it was fairly straightforward to do, but I wanted to put it here so others may be able to find it.

I also have it in my CVS repository, so check there for updates.

#!/usr/bin/perl -T

# $AFresh1: perl_strmode.pl,v 1.3 2011/03/27 21:27:25 andrew Exp $
#
# Copyright (c) 2011 Andrew Fresh <[e-mail]>
# 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 t
+he
#    documentation and/or other materials provided with the distributi
+on.
# 3. Neither the name of the University nor the names of its contribut
+ors
#    may be used to endorse or promote products derived from this soft
+ware
#    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, TH
+E
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR P
+URPOSE
# ARE DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LI
+ABLE
# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQU
+ENTIAL
# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GO
+ODS
# 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 AN
+Y 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 <[e-mail]>

    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? Is S_IFIFO ever not set?
        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) {
    my ( $mode, $nlink, $uid, $gid, $size, $mtime )
        = ( lstat $file )[ 2 .. 5, 7, 9 ]
            or next;

    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;
}

update: fix from jwkrahn

[jwkrahn]

Your code won't display symbolic links properly because you are using stat instead of lstat.

Just change:

    next unless -e $file;
    my ( $mode, $nlink, $uid, $gid, $size, $mtime )
        = ( stat(_) )[ 2 .. 5, 7, 9 ];

To:

    my ( $mode, $nlink, $uid, $gid, $size, $mtime )
        = ( lstat $file )[ 2 .. 5, 7, 9 ]
            or next;

[afresh1]

Thanks, fixed.

[educated_foo]

Or, for a less verbose version that doesn't require taint mode, 5.10, or a shouty license (consider it public domain):

use Fcntl ':mode';

my %TYPE = (S_IFDIR,'d',S_IFCHR,'c',S_IFBLK,'b',S_IFREG,'-',S_IFLNK,'l
+',
            S_IFSOCK,'s');

sub o
{
    my ($mode, $xr, $xid) = @_;
    (($mode & ($xr | $xid)) == ($xr | $xid)) ? 's'
        : ($mode & $xr) ? 'x' : ($mode & $xid) ? 'S' : '-';
}

sub strmode
{
    my ($mode) = @_;
    ($TYPE{$mode & S_IFMT} || '?')
        . (($mode & S_IRUSR) ? 'r' : '-')
        . (($mode & S_IWUSR) ? 'w' : '-')
        . o($mode, S_IXUSR, S_ISUID)
        . (($mode & S_IRGRP) ? 'r' : '-')
        . (($mode & S_IWGRP) ? 'w' : '-')
        . o($mode, S_IXGRP, S_ISGID)
        . (($mode & S_IROTH) ? 'r' : '-')
        . (($mode & S_IWOTH) ? 'w' : '-')
        . o($mode, S_IXOTH, S_ISVTX)
}

EDIT: Actually, this problem makes a decent golf hole. Given some files in @ARGV, print "modestring file\n" for each file. Here's a start (283 262 222 203 strokes w/o newlines):

#!/usr/bin/perl -l
sub i{'-'}
sub o{$m&$_[0]?$m&$_[1]?'s':x:$m&$_[1]?S:i}
print qw(? c d b - l s)[($m=(lstat)[2])>>13]
,$m&256?r:i
,$m&128?w:i
,o(64,2048)
,$m&32?r:i
,$m&16?w:i
,o(8,1024)
,$m&4?r:i
,$m&2?w:i
,o(1,512)
," $_"for@ARGV;

EDIT: Or, with bitwise goodness, 131 127:

#!/usr/bin/perl -l
for$f(@ARGV){
$_=sprintf"%9b",($m=(lstat$f)[2])&511;
y/01/\0\xff/;
$_&=rwxrwxrwx;
y/\0/-/;
print qw(? c d b - l s)[$m>>13],"$_ $f"
}

[repellent]

In CPAN, got Stat::lsMode.