#!/usr/bin/perl -w

use strict;
use Fcntl ':mode';
use Carp qw(verbose);

BEGIN {

    use vars qw(@POD_HOOKS $be_random $do_suid);
    no strict 'refs';

=head1 NAME

immucp - Duplicate structures, with immutability/immulink support

=cut

    push @POD_HOOKS, NAME => sub {
	my @m;
	( @m = m/(\S+) - (.*)/ ) &&
	    do { *{PROGNAME}   = sub { $m[0] };
		 *{SHORT_DESC} = sub { $m[1] }; }
	};

=head1 SYNOPSIS

immucp [options] dir1 dir2

=cut

    push @POD_HOOKS, SYNOPSIS => sub {
	my $a = $_;
	*{SYNOPSIS} = sub { $a }
    };

=head1 DESCRIPTION

immucp will copy the first location to the second location, but will
only ever make links, rather than copy.

It is very similar to using `cp -al', but has support for setting
Linux inode attributes along the way.

=cut

    push @POD_HOOKS, DESCRIPTION => sub {
	my $a = $_;
	*{DESCRIPTION} = sub { $a }
    };

=head1 COMMAND LINE OPTIONS

The following command line options are available:

=cut

    # Extract the command line options for the "usage" screen from the
    # POD ;-)
    use vars qw(@options);

    push @POD_HOOKS, 'COMMAND LINE OPTIONS' => sub {
	# This hook is deleted below under RELEASE
	&Pod::Constants::add_hook
		(#-debug => 1,
		 '*item' => sub {
		     my ($switches, $description) =
			 m/^(.*?)\n\n(.*)/s;
		     my (@switches, $longest);
		     $longest = "";
		     for my $switch
			 ($switches =~ m/\G
					 ((?:-\w|--\w+))
					 (?:,\s*)?
					 /gx) {
			     push @switches, $switch;
			     if ( length $switch > length $longest) {
				 $longest = $switch;
			     }
			 }
		     $longest =~ s/^-*//;
		     push @options,
			 $longest, {
				    options => \@switches,
				    description => $description,
				   };
		 }
		);
    };

=over 4

=item -h, --help

Display program usage

=item -v, --verbose

Verbose program execution

=item -d, --debug

Even more verbose program execution

=item -V, --version

Print the program version

=item -i, --immutable

Sets the "immutable" inode attribute.

=item -l, --linkage

Sets the "immutable linkage invert" inode attribute.

=item -S, --suid

Link files that have set user/group ID bits set

=item -r, --random

Turns on randomising of directory scanning and tree traversal.  This
option tries to prevent against racing symlink attacks.  A better
solution is planned.

=back

=head1 INODE ATTRIBUTES AND IMMUTABILITY

Hard linking identical files between directories has a drawback: if
one is changed, then the other one changes too.

To counter this, you can set the "immutable" inode attribute on
combined files (see L<chattr>).

Setting inode attribute requires root privileges, C<CAP_SYS_ATTR>, and
a filesystem that supports it.  Currently this includes default ext2
and ext3 in any recent kernel, or reiserfs with the "inode attributes"
patch applied (available from
C<ftp://ftp.namesys.com/pub/reiserfs-for-2.4/2.4.18.pending/>).

The problem with setting "immutable" is that then the file can not be
unlinked or renamed.  In the case where you have a user without
CAP_SYS_ATTR, but otherwise with write permission to a file, they
cannot then change it.

In comes the "immutable linkage invert" flag.  This flag will toggle
immutability of the file E<name>, but leave the file E<contents>,
E<permissions>, etc protected.  This means that you can unlink the
file, and hence replace it, edit it with most editors, etc.

This option requires a kernel patch - it is included in the s_context
patch for the vserver project, which is at
L<http://www.solucorp.qc.ca/miscprj/s_context.hc>).  It is also
available on its own from L<http://sam.vilain.net/immutable/>.

This works well with ext2 and ext3, but is a little trickier to get
working with reiserfs, as inode attributes are not a standard reiserfs
feature.  See the above link for more information.

=head1 RELEASE

This is immulink version 0.2.

=cut

    push @POD_HOOKS, RELEASE => sub {
	Pod::Constants::delete_hook("*item");
	my $v;
	(($v) = m/(\d+\.\d+)/) && (*{VERSION} = sub {$v});
    };


};

no strict 'subs';

sub abort {
    print STDERR &PROGNAME.": aborting: @_\n", short_usage();
    exit(1);
}

sub barf { print STDERR &PROGNAME.": @_\n"; exit(1) }
sub moan { print STDERR &PROGNAME.": WARNING: @_\n"; }
sub say { print &PROGNAME.": @_\n"; }
sub mutter { }
sub whisper { }

use strict 'subs';

#=====================================================================
#  MAIN SECTION STARTS HERE
#=====================================================================
my ($action, @dirs, $immutable, $linkage, $mode);

{
    use Getopt::Long;

    no strict "refs", 'vars';
    local ($^W) = 0;

    $action = "unify";
    $mode = "";

    Getopt::Long::config("bundling");
    #Getopt::Long::config("pass_through");
    Getopt::Long::GetOptions
	    (
	     'help|h' => sub { $action = "show_help" },
	     'version|V' => sub { $action = "show_version" },
	     'verbose|v' => sub { *{"mutter"} = \&say },
	     'debug|d' => sub { *{"whisper"} = *{"mutter"} = \&say },
	     'immutable|i' => \$immutable,
	     'linkage|l' => \$linkage,
	     'random|r' => sub { $be_random = 1 },
	     'suid|S' => sub { $do_suid = 1 },
	    );

    $mode .= "i" if $immutable;
    $mode .= "I" if $linkage;

    if ( ! -t STDOUT ) {
	if ( -t STDERR ) {
	    eval "sub say { print STDERR \"\@_\n\" }";
	} else {
	    eval "sub say { }";
	}
    }

    if ($action eq "show_help") {
	print usage();
	exit(0);
    } elsif ($action eq "show_version") {
	print version(), "\n";
	exit(0);
    }

}

my $source = shift @ARGV
    or abort "no source directory given";
my $dest = shift @ARGV
    or abort "no destination directory given";

@ARGV && abort "extra unparsed arguments: @ARGV";

copy_tree($source, $dest);

say "done";
exit(0);

=head1 INTERNAL FUNCTIONS

Documented for prosperity

=head2 chattr ($filename, $attr_string)

Calls the C<EXT2_IOC_SETFLAGS> IOCTL on $filename, setting flags as
per $attr_string.

=over

=item Permitted chattr attributes

The following table lists the allowed contents of $attr_string, and
the corresponding bitmask to the IOCTL.

  i => 0x00000010    ("immutable")
  I => 0x00008000    ("immutable linkage invert")

=back

=cut

BEGIN { use vars qw(%attr);
	push @POD_HOOKS,
	    "Permitted chattr attributes" => sub {
		%attr = map {
		    if ( m/(\w) => (0x\w+)/) {
			$1 => pack("L", hex($2));
		    } else { () }
		} split /\r?\n/, $_;
	    }; }

use vars qw($using_system);

sub chattr {
    my( $file, $attr_str ) = @_;
    whisper ("chattr($file, $attr_str)");
    my $EXT2_IOC_SETFLAGS = 0x40046602;
    my $flags = pack("L", 0);
    {
my $x = $attr_str;
    while( my $flag = chop($attr_str) ){
	$flags |= $attr{$flag};
    }
    $attr_str=$x;
    }
    open( F, $file ) or die "Can't open $file : $!";
    ioctl( F, $EXT2_IOC_SETFLAGS, $flags ) or do {
    	moan "can't set attr(".sprintf("%x",unpack("I",$flags)).") on $file: $!; using system('setattr')" unless $using_system++;

	system("/usr/lib/util-vserver/setattr", ($attr_str =~ /i/ ? "--immutable" : ()), ($attr_str =~ /I/ ? "--immulink" : () ), $file) == 0
		or die "setattr failed (rc=$?)";
    };
    close F;
}

=head2 copy_tree($source, $dest)

=cut

use File::Find;
use Cwd qw(getcwd);

sub copy_tree {

    my $source = shift;
    my $dest   = shift;

    barf "$source is not readable"
        unless ( -d $source and -r _ );

    ( -d $dest ) or do {
    	mkdir $dest or barf "failed to make $dest; $!";
    };

    if (my $pid = open IPC, "-|") {
	
	local($/)="\0";
	chdir($dest);

	$dest = getcwd;
	chop($source = <IPC>);
	defined($source) or barf "child process failed";

	my @utimes;

	# parent, this one does the linking
	while (<IPC>) {
	    chop;
	    my (@stat) = split ":", $_;
	    my $fn;
	    chop($fn = <IPC>);
	    if (!defined($stat[2])) {
	    	moan "file `$fn' in source failed stat? (@stat)";
		next;
	    }

	    if (S_ISDIR($stat[2])) {
	    	if ( ! -d "$dest/$fn" ) {
		    mutter "making dir $dest/$fn";
		    mkdir("$dest/$fn" )
		    	or barf "failed to make $dest/$fn; $!";
		    chown(@stat[4,5], "$dest/$fn")
		    	or barf "failed to change ownership on $dest/$fn; $!";
		    chmod(S_IMODE($stat[2]), "$dest/$fn")
		    	or barf "failed to change mode on $dest/$fn; $!";

		    # directory times must be set later
		    push @utimes, @stat[8,9], $fn;
		}
		chdir("$dest/$fn") or barf "failed to chdir '$dest/$fn'; $!";
	    } elsif (S_ISREG($stat[2])) {
		my $src = "$source/$fn";
	    	$fn =~ s{.*/}{};
	    	if ( ! -e "$fn" ) {
		    mutter "making $fn";
		    chattr($src, $mode) if ( $mode and $mode eq "iI" );
		    chattr($src, "") if ( $mode and $mode =~ /^[iI]$/ );

		    link $src, $fn or do { 
			die "link ('$src','$fn') failed; $!";
			next;
		    };

		    # don't change times unnecessarily
		    utime(@stat[8,9], $fn);

		    chattr($src, $mode) if ( $mode and $mode =~ /^[iI]$/ );
		}
	    } elsif (S_ISLNK($stat[2])) {
	        my $target = pop @stat;
	    	$fn =~ s{.*/}{};
		( -l $fn ) && next;
		mutter "$fn -> $target";
		symlink($target, $fn)
		    or barf "symlink($target, $fn) failed; $!";
	    } else {
	    	mutter "ignoring non-regular file $fn";
	    }
	}

    } elsif (!defined $pid) {
	barf "fork() failed; $!";
    } else {

	chdir($source)
	    or barf "failed to chdir to $source; $!";

	$\ = "\0";
	$, = ":";
	print getcwd;

	# child, this one does the finding
	my $name;
	find(sub {
		if ( -l ) {
		    print lstat _, readlink;
		} else {
		    print stat _;
		}
		($name = $File::Find::name) =~ s{^\.}{};
		print $name;
	     },
	     ".");

	exit(0);
    }

}

sub no_dups {
    return keys %{{ map { $_ => 1 } @_ }}
}

BEGIN {

    eval "use Pod::Constants -trim => 1, \@POD_HOOKS";
    die $@ if $@;

}

#---------------------------------------------------------------------
#  Usage functions
#---------------------------------------------------------------------

sub short_usage {
    return ("Usage: ${\(SYNOPSIS)}\n"
	    ."Try `${\(PROGNAME)} --help' for a summary of options."
	    ."\n");
}

use Text::Wrap qw(wrap fill);
use Term::ReadKey;

=head2 usage

Prints the program usage (extracted from the POD).

=cut

sub usage {

    # alright, I'm admit this function is silly.

    my $options_string;
    my $OPTIONS_INDENT = 2;
    my $OPTIONS_WIDTH = 20;
    my $OPTIONS_GAP = 2;
    my $TOTAL_WIDTH = (GetTerminalSize())[0] - 10 || 70;

    my $DESCRIPTION_WIDTH = ($TOTAL_WIDTH - $OPTIONS_GAP -
			     $OPTIONS_INDENT - $OPTIONS_WIDTH);

    # go through each option, and format it for the screen

    for ( my $i = 0; $i < (@options>>1); $i ++ ) {
	my $option = $options[$i*2 + 1];

	$Text::Wrap::huge = "overflow";
	$Text::Wrap::columns = $OPTIONS_WIDTH;
	my @lhs = map { split /\n/ }
	    wrap("","",join ", ",
		 sort { length $a <=> length $b }
		 @{$option->{options}});

	$Text::Wrap::huge = "wrap";
	$Text::Wrap::columns = $DESCRIPTION_WIDTH;
	my @rhs = map { split /\n/ }
	    fill("","",$option->{description});

	while ( @lhs or @rhs ) {
	    my $left = shift @lhs;
	    my $right = shift @rhs;
	    chomp($left);
	    $options_string .= join
		("",
		 " " x $OPTIONS_INDENT,
		 $left . (" " x ($OPTIONS_WIDTH - length $left)),
		 " " x $OPTIONS_GAP,
		 $right,
		 "\n");
	}
    }

    $Text::Wrap::huge = "overflow";
    $Text::Wrap::columns = $TOTAL_WIDTH;


    return (fill("","",PROGNAME . " - " . SHORT_DESC)
	    ."\n\n"
	    ."Usage: ".SYNOPSIS."\n\n"
	    .fill("  ","",DESCRIPTION)."\n\n"
	    .fill("  ","","Command line options:")
	    ."\n\n"
	    .$options_string."\n"
	    ."See `perldoc $0' for more information.\n");
}

__END__

=head1 BUGS/TODO

Some suggestions for use as a security tool:

 I came up with these extra options for unify-dirs:
 -s --save <filename>  
 save list of files in /etc/vserver/unified.vservername if no <filename>
 is given.
 -c --compare  compare <filename>
 compare current link status with saved list (see -s :-)
 -t --test
 don't actually do any linking. just print out list of files that could
 be unified. together with -s option one could merely create an initial
 list, without doing anything else..

=head1 AUTHOR

Sam Vilain, <sam@vilain.net>

=cut