mirror of https://github.com/fspc/gbootroot.git
You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
289 lines
7.4 KiB
289 lines
7.4 KiB
#
|
|
#
|
|
# Stat::lsMode
|
|
#
|
|
# Copyright 1998 M-J. Dominus
|
|
# (mjd-perl-lsmode-id-i0k+gzzokd+@plover.com)
|
|
#
|
|
# You may distribute this module under the same terms as Perl itself.
|
|
#
|
|
# $Revision: 1.3 $ $Date: 1998/04/20 18:24:53 $
|
|
|
|
|
|
package lsMode;
|
|
|
|
$VERSION = '0.50';
|
|
|
|
use Carp;
|
|
use Exporter;
|
|
@ISA = qw(Exporter);
|
|
@EXPORT = qw(format_mode file_mode format_perms lsmode);
|
|
|
|
@perms = qw(--- --x -w- -wx r-- r-x rw- rwx);
|
|
%smerp = map {$perms[$_] => $_} (0 .. $#perms);
|
|
@ftype = ('', qw(p c ? d ? b ? - ? l ? s ? ? ?));
|
|
%typef = map {$ftype[$_] => $_} (0 .. $#ftype);
|
|
|
|
$NOVICE_MODE = 1; # Default on?
|
|
sub novice {
|
|
my $pack = shift;
|
|
croak "novice_mode requires one boolean argument" unless @_ == 1;
|
|
my $old = $NOVICE_MODE; # Should this be localized t $pack?
|
|
$NOVICE_MODE = $_[0];
|
|
$old;
|
|
}
|
|
|
|
sub format_mode {
|
|
croak "format_mode requires a mode as an argument" unless @_ >= 1;
|
|
my $mode = shift;
|
|
my %opts = @_;
|
|
|
|
unless (defined $mode) {
|
|
return wantarray() ? () : undef;
|
|
}
|
|
|
|
_novice_warning($mode) if $NOVICE_MODE;
|
|
|
|
my $setids = ($mode & 07000)>>9;
|
|
my @permstrs = @perms[($mode&0700)>>6, ($mode&0070)>>3, $mode&0007];
|
|
my $ftype = $ftype[($mode & 0170000)>>12];
|
|
my @ftype = $opts{no_ftype} ? () : ($ftype);
|
|
|
|
if ($setids) {
|
|
if ($setids & 01) { # Sticky bit
|
|
$permstrs[2] =~ s/([-x])$/$1 eq 'x' ? 't' : 'T'/e;
|
|
}
|
|
if ($setids & 04) { # Setuid bit
|
|
$permstrs[0] =~ s/([-x])$/$1 eq 'x' ? 's' : 'S'/e;
|
|
}
|
|
if ($setids & 02) { # Setgid bit
|
|
# Maybe substr($permstrs[1], -1) =~ tr/-x/Ss/; instead. LOD!
|
|
$permstrs[1] =~ s/([-x])$/$1 eq 'x' ? 's' : 'S'/e;
|
|
}
|
|
}
|
|
|
|
if (wantarray) {
|
|
(@ftype, @permstrs);
|
|
} else {
|
|
join '', @ftype, @permstrs;
|
|
}
|
|
}
|
|
|
|
sub file_mode {
|
|
croak "file_mode requires one filename as an argument" unless @_ == 1;
|
|
my $file = shift;
|
|
my $mode = (lstat $file)[2];
|
|
|
|
unless (defined $mode) {
|
|
if (wantarray) {
|
|
return ();
|
|
} else {
|
|
carp "Couldn't get mode for file `$file': $!" if $NOVICE_MODE;
|
|
return undef;
|
|
}
|
|
}
|
|
|
|
format_mode($mode, @_);
|
|
}
|
|
|
|
|
|
# This was suggested by Colin Kuskie
|
|
sub lsmode {
|
|
my $lsmode = shift;
|
|
my ($t, $u, $g, $o);
|
|
my $ld;
|
|
|
|
if (length($lsmode) == 9) {
|
|
($u, $g, $o) = unpack "A3 A3 A3", $lsmode;
|
|
$ld = 0;
|
|
} elsif (length($lsmode) == 10) {
|
|
($t, $u, $g, $o) = unpack "A1 A3 A3 A3", $lsmode;
|
|
$ld = $typef{$t}
|
|
or croak("Mode `$lsmode' begins with unrecognized character `$t'");
|
|
$ld = sprintf "%01o", $ld;
|
|
} else {
|
|
croak "Unrecognizable mode `$lsmode'";
|
|
}
|
|
|
|
# Fix sticky bit?
|
|
if ($o =~ /s$/i) {
|
|
croak "Mode `$lsmode' may not end with `s'; aborting";
|
|
}
|
|
|
|
my $octperm = '';
|
|
my $setuid = 0;
|
|
foreach $perm ($u, $g, $o) {
|
|
# LOD
|
|
$setuid = $setuid * 2 + ($perm =~ s/([st])$/($1 eq lc $1)?'x':'-'/ie);
|
|
$octperm .= $smerp{$perm};
|
|
}
|
|
|
|
my $perm = oct(sprintf "0$ld$setuid$octperm");
|
|
$perm;
|
|
}
|
|
|
|
|
|
sub format_perms {
|
|
croak "format_perms requires a permission mode as an argument" unless @_ == 1;
|
|
format_mode($_[0], no_ftype => 1);
|
|
}
|
|
|
|
# None of these are really plausible modes.
|
|
# They are all almost certain to have occurred
|
|
# when someone used decimal instead of octal to specify a mode.
|
|
|
|
@badmodes = (777, 775, 755, 770, 700, 750,
|
|
751,
|
|
666, 664, 644, 660, 600, 640,
|
|
444, 440,
|
|
400, # 400 = rw--w---- which is just barely plausible.
|
|
# 000 *is* OK. It means just what you think.
|
|
711, 771, 751, 551, 111,
|
|
);
|
|
%badmode = map {($_ => 1)} @badmodes;
|
|
|
|
# Novices like to ask for the bits for mode `666' instead of `0666'.
|
|
# Try to detect and diagnose that.
|
|
sub _novice_warning {
|
|
my $mode = shift;
|
|
if ($badmode{$mode}) {
|
|
carp "mode $mode is very surprising. Perhaps you meant 0$mode";
|
|
}
|
|
}
|
|
|
|
=head1 NAME
|
|
|
|
Stat::lsMode - format file modes like the C<ls -l> command does
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
use Stat::lsMode;
|
|
|
|
$mode = (stat $file)[2];
|
|
$permissions = format_mode($mode);
|
|
# $permissions is now something like `drwxr-xr-x'
|
|
|
|
$permissions = file_mode($file); # Same as above
|
|
|
|
$permissions = format_perms(0644); # Produces just 'rw-r--r--'
|
|
|
|
$permissions = format_perms(644); # This generates a warning message:
|
|
# mode 644 is very surprising. Perhaps you meant 0644...
|
|
|
|
Stat::lsMode->novice(0); # Disable warning messages
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
C<Stat::lsMode> generates mode and permission strings that look like
|
|
the ones generated by the Unix C<ls -l> command. For example, a
|
|
regular file that is readable by everyone and writable only by its
|
|
owner has the mode string C<-rw-r--r-->. C<Stat::lsMode> will either
|
|
examine the file and produce the right mode string for you, or you can
|
|
pass it the mode that you get back from Perl's C<stat> call.
|
|
|
|
=head2 C<format_mode>
|
|
|
|
Given a mode number (such as the third element of the list returned by
|
|
C<stat>), return the appopriate ten-character mode string as it would
|
|
have been generated by C<ls -l>. For example,
|
|
consider a directory that is readable and searchable by everyone, and
|
|
also writable by its owner. Such a directory will have mode 040755.
|
|
When passed this value, C<format_mode> will return the string
|
|
C<drwxr-xr-x>.
|
|
|
|
If C<format_mode> is passed a permission number like C<0755>, it will
|
|
return a nine-character string insted, with no leading character to
|
|
say what the file type is. For example, C<format_mode(0755)> will
|
|
return just C<rwxr-xr-x>, without the leading C<d>.
|
|
|
|
=head2 C<file_mode>
|
|
|
|
Given a filename, do C<lstat> on the file to determine the mode, and
|
|
return the mode, formatted as above.
|
|
|
|
=head2 Novice Operation Mode
|
|
|
|
A common mistake when dealing with permission modes is to use C<644>
|
|
where you meant to use C<0644>. Every permission has a numeric
|
|
representation, but the representation only makes sense when you write
|
|
the number in octal. The decimal number 644 corresponds to a
|
|
permission setting, but not the one you think. If you write it in
|
|
octal you get 01204, which corresponds to the unlikely permissions
|
|
C<-w----r-T>, not to C<rw-r--r-->.
|
|
|
|
The appearance of the bizarre permission C<-w----r-T> in a program is
|
|
almost a sure sign that someone used C<644> when they meant to use
|
|
C<0644>. By default, this module will detect the use of such unlikely
|
|
permissions and issue a warning if you try to format them. To disable
|
|
these warnings, use
|
|
|
|
Stat::lsMode->novice(0); # disable novice mode
|
|
|
|
Stat::lsMode->novice(1); # enable novice mode again
|
|
|
|
The surprising permissions that are diagnosed by this mode are:
|
|
|
|
111 => --xr-xrwx
|
|
400 => rw--w----
|
|
440 => rw-rwx---
|
|
444 => rw-rwxr--
|
|
551 => ---r--rwt
|
|
600 => --x-wx--T
|
|
640 => -w------T
|
|
644 => -w----r-T
|
|
660 => -w--w-r-T
|
|
664 => -w--wx--T
|
|
666 => -w--wx-wT
|
|
700 => -w-rwxr-T
|
|
711 => -wx---rwt
|
|
750 => -wxr-xrwT
|
|
751 => -wxr-xrwt
|
|
751 => -wxr-xrwt
|
|
755 => -wxrw--wt
|
|
770 => r------wT
|
|
771 => r------wt
|
|
775 => r-----rwt
|
|
777 => r----x--t
|
|
|
|
Of these, only 400 is remotely plausible.
|
|
|
|
=head1 BUGS
|
|
|
|
As far as I know, the precise definition of the mode bits is portable
|
|
between varieties of Unix. The module should, however, examine
|
|
C<stat.h> or use some other method to find out if there are any local
|
|
variations, because Unix being Unix, someone somewhere probably does
|
|
it differently.
|
|
|
|
Maybe C<file_mode> should have an option that says that if the file
|
|
is a symlink, to format the mode of the pointed to file instead of the
|
|
mode of the link itself, the way C<ls -Ll> does.
|
|
|
|
=head1 SEE ALSO
|
|
|
|
=over 4
|
|
|
|
=item *
|
|
|
|
C<http://www.plover.com/~mjd/perl/lsMode/>.
|
|
|
|
=item *
|
|
|
|
L<ls>
|
|
|
|
=item *
|
|
|
|
L<chmod>
|
|
|
|
=item *
|
|
|
|
L<stat>
|
|
|
|
=back
|
|
|
|
=head1 AUTHOR
|
|
|
|
Mark-Jason Dominus (C<mjd-perl-lsmode-id-i0k+gzzokd+@plover.com>).
|
|
|
|
=cut
|
|
|
|
|