Return to perl_strmode.pl CVS log

Up to [local] / misc / strmode

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

1.1       andrew      1: #!/usr/bin/perl -T
                      2:
                      3: # $AFresh1$
                      4: #
                      5: # Copyright (c) 2011 Andrew Fresh <andrew@afresh1.com>
                      6: #
                      7: # Permission to use, copy, modify, and distribute this software for any
                      8: # purpose with or without fee is hereby granted, provided that the above
                      9: # copyright notice and this permission notice appear in all copies.
                     10: #
                     11: # THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
                     12: # WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
                     13: # MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
                     14: # ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
                     15: # WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
                     16: # ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
                     17: # OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
                     18:
                     19: use warnings;
                     20: use strict;
                     21: use 5.010;
                     22:
                     23: use Fcntl ':mode';
                     24:
                     25: sub strmode {
                     26:
                     27:     # Perl port of OpenBSD: lib/libc/string/strmode.c,v 1.7
                     28:     # by Andrew Fresh <andrew@afresh1.com>
                     29:
                     30:     my ($mode) = @_;
                     31:     my $p = '';
                     32:
                     33:     # print type
                     34:     given ( $mode & S_IFMT ) {
                     35:         when (S_IFDIR)  { $p .= 'd' }    # directory
                     36:         when (S_IFCHR)  { $p .= 'c' }    # character special
                     37:         when (S_IFBLK)  { $p .= 'b' }    # block special
                     38:         when (S_IFREG)  { $p .= '-' }    # regular
                     39:         when (S_IFLNK)  { $p .= 'l' }    # symbolic link
                     40:         when (S_IFSOCK) { $p .= 's' }    # socket
                     41:
                     42:         #ifdef S_IFIFO XXX How important is this ifdef?
                     43:         when (S_IFIFO) { $p .= 'p' }     # fifo
                     44:
                     45:         #endif
                     46:         default { $p .= '?' }            # unknown
                     47:     }
                     48:
                     49:     # usr
                     50:     $p .= ( $mode & S_IRUSR ) ? 'r' : '-';
                     51:     $p .= ( $mode & S_IWUSR ) ? 'w' : '-';
                     52:     given ( $mode & ( S_IXUSR | S_ISUID ) ) {
                     53:         when (0)                   { $p .= '-' }
                     54:         when (S_IXUSR)             { $p .= 'x' }
                     55:         when (S_ISUID)             { $p .= 'S' }
                     56:         when ( S_IXUSR | S_ISUID ) { $p .= 's' }
                     57:     }
                     58:
                     59:     # group
                     60:     $p .= ( $mode & S_IRGRP ) ? 'r' : '-';
                     61:     $p .= ( $mode & S_IWGRP ) ? 'w' : '-';
                     62:     given ( $mode & ( S_IXGRP | S_ISGID ) ) {
                     63:         when (0)                   { $p .= '-' }
                     64:         when (S_IXGRP)             { $p .= 'x' }
                     65:         when (S_ISGID)             { $p .= 'S' }
                     66:         when ( S_IXGRP | S_ISGID ) { $p .= 's' }
                     67:     }
                     68:
                     69:     # other
                     70:     $p .= ( $mode & S_IROTH ) ? 'r' : '-';
                     71:     $p .= ( $mode & S_IWOTH ) ? 'w' : '-';
                     72:     given ( $mode & ( S_IXOTH | S_ISVTX ) ) {
                     73:         when (0)                   { $p .= '-' }
                     74:         when (S_IXOTH)             { $p .= 'x' }
                     75:         when (S_ISVTX)             { $p .= 'T' }
                     76:         when ( S_IXOTH | S_ISVTX ) { $p .= 't' }
                     77:     }
                     78:     $p .= ' ';    # will be a '+' if ACL's implemented
                     79:
                     80:     return $p;
                     81: }
                     82:
                     83: my @files = @ARGV;
                     84: @files = '.' unless @files;
                     85:
                     86: foreach my $file (@files) {
                     87:     next unless -e $file;
                     88:     my ( $mode, $nlink, $uid, $gid, $size, $mtime )
                     89:         = ( stat(_) )[ 2 .. 5, 7, 9 ];
                     90:
                     91:     my $time = localtime($mtime);
                     92:     $time =~ s/^\w+\s+//;
                     93:
                     94:     printf "%s %2s %-7s %-7s %8d %s %s\n",
                     95:         strmode($mode),
                     96:         $nlink,
                     97:         ( getpwuid($uid) )[0],
                     98:         ( getgrgid($gid) )[0],
                     99:         $size, $time, $file;
                    100: }