#!/usr/pkg/bin/perl

=begin metadata

Name: chmod
Description: change permissions of files
Author: Abigail, perlpowertools@abigail.be
License: perl

=end metadata

=cut

use strict;

use File::Basename qw(basename);

use constant EX_SUCCESS => 0;
use constant EX_FAILURE => 1;

my $Program = basename($0);
my $VERSION = '1.6';

my $rc = EX_SUCCESS;

# Get the options.
# We can't use Getopts, as the order is important.
my %options;
while (@ARGV && $ARGV [0] =~ /^-/) {
    my $opt = reverse shift;
    chop $opt;
    last if ($opt eq '-');
    local $_;
    while (length ($_ = chop $opt)) {
        unless (m/\A[RHLP]\Z/) {
            warn "$Program: invalid option -- '$_'\n";
            usage();
        }
        /R/ && do {$options {R} = 1; next};
        usage() unless $options{'R'};
        /H/ && do {$options {L} = $options {P} = 0; $options {H} = 1; next};
        /L/ && do {$options {H} = $options {P} = 0; $options {L} = 1; next};
        /P/ && do {$options {H} = $options {L} = 0; $options {P} = 1; next};
    }
}

my $mode = shift;
usage() unless @ARGV;

my $symbolic = 0;
if ($mode =~ /[^0-7]/) {
    $symbolic = 1;
}
elsif ($mode !~ /^[0-7]{1,4}$/) {
    warn "$Program: invalid mode: '$mode'\n";
    exit EX_FAILURE;
}

my %ARGV;
%ARGV = map {$_ => 1} @ARGV if $options {H};

sub modify_file;

if (exists $options {R}) {
    # Recursion.
    require File::Find;
    File::Find::find (\&modify_file, @ARGV);
}
else {
    foreach my $file (@ARGV) {
        modify_file($file);
    }
}
exit $rc;

sub usage {
    print "usage: $Program [-R [-H | -L | -P]] mode file...\n";
    exit EX_FAILURE;
}

# File::Find is weird. If called with a directory, it will call
# the sub with "." as file name, while having chdir()ed to the
# directory. But it doesn't do that in recursion, just the top
# level ones. And it ain't true that $File::Find::name eq
# "$File::Find::dir/$_" in all cases.
# But it shouldn't matter in this case.
sub modify_file {
    my $file = @_ ? shift : $_;
    # Now, if this is a symbolic link, it points somewhere,
    # *and* we are following symbolic links, we recurse.
    # This may never end as symlinks can form loops.
    if (-l $file && -e $file &&
                      ($options {L} || $options {H} && $ARGV {$file})) {
        # We don't want to recurse symlinks that just happen to
        # have the same name as one of the arguments, hence the local.
        # Remember that $file is relative to the current directory.
        my $src = readlink $file;
        unless (defined $src) {
            warn "$Program: readlink failed for '$file': $!\n";
            $rc = EX_FAILURE;
            return;
        }
        local $ARGV{$src} = 0;
        File::Find::find(\&modify_file, $src);
        return;
    }
    unless (-e $file) {
        warn "$Program: '$file' does not exist\n";
        $rc = EX_FAILURE;
        return;
    }
    my $realmode = $mode;
    if ($symbolic) {
        $realmode = mod($mode, $file) or do {
            warn "$Program: invalid mode: '$mode'\n";
            exit EX_FAILURE;
        };
    }
    unless (chmod oct($realmode), $file) {
        warn "$Program: failed to change mode for '$file': $!\n";
        $rc = EX_FAILURE;
    }
}

#
# $Id: SymbolicMode.pm,v 1.1 2004/07/23 20:10:01 cwest Exp $
#
# $Log: SymbolicMode.pm,v $
# Revision 1.1  2004/07/23 20:10:01  cwest
# initial import
#
# Revision 1.1  1999/03/07 12:03:54  abigail
# Initial revision
#
#

sub mod {
    my $symbolic     = shift;
    my $file         = shift;

    my @ugo          = qw/u g o/;
    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 = '000';
    if ($symbolic =~ m/[\-\+]/) {
        my @st = stat $file;
        if (@st) {
            $mode = sprintf '%04o', $st[2];
        }
    }
    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 ($operator eq '=') {
                $perms{$who} = 0;
            }

            # 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 '+' || $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};
}

__END__

=pod

=head1 NAME

chmod - change permissions of files

=head1 SYNOPSIS

B<chmod> [B<-R> [B<-H> | B<-L> | B<-P>]] I<mode> I<file>...

=head1 DESCRIPTION

B<chmod> sets the permissions of files. The first argument after the
options is permission the files should be given.

=head2 OPTIONS

B<chmod> accepts the options described below. The options B<-L>,
B<-H> and B<-P> are mutually exclusive, and only the last given
option will be honoured. All of B<-L>, B<-H> and B<-P> require the
B<-R> option to be set first.

=over 4

=item B<-R>

Recurse into directories. Any directories are recursively traversed,
and all files and directories will change owner.

=item B<-L>

Follow symbolic links. By default, B<chmod> will not follow symbolic
links. This is a potential dangerous option, as B<chmod> will not
check for cycles. Be careful. This option requires the B<-R> option to be set.

=item B<-H>

Follow symbolic links of command line files/directories only. This option
requires the B<-R> option to be set.

=item B<-P>

Do not follow symbolic links at all. This option requires the B<-R> option
to be set.

=back

=head2 MODES

I<Mode>s are either absolute, or symbolic. An absolute I<mode> is an octal
number, calculated by OR-ing the following values:

=for html <DL>
<DT><STRONG>4000</STRONG><DD><P>Suid on execution.</DD>
<DT><STRONG>2000</STRONG><DD><P>Guid on execution.</DD>
<DT><STRONG>1000</STRONG><DD><P>The <EM>sticky(8)</EM> bit is turned on.</DD>
<DT><STRONG>0400</STRONG><DD><P>Read permission for the ownwer of the file.</DD>
<DT><STRONG>0200</STRONG><DD>
<P>Write permission for the ownwer of the file.</DD>
<DT><STRONG>0100</STRONG><DD>
<P>Execute permission for the ownwer of the file.</DD>
<DT><STRONG>0040</STRONG><DD>
<P>Read permission for those in the group as the group of the file.</DD>
<DT><STRONG>0020</STRONG><DD>
<P>Write permission for those in the group as the group of the file.</DD>
<DT><STRONG>0010</STRONG><DD>
<P>Execute permission for those in the group as the group of the file.</DD>
<DT><STRONG>0004</STRONG><DD><P>Read permission for all others.</DD>
<DT><STRONG>0002</STRONG><DD><P>Write permission for all others.</DD>
<DT><STRONG>0001</STRONG><DD><P>Execute permission for all others.</DD>

=for html </DL><!--

=over

=item B<4000>

Suid on execution.

=item B<2000>

Guid on execution.

=item B<1000>

The I<sticky(8)> bit is turned on.

=item B<0400>

Read permission for the owner of the file.

=item B<0200>

Write permission for the owner of the file.

=item B<0100>

Execute permission for the owner of the file.

=item B<0040>

Read permission for those in the group as the group of the file.

=item B<0020>

Write permission for those in the group as the group of the file.

=item B<0010>

Execute permission for those in the group as the group of the file.

=item B<0004>

Read permission for all others.

=item B<0002>

Write permission for all others.

=item B<0001>

Execute permission for all others.

=back

=for html -->

Symbolic I<mode> is a comma separated list of I<action>s. Each I<action> has
the following format:

=for html <PRE>
      [<EM>who</EM>] <EM>operator</EM> [<EM>permissions</EM>] [<EM>operator</EM> [<EM>permissions</EM>] ...]
</PRE> <!--

S<    [I<who>] I<operator> [I<permissions>] [I<operator> [I<permissions>] ...]>

=for html -->

I<who> consists of zero or more of the following symbols:

=over

=item B<u>

Permissions for the user (owner) of the file.

=item B<g>

Permissions for the group of the file.

=item B<o>

Permissions for all others.

=item B<a>

Permissions for everyone.

=back

If I<who> is omitted, it will default to B<a>, but the value of your
I<umask> is taken into account. B<chmod> will then not set a permission
that is masked by your I<umask>.

The I<operator> is one of:

=over

=item B<+>

Add permissions. If no I<permission>s are given, this action
is ignored. If I<who> is absent, set the permission bit as
indicated by I<permission>s, but respect the I<umask> settings.
If I<who> is given, set the permission bits as indicated by
I<permission>s, for those groups indicated by I<who>.

=for html <DT><STRONG><A NAME="item_5">-</A></STRONG><DD><!--

=item B<E<45>>

=for html -->

Revoke permissions. If no I<permission>s are given, this action
is ignored. If I<who> is absent, revoke the I<permission> bit as
indicated by permissions, but respect the umask settings.
If I<who> is given, revoke the permission bits as indicated by
I<permission>s, for those groups indicated by I<who>.

=for html <DT><STRONG><A NAME="item_1">-</A></STRONG><DD><!--

=item B<E<61>>

=for html -->

Set permissions. The permission bits indicated by I<who> are
all cleared. If I<who> isn't given, all permission bits are
cleared. Then, if I<who> isn't given, those permission bits
in I<permission> whose corresponding bit in the I<umask> is clear
are set. Otherwise, the permission bits are set as indicated
by I<who> and I<permission>.

=back

I<permission> consists of zero or more of:

=over

=item B<r>

The read permission bit.

=item B<w>

The write permission bit.

=item B<x>

The execute permission bit.

=item B<X>

The execute permission bit, but only if the target is either a directory,
or has at least one execution bit set in the unmodified permission
bits. Furthermore, this permission is ignored if I<operator> is either
B<E<45>> or B<E<61>>.

=item B<s>

The suid and guid bit. These will have no effect in combination
with the B<o> I<who> setting.

=item B<t>

The sticky bit. This makes sense only for the others group,
however, it will be ignored if B<o> is the only group in the
I<who> part of the I<clause>.

=item B<u>

The original permissions of the user.

=item B<g>

The original permissions of the group.

=item B<o>

The original permissions for others.

=back

=head1 ENVIRONMENT

The working of B<chmod> is not influenced by any environment variables.

=head1 BUGS

It is unlikely there are no bugs. The documentation is at best ambiguous.
The OpenBSD documentation does not match the OpenBSD implementation.
Furthermore, the implementations of Solaris, SunOS, HP, and GNU all differ
from each other, and from OpenBSD.

This manual page needs work. The module I<PerlPowerTools::SymbolicMode> needs to be
documented.

B<chmod> parses a symbolic mode once for each file. That is too much
redundant work.

B<chmod> can loop forever when symbolic links create cycles.

B<chmod> uses I<File::Find> to recurse.

This manual should have been written in Texinfo, LaTeX, or a funky
SGML application. B<pod2man>, B<pod2html>, B<pod2text> and B<pod2latex>
are all broken beyond belief.

=head1 STANDARDS

It does not make sense to talk about standards in a chmod manual page.

=head1 REVISION HISTORY

    $Log: chmod,v $
    Revision 1.2  2004/08/05 14:17:43  cwest
    cleanup, new version number on website

    Revision 1.1  2004/07/23 20:10:01  cwest
    initial import

    Revision 1.3  1999/03/09 02:44:57  abigail
    Fixed SybolicMode -> SymbolicMode typo.

    Revision 1.2  1999/03/08 03:07:28  abigail
    Major documentation tweaks.

    Revision 1.1  1999/03/07 12:03:54  abigail
    Initial revision

=head1 AUTHOR

The Perl implementation of B<chmod> was written by Abigail, I<perlpowertools@abigail.be>.

=head1 COPYRIGHT and LICENSE

This program is copyright by Abigail 1999.

This program is free and open software. You may use, copy, modify, distribute,
and sell this program (and any modified variants) in any way you wish,
provided you do not restrict others from doing the same.

=cut

