package SymbolicMode;
#
# $Id: SymbolicMode.pm,v 1.3 2004/08/05 14:18:01 cwest Exp $
#
# $Log: SymbolicMode.pm,v $
# Revision 1.3 2004/08/05 14:18:01 cwest
# cleanup, new version number on website
#
# Revision 1.1 2004/07/23 20:10:01 cwest
# initial import
#
# Revision 1.1 1999/03/07 12:03:54 abigail
# Initial revision
#
#
use strict;
sub mod ($$) {
my $symbolic = shift;
my $file = shift;
# Initialization.
# The 'user', 'group' and 'other' groups.
my @ugo = qw /u g o/;
# Bit masks for '[sg]uid', 'sticky', 'read', 'write' and 'execute'.
# Can't use qw // cause silly Perl doesn't know '2' is a number
# when dealing with &= ~$bit.
my %bits = (s => 8, t => 8, r => 4, w => 2, x => 1);
# For parsing.
my $who_re = '[augo]*';
my $action_re = '[-+=][rstwxXugo]*';
# Find the current permissions. This is what we start with.
my $mode = sprintf "%04o" => (stat $file) [2] || 0;
my $current = substr $mode => -3; # rwx permissions for ugo.
my %perms;
@perms {@ugo} = split // => $current;
# Handle the suid, guid and sticky bits.
# It looks like permission are 4 groups of 3 bits, groups for user,
# group and others, and a group for the special flags, but they are
# really 3 groups of 4 bits. Or maybe not.
# Anyway, this function is greatly simplified by treating them as
# 3 4-bit groups. The highest bit will be "special" one. suid for
# the users group, guid for the group group, and the sticky bit
# for the others group.
my $special = substr $mode => -4, 1;
my $bit = 1;
foreach my $c (reverse @ugo) {
$perms {$c} |= 8 if $special & $bit;
$bit <<= 1;
}
# Keep track of the original permissions.
my %orig = %perms;
# Find the umask setting, and store the bits for each group
# in a hash.
my %umask; # umask bits.
@umask {@ugo} = split // => sprintf "%03o" => umask;
# Time to parse...
foreach my $clause (split /,/ => $symbolic) {
# Perhaps we should die if we can't parse it?
return undef unless
my ($who, $actions) =
$clause =~ /^($who_re)((?:$action_re)+)$/o;
# We would rather split the different actions out here,
# but there doesn't seem to be a way to collect them.
# /^($who_re)($action_re)+/ only gets the last one.
# Now, we have to reparse in later.
my %who;
if ($who) {
$who =~ s/a/ugo/; # Ignore multiple 'a's.
@who {split // => $who} = undef;
}
# @who will contain who these settings applies to.
# if who isn't set, it might be masked with the umask,
# hence, this isn't the final decision.
# Maybe we don't need this.
my @who = $who ? keys %who : @ugo;
foreach my $action (split /(?=$action_re)/o => $actions) {
# The first character has to be the operator.
my $operator = substr $action, 0, 1;
# And the rest are the permissions.
my $perms = substr $action, 1;
# BSD documentation says 'X' is to be ignored unless
# the operator is '-'. GNU, HP, SunOS and Solaris handle
# '-' and '=', while OpenBSD ignores only '-'.
# Solaris, HP and OpenBSD all turn a file with permission
# 666 to a file with permission 000 if chmod =X is
# is applied on it. SunOS and GNU act as if chmod = was
# applied to it. I cannot find out what the reasoning
# behind the choices of Solaris, HP and OpenBSD is.
# GNU and SunOS seem to ignore the 'X', which, after
# careful studying of the documentation seems to be
# the right choice.
# Therefore, remove any 'X' if the operator ain't '+';
$perms =~ s/X+//g unless $operator eq '+';
# If there are no permissions, things are simple.
unless ($perms) {
# Things like u+ and go- are ignored; only = makes sense.
next unless $operator eq '=';
# Clear permissions on u= and go=.
if ($who) {@perms {keys %who} = (0) x 3;}
# '=' is special. Sets permissions to the umask.
else {%perms = %umask;}
next;
}
# If we arrive here, $perms is a string.
# We can iterate over the characters.
foreach (split // => $perms) {
if ($_ eq 'X') {
# We know the operator eq '+'.
# Permission of `X' is special. If used on a regular file,
# the execution bit will only be turned on if any of the
# execution bits of the _unmodified_ file are turned on.
# That is,
# chmod 600 file; chmod u+x,a+X file;
# should result in the file having permission 700, not 711.
# GNU and SunOS get this wrong;
# Solaris, HP and OpenBSD get it right.
next unless -d $file || grep {$orig {$_} & 1} @ugo;
# Now, do as if it's an x.
$_ = 'x';
}
if (/[st]/) {
# BSD man page says operations on 's' and 't' are to
# be ignored if they operate only on the "other" group.
# GNU and HP happely accept 'o+t'. Sun rejects 'o+t',
# but also rejects 'g+t', accepting only 'u+t'.
# OpenBSD acceps both 'u+t' and 'g+t', ignoring 'o+t'.
# We do too.
# OpenBSD however, accepts 'o=t', clearing all the bits
# of the "other" group.
# We don't, as that doesn't make any sense, and doesn't
# confirm to the documentation.
next if $who =~ /^o+$/;
}
# Determine the $bit for the mask.
my $bit = /[ugo]/ ? $orig {$_} & ~8 : $bits {$_};
die "Weird permission `$_' found\n" unless defined $bit;
# Should not happen.
# Determine the set on which to operate.
my @set = $who ? @who : grep {!($umask {$_} & $bit)} @ugo;
# If the permission is 's', don't operate on the other group.
# Unless the operator was '='. But in that case, don't set
# the 8 bit for 'other'.
my $equal_s;
if (/s/) {
if ($operator eq '=') {$equal_s = 1;}
else {@set = grep {!/o/} @set or next;}
}
# If the permission is 't', only operate on the other group;
# regardless what the 'who' settings are.
# Note that for a directory with permissions 1777, and a
# umask of 002, a chmod =t on HP and Solaris turn the
# permissions to 1000, GNU and SunOS turn the permissiosn
# to 1020, while OpenBSD keeps 1777.
/t/ and @set = qw /o/;
# Apply.
foreach my $s (@set) {
do {$perms {$s} |= $bit; next} if $operator eq '+';
do {$perms {$s} &= ~$bit; next} if $operator eq '-';
do {$perms {$s} = $bit; next} if $operator eq '=';
die "Weird operator `$operator' found\n";
# Should not happen.
}
# Special case '=s'.
$perms {o} &= ~$bit if $equal_s;
}
}
}
# Now, translate @perms to an *octal* number.
# First, deal with the suid, guid, and sticky bits by collecting
# the high bits of the ugo permissions.
my $first = 0;
$bit = 1;
for my $c (reverse @ugo) {
if ($perms {$c} & 8) {$first |= $bit; $perms {$c} &= ~8;}
$bit <<= 1;
}
join "" => $first, @perms {@ugo};
}
1;
__END__