Return to perl_strmode.pl CVS log

Up to [local] / misc / strmode

Annotation of misc/strmode/perl_strmode.pl, Revision 1.5

1.1       andrew      1: #!/usr/bin/perl -T
                      2:
1.5     ! andrew      3: # $AFresh1: perl_strmode.pl,v 1.4 2011/03/28 02:37:48 andrew Exp $
1.1       andrew      4: #
                      5: # Copyright (c) 2011 Andrew Fresh <andrew@afresh1.com>
1.2       andrew      6: # Copyright (c) 1990 The Regents of the University of California.
                      7: # All rights reserved.
1.1       andrew      8: #
1.2       andrew      9: # Redistribution and use in source and binary forms, with or without
                     10: # modification, are permitted provided that the following conditions
                     11: # are met:
                     12: # 1. Redistributions of source code must retain the above copyright
                     13: #    notice, this list of conditions and the following disclaimer.
                     14: # 2. Redistributions in binary form must reproduce the above copyright
                     15: #    notice, this list of conditions and the following disclaimer in the
                     16: #    documentation and/or other materials provided with the distribution.
                     17: # 3. Neither the name of the University nor the names of its contributors
                     18: #    may be used to endorse or promote products derived from this software
                     19: #    without specific prior written permission.
1.1       andrew     20: #
1.2       andrew     21: # THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
                     22: # ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
                     23: # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
                     24: # ARE DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
                     25: # FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
                     26: # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
                     27: # OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
                     28: # HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
                     29: # LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
                     30: # OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
                     31: # SUCH DAMAGE.
1.1       andrew     32:
                     33: use warnings;
                     34: use strict;
                     35: use 5.010;
                     36:
                     37: use Fcntl ':mode';
                     38:
                     39: sub strmode {
                     40:
                     41:     # Perl port of OpenBSD: lib/libc/string/strmode.c,v 1.7
                     42:     # by Andrew Fresh <andrew@afresh1.com>
                     43:
                     44:     my ($mode) = @_;
                     45:     my $p = '';
                     46:
                     47:     # print type
                     48:     given ( $mode & S_IFMT ) {
                     49:         when (S_IFDIR)  { $p .= 'd' }    # directory
                     50:         when (S_IFCHR)  { $p .= 'c' }    # character special
                     51:         when (S_IFBLK)  { $p .= 'b' }    # block special
                     52:         when (S_IFREG)  { $p .= '-' }    # regular
                     53:         when (S_IFLNK)  { $p .= 'l' }    # symbolic link
                     54:         when (S_IFSOCK) { $p .= 's' }    # socket
1.3       andrew     55: #ifdef S_IFIFO XXX How important is this? Is S_IFIFO ever not set?
1.1       andrew     56:         when (S_IFIFO) { $p .= 'p' }     # fifo
1.3       andrew     57: #endif
1.1       andrew     58:         default { $p .= '?' }            # unknown
                     59:     }
                     60:
                     61:     # usr
                     62:     $p .= ( $mode & S_IRUSR ) ? 'r' : '-';
                     63:     $p .= ( $mode & S_IWUSR ) ? 'w' : '-';
                     64:     given ( $mode & ( S_IXUSR | S_ISUID ) ) {
                     65:         when (0)                   { $p .= '-' }
                     66:         when (S_IXUSR)             { $p .= 'x' }
                     67:         when (S_ISUID)             { $p .= 'S' }
                     68:         when ( S_IXUSR | S_ISUID ) { $p .= 's' }
                     69:     }
                     70:
                     71:     # group
                     72:     $p .= ( $mode & S_IRGRP ) ? 'r' : '-';
                     73:     $p .= ( $mode & S_IWGRP ) ? 'w' : '-';
                     74:     given ( $mode & ( S_IXGRP | S_ISGID ) ) {
                     75:         when (0)                   { $p .= '-' }
                     76:         when (S_IXGRP)             { $p .= 'x' }
                     77:         when (S_ISGID)             { $p .= 'S' }
                     78:         when ( S_IXGRP | S_ISGID ) { $p .= 's' }
                     79:     }
                     80:
                     81:     # other
                     82:     $p .= ( $mode & S_IROTH ) ? 'r' : '-';
                     83:     $p .= ( $mode & S_IWOTH ) ? 'w' : '-';
                     84:     given ( $mode & ( S_IXOTH | S_ISVTX ) ) {
                     85:         when (0)                   { $p .= '-' }
                     86:         when (S_IXOTH)             { $p .= 'x' }
                     87:         when (S_ISVTX)             { $p .= 'T' }
                     88:         when ( S_IXOTH | S_ISVTX ) { $p .= 't' }
                     89:     }
                     90:     $p .= ' ';    # will be a '+' if ACL's implemented
                     91:
                     92:     return $p;
                     93: }
                     94:
                     95: my @files = @ARGV;
                     96: @files = '.' unless @files;
                     97:
                     98: foreach my $file (@files) {
                     99:     my ( $mode, $nlink, $uid, $gid, $size, $mtime )
1.5     ! andrew    100:         = ( lstat($file) )[ 2 .. 5, 7, 9 ]
        !           101:             or next;
1.1       andrew    102:
                    103:     my $time = localtime($mtime);
                    104:     $time =~ s/^\w+\s+//;
                    105:
                    106:     printf "%s %2s %-7s %-7s %8d %s %s\n",
                    107:         strmode($mode),
                    108:         $nlink,
                    109:         ( getpwuid($uid) )[0],
                    110:         ( getgrgid($gid) )[0],
                    111:         $size, $time, $file;
                    112: }