install

#!/usr/bin/perl

=begin metadata

Name: install
Description: install files and directories
Author: Greg Bacon, gbacon@itsc.uah.edu
License: perl

=end metadata

=cut


use strict;

use File::Basename qw(basename dirname);
use Getopt::Std qw(getopts);

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

sub usage {
    print <<EOUsage;
$Program (Perl bin utils) $VERSION

Usage: $Program [-CcDps] [-g group] [-m mode] [-o owner] file1 file2
       $Program [-CcDps] [-g group] [-m mode] [-o owner] file ... directory
       $Program -d [-g group] [-m mode] [-o owner] directory ...
EOUsage
    exit 1;
}

$SIG{__DIE__} = sub {
    warn @_;
    exit 1;
};

# still in Kansas, Toto?
my $Unix = $^O !~ /Win|VMS|DOS|MacOS|OS2/i;

my $Debug = 0;
my $Errors = 0;

# process options
my %opt;
getopts('CcDdf:g:Mm:o:ps', \%opt) or usage();
usage() unless @ARGV;

if ($opt{d} and grep($_, @opt{qw/ C c D p /}) > 0) {
    warn "$Program: -d not allowed with -[CcDp]\n";
    usage();
}

$opt{C}++ if $opt{p};
$Debug = 1 if $opt{D};

# these probably won't make sense elsewhere
if ($Unix) {
    if ($opt{g} and $opt{g} !~ /^\d+$/) {
        if (my $gid = getgrnam $opt{g}) {
            $opt{g} = $gid;
        }
        else {
            die "$Program: unknown group `$opt{g}'\n";
        }
    }

    if ($opt{o} and $opt{o} !~ /^\d+$/) {
        if (my $uid = getpwnam $opt{o}) {
            $opt{o} = $uid;
        }
        else {
            die "$Program: unknown user `$opt{o}'\n";
        }
    }
}

# do stuff
if ($opt{d}) {
    install_dirs();
}
else {
    install_files();
}

exit($Errors == 0 ? 0 : 1);

sub modify_file {
    my($path,$mode,$st) = @_;

    if ($mode) {
        unless (chmod $mode, $path) {
            printf STDERR "$Program: chmod %o $path: $!\n", $mode;
            $Errors++;
        }
    }

    if ($opt{o} || $opt{g}) {
        my @st = stat $path;
        my $uid = $opt{o} || $st[4];
        my $gid = $opt{g} || $st[5];

        unless (chown $uid, $gid => $path) {
            warn "$Program: chown $uid.$gid $path: $!\n";
            $Errors++;
        }
    }

    if ($opt{p}) {
        unless (utime @{$st}[8,9] => $path) {
            warn "$Program: utime $path: $!\n";
            $Errors++;
        }
    }

    if ($opt{s} and -B $path) {
        if (system "strip", $path) {
            warn "$Program: strip $path exited " . ($? >> 8) . "\n";
            $Errors++;
        }
    }
}

sub install_dirs {
    my $mode = $opt{m} || '755';
    my $symbolic = $mode =~ /^[0-7]{1,4}$/ ? 0 : 1;

    # credit Abigail
    my @dirs;
    my %min;
    while (@ARGV) {
        my $dir = pop @ARGV;
        my $intermediate = 0;
        while ($dir ne dirname($dir)) {
            my $val = $intermediate++;

            push @dirs => [$dir, $val];

            if ($val == 0 || !defined($min{$dir}) || $val < $min{$dir}) {
                $min{$dir} = $val;
            }

            $dir = dirname($dir);
        }
    }

    my %seen;
    for (reverse @dirs) {
        next if $seen{ $_->[0] }++;

        $_->[1] = $min{ $_->[0] };
        push @ARGV, $_;
    }

    foreach my $directory (@ARGV) {
        my($dir,$implied) = @$directory;

        next if $implied && -d $dir;

        mkdir $dir, 0755 or die "$Program: mkdir $dir: $!\n";
    }

    foreach my $directory (@ARGV) {
        my($dir,$implied) = @$directory;

        next if $implied;

        my $bits;
        if ($symbolic) {
            unless ( $bits = mod($mode, $dir) ) {
                die "$Program: invalid mode: $mode\n";
            }
            $bits = oct $bits;
        }
        else {
            $bits = oct $mode;
        }

        # do these make sense elsewhere?
        modify_file $dir, $bits if !$implied && $Unix;
    }
}

sub install_files {
    my $dst = pop @ARGV;
    my $dir = -d $dst;

    if (scalar(@ARGV) == 0) {
        die "$Program: missing destination file operand after '$dst'\n";
    }
    if (!$dir and @ARGV > 1) {
        warn "$Program: '$dst' is not a directory\n";
        usage();
    }

    my $mode = $opt{m} || '755';
    my $symbolic = ($mode =~ /^[0-7]{1,4}$/) ? 0 : 1;

    require File::Copy;
    require File::Spec;

    foreach my $file (@ARGV) {
        my $targ = $dir ? File::Spec->catfile($dst, basename($file)) : $dst;

        my @st;
        if ($opt{p}) {
            unless (@st = stat $file) {
                warn "$Program: stat $file: $!\n";
                $Errors++;
                next;
            }
        }

        if (-d $file) {
            warn "$Program: ignoring directory '$file'\n";
            $Errors++;
            next;
        }

        if ($opt{C}) {
            if (system "cmp", "-s", $file, $targ) {
                warn "$Program: copy $file $targ\n" if $Debug;

                unless ( File::Copy::copy($file, $targ) ) {
                    warn "$Program: copy $file $targ: $!\n";
                    $Errors++;
                    next;
                }
            }
            else {
                warn("$Program: $file not copied to $targ\n") if $Debug;
                next;
            }
        }
        else { # default -c
            warn "$Program: copy $file $targ\n" if $Debug;

            unless ( File::Copy::copy($file, $targ) ) {
                warn "$Program: copy $file $targ: $!\n";
                $Errors++;
                next;
            }
        }

        my $bits;
        if ($symbolic) {
            unless ( $bits = mod($mode, $targ) ) {
                die "$Program: invalid mode: $mode\n";
            }
            $bits = oct $bits;
        }
        else {
            $bits = oct $mode;
        }

        modify_file $targ, $bits, \@st if $Unix;
    }
}

#
# $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;

    # 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 ($operator eq '=') {
                %perms = ( 'u' => 0, 'g' => 0, 'o' => 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

install - install files and directories

=head1 SYNOPSIS

B<install> [B<-CcDps>] [B<-g> I<group>] [B<-m> I<mode>] [B<-o> I<owner>] I<file1> I<file2>

B<install> [B<-CcDps>] [B<-g> I<group>] [B<-m> I<mode>] [B<-o> I<owner>] I<file> ... I<directory>

B<install> B<-d> [B<-g> I<group>] [B<-m> I<mode>] [B<-o> I<owner>] I<directory> ...

=head1 DESCRIPTION

B<install> copies files to the
target path specified by I<file2> or I<directory>.  Alternatively, if
B<-d> is specified, B<install> creates directories (also creating missing
parent directories as necessary, similar to B<mkdir -p>).

B<install> accepts these options:

=over 4

=item B<-C>

Copy the file only if it differs from the target (according to
B<cmp>).

=item B<-c>

Copy the file. This option is provided for compatibility and is the
default.

=item B<-D>

Give debugging information.  If specified once, B<install> will warn
about impending copies or moves.  If specified more than once, B<install>
will warn when it does not install files due to B<-C>.

=item B<-d>

Create directories (creating missing parent directories as needed,
similar to B<mkdir -p>).  When creating parent directories, the implied
directories are created with the default creation mask 0755 (modified
by your umask).  Only those directories explicitly provided on the
command line take the permissions specified by B<-m>.  This behavior
imitates that of BSD install(1).

=item B<-f>

Specify the target's file flags, i.e. B<-f> I<flags>.  This option is
only provided for compatibility and does not affect the execution of
B<install>.

=item B<-g>

Specify the group to which the target file should belong.  Both numeric
and mnemonic group IDs are acceptable.

=item B<-M>

Do not use mmap(2).  This option is only provided for compatibility and
does not affect the execution of B<install>.

=item B<-m>

Specify the target file's mode.  Either octal modes or symbolic modes
are acceptable.  See the documentation for the I<PerlPowerTools::SymbolicMode> module
for details on acceptable symbolic modes.  The default mode (used in
absence of B<-m> is 0755).  When specifying a symbolic mode, keep in
mind that all directories are created with the default creation mask
0755 (as modified by your umask), so it is probably best to use
absolute symbolic permissions (e.g. C<u=rwx,g=rx,o=rx>) as opposed
to relative symbolic permissions (e.g. C<ugo+x>).

=item B<-o>

Specify the owner to whom the target should belong.  Both numeric and
mnemonic user IDs are acceptable.

=item B<-p>

Preserve modification time.  This option implies B<-C>.

=item B<-s>

Invoke strip(1) on installed binaries.

=back

=head1 ENVIRONMENT

No environment variables affect the execution of B<install>.

=head1 CAVEATS

The combination of creation of and setting permissions for files and
directories is not atomic, so there are lots of possibilities for
race conditions.  If you are really concerned about this, use a umask
of 77.

=head1 AUTHOR

The Perl implementation of B<install> was written by Greg Bacon
E<lt>I<gbacon@itsc.uah.edu>E<gt> as part of the ADaM Project.

=head1 COPYRIGHT and LICENSE

Copyright 1999 UAH Information Technology and Systems Center.

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.

=head1 SEE ALSO

umask(2), chmod(1), mkdir(1), chown(8), chgrp(8), strip(1)

=cut