Return to perl_strmode.pl CVS log

Up to [local] / misc / strmode

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

1.1       andrew      1: #!/usr/bin/perl -T
                      2:
1.2     ! andrew      3: # $AFresh1: perl_strmode.pl,v 1.1.1.1 2011/03/27 20:54:35 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
                     55:
                     56:         #ifdef S_IFIFO XXX How important is this ifdef?
                     57:         when (S_IFIFO) { $p .= 'p' }     # fifo
                     58:
                     59:         #endif
                     60:         default { $p .= '?' }            # unknown
                     61:     }
                     62:
                     63:     # usr
                     64:     $p .= ( $mode & S_IRUSR ) ? 'r' : '-';
                     65:     $p .= ( $mode & S_IWUSR ) ? 'w' : '-';
                     66:     given ( $mode & ( S_IXUSR | S_ISUID ) ) {
                     67:         when (0)                   { $p .= '-' }
                     68:         when (S_IXUSR)             { $p .= 'x' }
                     69:         when (S_ISUID)             { $p .= 'S' }
                     70:         when ( S_IXUSR | S_ISUID ) { $p .= 's' }
                     71:     }
                     72:
                     73:     # group
                     74:     $p .= ( $mode & S_IRGRP ) ? 'r' : '-';
                     75:     $p .= ( $mode & S_IWGRP ) ? 'w' : '-';
                     76:     given ( $mode & ( S_IXGRP | S_ISGID ) ) {
                     77:         when (0)                   { $p .= '-' }
                     78:         when (S_IXGRP)             { $p .= 'x' }
                     79:         when (S_ISGID)             { $p .= 'S' }
                     80:         when ( S_IXGRP | S_ISGID ) { $p .= 's' }
                     81:     }
                     82:
                     83:     # other
                     84:     $p .= ( $mode & S_IROTH ) ? 'r' : '-';
                     85:     $p .= ( $mode & S_IWOTH ) ? 'w' : '-';
                     86:     given ( $mode & ( S_IXOTH | S_ISVTX ) ) {
                     87:         when (0)                   { $p .= '-' }
                     88:         when (S_IXOTH)             { $p .= 'x' }
                     89:         when (S_ISVTX)             { $p .= 'T' }
                     90:         when ( S_IXOTH | S_ISVTX ) { $p .= 't' }
                     91:     }
                     92:     $p .= ' ';    # will be a '+' if ACL's implemented
                     93:
                     94:     return $p;
                     95: }
                     96:
                     97: my @files = @ARGV;
                     98: @files = '.' unless @files;
                     99:
                    100: foreach my $file (@files) {
                    101:     next unless -e $file;
                    102:     my ( $mode, $nlink, $uid, $gid, $size, $mtime )
                    103:         = ( stat(_) )[ 2 .. 5, 7, 9 ];
                    104:
                    105:     my $time = localtime($mtime);
                    106:     $time =~ s/^\w+\s+//;
                    107:
                    108:     printf "%s %2s %-7s %-7s %8d %s %s\n",
                    109:         strmode($mode),
                    110:         $nlink,
                    111:         ( getpwuid($uid) )[0],
                    112:         ( getgrgid($gid) )[0],
                    113:         $size, $time, $file;
                    114: }