#!/usr/pkg/bin/perl -T
# $Id: rconfig.pl,v 1.71 2007/03/24 14:46:43 abs Exp $

# (c) 2001, 2002, 2003, 2009 David Brownlee <abs@netbsd.org>.
# No warranty, implied or otherwise.
# No restrictions placed on distribution or use, but please keep this commment.

# ssh usage: You will probably want to ssh-keygen on the server and add the
#	     key to root/.ssh/authorized_hosts on clients.
#
# XXX: Allow diffs in non common dir - use substitute as object
# XXX: parseable debug output of what files go to what hosts
# XXX: report failed when probe fails second time

my $version = '0.47';

my $PREFIX     = '/usr/local';
my $LIBEXEC    = "$PREFIX/libexec";
my $SYSCONFDIR = "/usr/pkg/etc";

=head1 NAME

rconfig - Manage configuration files for many machines via rdist trees.

=head1 SYNOPSIS

rconfig [-abdfhlnovV] [-m addr] [-t tagregex] [hosts]

=head1 DESCRIPTION

Rconfig is intended to manage configuration files across hetrogenous groups
of machines. The configuration for each machine is determined by a set of
rdist trees based on the various tags such as OS, hostname, and architecture.
Files in 'more specific' rdist trees take priority.

Remote configuration requires passwordless root rsh/ssh from a host with
direct access to the rconfig basedir. Target machines will require rdist
but not rconfig installed

=head1 CONFIGURATION

rconfig has a default set of configuration which can be optionally overridden
by $SYSCONFDIR/rconfig.conf, and then $basedir/rconfig.conf. The file can
continue end of lines with '\' and can include comments with '#'.

The valid configuration directives are:

    basedir	 Base of rconfig tree. Default: '/files/rconfig'

    dirtrees	 Space separated list of directory trees to includes
		 when determining files to push.  Files in earlier
		 trees are pushed in preference to those in later
		 ones.	See also TAGS. Default:
		     ${fqdn}
		     ${name}
		     ${tags}
		     ${osname}-${osver}-${machine}-${x11}
		     ${osname}-${osver}-${machine}
		     ${osname}-${osver}-${machine_arch}-${x11}
		     ${osname}-${osver}-${machine_arch}
		     ${osname}-${osver}-${x11}
		     ${osname}-${osver}
		     ${osname}-${machine}-${x11}
		     ${osname}-${machine}
		     ${osname}-${machine_arch}-${x11}
		     ${osname}-${machine_arch}
		     ${osname}-${x11}
		     ${osname}
		     common-${x11}
		     common
		 Note: when adding a new tag the 'dirtrees += ${newtag}'
		 syntax will insert the new tag directly after ${name},
		 if present, otherwise it will append a space then value.
		 This is particularly convenient if a new tag has been
		 added and it should be treated as more important than
		 everything except the machine's name. This feature is
		 disabled after dirtrees is assigned with 'dirtrees = x'.

    fping	 Command name for fping. Default: fping'

    fping_opts	 Options to pass to fping: Default '-i 250'

    mustbedir	 Space separated list of directories. If a dirtree
		 contains a matching entry which is not a directory,
		 abort push. Intended to stop disasters in case
		 someone puts a file called 'usr' in a dirtree,
		 which is pushed would delete the destination
		 directory '/usr'. Default '/ /usr'

    path	 Path setting: Default: "/sbin:/usr/sbin:/bin:/usr/bin:".
		 "${PREFIX}/bin:${PREFIX}/sbin"
		 Note: Path components are separated by : rather than spaces

    probe	 Command name for probe script.
		 Default: '${LIBEXEC}/rconfig_probe'

    probe_remote File into which probe script is copied on remote
		 machines Default: '/var/.rconfig_probe';

    rcp		 Command used to copy probe script to remote machine:
		 Default: 'scp'.

    rcp_opts	 Options to pass to rcp: Default '-B'

    rdist	 Command name for rdist. Default: 'rdist6'

    rdist_opts	 Options to pass to rdist. Default:
		 '-A 64 -a 10240 -M 12 -onumchkgroup -onumchkowner'

    rdist_except_pat Rdist 'except_pat' (exclude from any push)
		 settings.  Default: '/RCS\$ /CVS\$ /.svn\$ ,v\$ /core\$'

    rsh		 Remote shell command.
		 Default: '${LIBEXEC}/rconfig_ssh'.
		 If any options are required you must set to the name
		 of a shell script which then calls the desired commands
		 and options.  This is because rdist cannot handle
		 an RDIST_RSH with options.

    rsh_timeout	 Timeout on rsh commands in seconds: Default: 30

    shmux	 Command name for shmux. Default: shmux'

    shmux_opts	 Options to pass to shmux: Default '-S all -Qs -M 12'

    subst_ext	 Extension of files to parse for substitutions. Not yet
		 implemented. Default: '.subst';

Lines with 'directive = value' with set a directive.

Lines with 'directive += value' will append a space (or : in the case of path)
then value to a directive, with the exception of dirtrees (explained above).

Lines with 'directive -= value' will remove a (space or colon separated)
value from a directive.

rconfig reads the list of hosts to configure from 'basedir/hosts.conf'.

A slight performance gain can be obtained by keeping slower hosts away
from the end of the file.

=head1 TAGS

The default set of tags consists of the hostname plus those determined
by running the rconfig_probe script on the destination machine. They are:

    name	    hostname, with any domain information trimmed
    osname	    uname -s
    osver	    uname -v
    machine	    uname -m
    machine_arch    uname -p (if uname supports this)
    redhat	    Redhat Linux version number (or blank)
    x11		    x11 or nox11, depending on the existance of
		    /usr/X11R6/lib/libX11.so or /usr/X11R6/lib/libX11.a

Additional tags may be specified after each host in the hosts.conf file,
in the form tag=value, in a whitespace separated list. The value can be
a comma separated list.

Tags are used to determine the set of dirtrees to check for a given host.
If a tag used in a dirtree is not set for a given host, that dirtree is
skipped.

For example to add a set of primary and secondary dns servers:

    - Update some hosts in hosts.conf to add 'dns=pri' or 'dns=sec'
    - Add 'dirtrees += dnsserv-${dns}' entry in rconfig.conf
    - Create 'server-pri' and 'server-sec' trees in basedir

Hosts specified on the command line can be followed by +tag=value to set a
specific tag or tags. For example to push to newhost with 'foo' set to 'bar'
and 'bun' set to 'dy':

	'rconfig -f newhost+foo=bar+bun=dy'

=head1 CHROOT

It is intended that at some future point a chrooted area on a target host
could be configured by setting chroot=/path in hosts.conf.
NOTE: THIS HAS BEEN IMPLEMENTED FOR THE PROBE STATE, BUT NOT YET FOR THE
RDIST.

=head1 PING

Hosts are pinged using fping before a probe is attempted. This stage can
be skipped for all hosts by setting fping=SKIP in rconfig.conf, or for
individual hosts by setting fping=SKIP for a specific host in hosts.conf.

=head1 PROBE

The probe script determines the default set of tags. A default script is
provided in ${LIBEXEC}/rconfig_probe and will be automatically
copied to each machine as probed. The probe script runs a series of
commands on the target machine and returns the output in a series of
lines of the form:

    key=value

One of the keys output _must_ be probe_version, the value of which
should be changed if the probe script is updated on the master host.

The probe script is relatively configurable. For example, if the
osname was desired in lowercase this could be accomplished by adding
a 'tr A-Z a-z' in the appropriate place.

=head1 EXAMPLE

Sample contents of basedir for hosts wopr, orac, dora, and zen

    # hosts file listing all hosts, one per line
    hosts.conf

    # Files that go to all hosts
    common/etc/RCS			# RCS dir ignored by rconfig
    common/etc/csh.cshrc
    common/etc/csh.login
    common/etc/group
    common/etc/sshd.conf
    common/usr/local/bin/<many_scripts>

    # Files for specific architecturse
    netbsd-i386/usr/local/bin/<some_binaries>
    netbsd-sparc/usr/local/bin/<some_binaries>

    # Files for specific OS
    netbsd/usr/share/locale/iso_8859_1/LC_CTYPE

    # Zen has its own sshd.conf, overrriding common one
    zen/etc/sshd.conf

=head1 CAVEATS

If you have hostnames that overlap with architecture names or similar is it
suggested you change the ${name} entry in dirtrees to host/${name} or similar.

=cut

use strict;
use warnings;
use Getopt::Std;
use File::Find;
use IPC::Open3;
use Sys::Hostname;

my (
    %config,      # General configuration
    %locks,       # Locked files
    $hostlist,    # List of hosts
    %opt,         # Command line options
);

%config = (
    basedir  => '/files/rconfig',
    dirtrees => '${fqdn} '
      . '${name} '
      . '${tags} '
      . '${osname}-${osver}-${machine}-${x11} '
      . '${osname}-${osver}-${machine} '
      . '${osname}-${osver}-${machine_arch}-${x11} '
      . '${osname}-${osver}-${machine_arch} '
      . '${osname}-${osver}-${x11} '
      . '${osname}-${osver} '
      . '${osname}-${machine}-${x11} '
      . '${osname}-${machine} '
      . '${osname}-${machine_arch}-${x11} '
      . '${osname}-${machine_arch} '
      . '${osname}-${x11} '
      . '${osname} '
      . 'common-${x11} '
      . 'common',
    fping      => 'fping',
    fping_opts => '-i 250',
    shmux      => 'shmux',
    shmux_opts => '-S all -Qs -M 12',
    mustbedir  => '/ /usr',
    path       => "/sbin:/usr/sbin:/bin:/usr/bin:${PREFIX}/bin:${PREFIX}/sbin",
    probe      => "${LIBEXEC}/rconfig_probe",
    probe_remote     => '/var/.rconfig_probe',
    rcp              => 'scp',
    rcp_opts         => '-B',
    rdist            => 'rdist6',
    rdist_opts       => '-A 64 -a 10240 -M 12 -onumchkgroup -onumchkowner',
    rdist_except_pat => '/RCS\$ /CVS\$ /.svn\$ ,v\$ /core\$',
    rsh              => "${LIBEXEC}/rconfig_ssh",
    rsh_timeout      => 30,
    subst_ext        => '.subst',
);

umask(022);

if ( !getopts( 'abCIdfhlm:not:vVL:U:', \%opt ) || $opt{h} ) {
    usage_and_exit();
}
if ( $opt{V} ) { print "$version\n"; exit; }
if (
    (
        ( defined $opt{a} || defined $opt{l} ) +
        ( defined $opt{L} ) +
        ( defined $opt{C} ) +
        ( defined $opt{U} )
    ) != 1
    && !@ARGV
  )
{
    usage_and_exit("Must specify hosts, -a, -l, -C, -L or -U");
}

if ( $opt{d} ) {
    print "Initial config:\n";
    foreach my $key ( sort keys %config ) {
        print "    $key = $config{$key}\n";
    }
    print "\n";
}
config_read("${SYSCONFDIR}/rconfig.conf");
chdir( $config{basedir} ) || fail("Unable to chdir($config{basedir}): $!");
config_read("$config{basedir}/rconfig.conf");

if ( $config{mustbedir} ) {
    $config{mustbedir} = [ split( /\s+/, $config{mustbedir} ) ];
}
$config{rdist_except_pat} .= ' ' . $config{subst_ext} . '\$';

locks_read();

if ( $opt{C} ) {
    check_files();
    exit;
}
if ( $opt{L} || $opt{U} ) {
    if ( $opt{L} ) {
        if ( !@ARGV ) { usage_and_exit("Must given a reason with -L"); }
        if ( !-f $opt{L} ) {
            usage_and_exit("Cannot locate file to lock '$opt{L}'");
        }
        locks_file_lock( $opt{L}, "@ARGV" );
    }
    else { locks_file_unlock( $opt{U} ); }
    exit;
}

if ( defined $opt{b} ) {
    verbose("Note: Binary check\n");
    $config{rdist_opts} .= ' -ocompare';
}
if   ( defined $opt{o} ) { verbose("Note: Overwrite with older\n"); }
else                     { $config{rdist_opts} .= ' -oyounger'; }
if ( defined $opt{n} ) {
    print "Note: Do not update files\n";
    $config{rdist_opts} .= ' -v';
}

$ENV{PATH} = $config{path};

if ( $opt{I} ) {
    if ( @ARGV != 2 ) {
        usage_and_exit('Must specify from & dest hosts with -I');
    }
    $opt{I} = pop @ARGV;
    if ( $opt{I} !~ /^([-\w.]+)$/ ) {
        usage_and_exit('Invalid character in first hostname for -I');
    }
    $opt{I} = $1;
}

$hostlist = new Hostlist;
if ( $hostlist->error() ) { fail( "Setup: " . $hostlist->error() ); }
if ( $opt{l} )            { $hostlist->list_setactive(hostname); }
if ( $opt{a} )            { $hostlist->list_setactive( $hostlist->list_all ); }
if (@ARGV)                { $hostlist->list_setactive(@ARGV); }
$hostlist->error() && fail( "Config: " . $hostlist->error() );

if ( $opt{I} ) {
    my @host = $hostlist->list_active();
    if ( @host != 1 )    # Catch -l etc
    {
        usage_and_exit('Additional hosts specified with -I');
    }
    $host[0]->name( $opt{I} );
    $host[0]->netname( $opt{I} );
}

if ( $config{fping} ne 'SKIP' && !$hostlist->ping() ) {
    fail( "Ping: " . $hostlist->error() );
}
$hostlist->probe() || fail( "Probe: " . $hostlist->error() );
if ( $opt{d} ) {
    foreach my $host ( $hostlist->list_active ) {
        my $tags = $host->taghash;
        foreach my $tag ( sort keys %{$tags} ) {
            print $host->name(), ": $tag = ", $host->tag($tag), "\n";
        }
    }
    print "\n";
}
if ( $opt{t} ) { $hostlist->report_tags( $opt{t} ); }
else           { $hostlist->rdist() || fail( "Rdist: " . $hostlist->error() ); }
exit;

sub check_files {
    find(
        {
            wanted          => \&check_files_wanted,
            untaint         => 1,
            untaint_pattern => qr|^([-+@\\\w./]+)$|
        },
        $config{basedir}
    );
}

sub check_files_wanted {
    my ($path) = ($File::Find::name);
    $path =~ s#$config{basedir}/?##;
    my $is_rcs;
    if (/,v$/) { $is_rcs = 1; }
    if ( $File::Find::dir =~ m#(^|/)RCS$# ) {
        if ( !$is_rcs ) {
            print "$path: Non RCS file in RCS directory\n";
            return;
        }
        my $tmp = $File::Find::dir;
        $tmp =~ s#RCS$##;
        $tmp .= $_;
        $tmp =~ s#,v$##;
        if ( !-f $tmp ) {
            print "$path: In RCS but no copy checked out\n";
            return;
        }
    }
    elsif ( -f $_ ) {
        if ($is_rcs) {
            print "$path: RCS (,v) file not in RCS directory\n";
            return;
        }
        my $rcspath = "$config{basedir}/$path";
        $rcspath =~ s#(.*/|)#$1RCS/#;
        $rcspath .= ',v';
        if ( !-f $rcspath ) {

            # Check for generated
            print "$path: Not in RCS\n";
            return;
        }
        else {

            # XXX
        }
    }
}

sub config_read {
    my ($file) = @_;
    my ( $line, $dirtree_redefined );

    foreach my $key ( sort keys %config ) { $config{$key} =~ s/\s+/ /g; }
    if ( !open( FILE, $file ) ) { return (undef); }
    if ( $opt{d} ) { print "$file:\n"; }
    while (<FILE>) {
        chomp;
        s/#.*//;
        $line .= $_;
        if ( $line =~ s/\\$/ / ) { next; }

        my ( $key, $type, $value );
        if ( $line =~ /(\S+)\s*([+-]?)=\s*(.*\S)/ ) {
            ( $key, $type, $value ) = ( $1, $2, $3 );
            if ( !defined $config{$key} ) {
                fail("$file:$. - unknown config option '$key'");
            }
            if ( $type eq '+' ) {
                if ( $key eq 'path' ) { $config{$key} .= ":$value"; }
                elsif ($key ne 'dirtrees'
                    || $dirtree_redefined
                    || $config{$1} !~ s/(\${name})/$1 $value/ )
                {
                    $config{$key} .= " $value";
                }
            }
            elsif ( $type eq '-' ) {
                $value = quotemeta($value);
                if ( $key eq 'path' ) {
                    if (
                        $config{$key} !~ s/(:|(?<![^:]))$value(:|(?![^:]))/:/s )
                    {
                        fail("$file:$. - Unable to remove $value from $key");
                    }
                }
                else {
                    if (
                        $config{$key} !~ s/( |(?<![^ ]))$value( |(?![^ ]))/ /s )
                    {
                        fail("$file:$. - Unable to remove $value from $key");
                    }
                }
            }
            else {
                if ( $key eq 'dirtrees' ) {
                    $dirtree_redefined = 1;
                    if ( $opt{d} ) { print "    $key redefined\n"; }
                }
                $config{$key} = $value;
            }
            if ( $opt{d} ) { print "    $key = $config{$key}\n"; }
        }
        elsif (/\S/) { fail("$file:$. - unparsable line: '$line'."); }
        $line = '';
    }
    close(FILE);
    if ( $opt{d} ) { print "\n"; }
}

sub fail {
    print STDERR @_, "\n";
    exit(1);
}

sub locks_file_lock {
    my ( $file, $why ) = @_;
    $locks{$file} = { file => $file, when => time, why => $why };
    locks_save();
}

sub locks_file_unlock {
    my ($file) = @_;
    if ( $file eq '*' ) {
        undef %locks;
        locks_save();
    }
    elsif ( $locks{$file} ) {
        delete $locks{$file};
        locks_save();
    }
    else { print STDERR "File '$file' was not locked\n"; }
}

sub locks_read {
    my ($locks) = 'locks';
    if ( open( FILE, $locks ) ) {
        while (<FILE>) {
            chomp;
            my ( $file, $when, $why ) = split( ' ', $_, 3 );
            $locks{$file} = { file => $file, when => $when, why => $why };
        }
        close(FILE);
    }
}

sub locks_save {
    my ($locks) = 'locks';
    if ( !%locks ) { unlink $locks; }
    elsif ( open( FILE, ">$locks.tmp" ) ) {
        foreach my $lock ( values %locks ) {
            print FILE "$lock->{file} $lock->{when} $lock->{why}\n";
        }
        if ( !close(FILE) ) {
            print STDERR "Unable to save $locks: $!\n";
            unlink "$locks.tmp";
        }
        elsif ( !rename( "$locks.tmp", $locks ) ) {
            print STDERR "Unable to save $locks: $!\n";
            unlink "$locks.tmp";
        }
    }
    else { print STDERR "Unable to save $locks: $!\n"; }
}

sub run_cmd {
    my ( $cmd, $timeout ) = @_;
    my ( @output, @errors );
    my ( $savesig, $pid, $timed_out );

    if ( $opt{v} ) { print "\n>>$cmd<<\n"; }
    if ( !( $pid = open3( 'WRITE', 'READ', 'READERR', $cmd ) ) ) {
        @errors = ('open3 failed');
    }
    else {
        if ($timeout) {
            $savesig = $SIG{ALRM};
            $SIG{ALRM} = sub {
                kill 'KILL', $pid;
                close(READ);
                close(READERR);
                defined($timed_out) || ( $timed_out = 'timed out' );
            };
            { alarm($timeout); }
        }
        print WRITE '';    # Grrr... to shut up perl
        close(WRITE);
        @output = <READ>;
        if ( !$timed_out ) { @errors = <READERR>; }
        if ($timeout) {
            alarm(0);
            $savesig && ( $SIG{ALRM} = $savesig );
        }
        else {
            close(READ);
            close(READERR);
        }
    }
    wait;
    if ($timed_out) { push( @errors, $timed_out ); }
    ( \@output, \@errors );
}

sub usage_and_exit {
    if (@_) { print "**** @_\n\n"; }
    print "Usage: rconfig [<opts>] [hosts]
opts:	     -a Distribute to all hosts in hosts.conf
	     -b Use binary check
	     -d Debug - do not run rdist, send config to STDOUT
	     -f Bypass hosts.conf test
	     -h This help
	     -l Update localhost only
             -I Init. Given two hosts will push first's config to second
      -m <addr> Email output to <addr> (NOTYET)
	     -n Do not update anything
	     -o Push older files over newer files on destination
     -t <regex> List tags (probes, no push). Use '-t .' for all tags
	     -v More verbose output
	     -V Print version and exit

	     -C Check files in rconfig tree
-L <file> <why> Lock <file> so it will not be pushed (relative to basedir)
      -U <file> Unlock <file> so it can be pushed again (* for all files)

Hosts specified on the command line can be followed by +tag=value to set a
specific tag or tags. For example to push to newhost with 'foo' set to 'bar'
and 'bun' set to 'dy':

	'rconfig -f newhost+foo=bar+bun=dy'

";
    exit(0);
}

sub verbose { $opt{v} && print @_; }

package Host;

use Sys::Hostname;

sub active {
    my $self = shift;
    @_ ? ( $self->{_active} = $_[0] ) : $self->{_active};
}

sub error {
    my $self = shift;
    if (@_) { $self->{_error} .= "@_"; }
    $self->{_error};
}

sub error_probe {
    my $self = shift;
    if (@_) { $self->{_error_probe} .= "@_"; }
    $self->{_error_probe};
}

sub error_reset {
    my $self = shift;
    delete $self->{_error};
    delete $self->{_error_probe};
}

sub fqdn {
    my $self = shift;
    @_ ? ( $self->{_fqdn} = $_[0] ) : $self->{_fqdn};
}

sub islocalhost {
    my ($self) = shift;
    $self->namematch(hostname);
}

sub namematch {
    my ($self) = shift;
    my ($name) = @_;
         $self->name()    eq $name
      || $self->fqdn()    eq $name
      || $self->netname() eq $name
      || ( $name eq 'localhost' && $self->islocalhost() );
}

sub name {
    my ($self) = shift;
    @_ ? ( $self->{_name} = $_[0] ) : $self->{_name};
}

sub netname {
    my ($self) = shift;
    @_ ? ( $self->{_netname} = $_[0] ) : ( $self->{_netname} || '' );
}

sub new {
    my $class = shift;
    my $self  = {};
    bless $self, $class;
    my $name = $_[0];
    if ( $name !~ /^([-\w.]+)$/ ) {
        $self->error("Hostname '$name' contains invalid characters.");
        return ($self);
    }
    $name = $1;    # Untaint;
    if ( !( ( $self->{_fqdn} ) = ( gethostbyname($name) )[0] ) ) {
        $self->error("Unable to resolve hostname '$name'.");
        return ($self);
    }
    $self->{_name} = $self->fqdn();
    if   ( $self->islocalhost() ) { $self->netname('localhost'); }
    else                          { $self->netname( $self->{_name} ); }

    # Do not mangle IP addresses
    if ( $self->{_name} !~ /^(\d+\.){3}\d+$/ ) { $self->{_name} =~ s/\..*//; }
    if ( !$self->namematch($name) ) {
        warn("Must use primary name of '$self->{_name}', not '$name'");
        return ($self);
    }
    $self->tag( 'name', $self->{_name} );
    $self->tag( 'fqdn', $self->{_fqdn} );
    return $self;
}

sub probe_update {
    my ($self) = shift;
    my $remote_path = $config{probe_remote};
    if ( $self->tag('chroot') ) {
        $remote_path = $self->tag('chroot') . '/' . $remote_path;
    }
    my ($cp) =
        "$config{rcp} $config{rcp_opts} $config{probe} "
      . $self->netname()
      . ":$remote_path";
    print $self->name, ": Update $config{probe_remote}\n";
    my ( $output, $errors ) = main::run_cmd( $cp, $config{rsh_timeout} );
    if ( @{$errors} ) {
        $self->error("Unable to copy probe to host: @{$errors}");
        return;
    }
    1;
}

sub probe_record_line {
    my ($self) = shift;
    my ( $key, $value ) = split( '=', $_[0], 2 );
    if ( !$value ) { $self->error_probe("Invalid data from probe ($2)"); }
    else {
        if   ( $key eq 'probe_version' ) { $self->probe_version($value); }
        else                             { $self->tag( $key, $value ); }
    }
}

sub probe_bad_data {
    my $self = shift;
    @_ ? ( $self->{_bad_data} = $_[0] ) : ( $self->{_bad_data} || '' );
}

sub probe_version {
    my $self = shift;
    @_
      ? ( $self->{_probe_version} = $_[0] )
      : ( $self->{_probe_version} || '' );
}

sub tag_restore {
    my $self = shift;
    if ( $self->{_tag_store} ) {
        my (%restore) = %{ $self->{_tag_store} };
        $self->{_tag} = \%restore;
    }
}

sub tag_store {
    my $self = shift;
    my (%store) = %{ $self->{_tag} };
    $self->{_tag_store} = \%store;
}

sub tag {
    my $self = shift;
    if ( @_ > 1 ) { $self->{_tag}{ $_[0] } = $_[1]; }
    $self->{_tag}{ $_[0] } ? $self->{_tag}{ $_[0] } : '';
}

sub taghash {
    my $self = shift;
    my $tags;
    foreach my $tag ( sort keys %{ $self->{_tag} } ) {
        $tags->{$tag} = $self->{_tag}{$tag};
    }
    $tags;
}

package Hostlist;

use File::Find;
use IO::Handle;
use IPC::Open3;

sub error {
    my $self = shift;
    if (@_) { $self->{_error} .= "@_"; }
    $self->{_error};
}

sub failedhosts {
    my ($self) = shift;
    my (@failed);
    foreach my $host ( $self->list_all ) {
        $host->error && push( @failed, $host );
    }
    @failed;
}

sub list_all {
    my $self = shift;
    $self->{_list} ? @{ $self->{_list} } : ();
}

sub list_active {
    my ($self) = shift;
    my @list;
    foreach my $host ( $self->list_all ) {
        $host->active && !$host->error && push( @list, $host );
    }
    @list;
}

sub list_failed {
    my ($self) = shift;
    my @list;
    foreach my $host ( $self->list_all ) {
        $host->active && $host->error && push( @list, $host );
    }
    @list;
}

sub list_update_active_and_report {
    my ($self) = shift;
    my (@goodhosts);

    if ( !$self->list_failed ) { print "All"; }
    elsif ( !$self->list_active ) {
        print "No hosts";
        if ( !$self->error() ) { $self->error("No hosts left"); }
    }
    else {
        print scalar( $self->list_active ) . '/'
          . scalar( $self->list_active + $self->list_failed )
          . " hosts";
    }
    print " OK\n\n";
    !$self->error();
}

sub list_setactive {
    my ($self)  = shift;
    my (@hosts) = @_;

    foreach my $name (@hosts) {
        my ($host);

        if ( ref $name eq 'Host' ) { $host = $name; }
        else {
            my @tagset;
            ( $name, @tagset ) = split( '\+', $name );
            if ( !( $host = $self->lookuphost($name) ) ) {
                $host = new Host $name;
                if ( $host->error() ) {
                    $self->error( $host->error() );
                    next;
                }
                elsif ( !$opt{f} ) {
                    $self->error("Host '$name' not in hosts.conf. -f to force");
                    next;
                }
                if ( $self->lookuphost( $host->name() ) ) {
                    $self->error(
                        "'" . $host->name() . "' matches more than one host" );
                    next;
                }
                $self->list_add($host);
            }
            foreach my $tagval (@tagset) {
                if ( $tagval !~ /^(.+)=(.+)$/ ) {
                    $self->error("Host '$name' - '$tagval' should be tag=val");
                    next;
                }
                $host->tag( $1, $2 );
            }
        }
        $host->active(1);
    }
    !$self->error();
}

sub list_add {
    my $self = shift;
    push( @{ $self->{_list} }, @_ );
}

sub hosts_config_read {
    my $self = shift;
    my ($file) = @_;
    my ($line);

    if ( !open( FILE, $file ) ) {
        $self->error("Unable to open host config '$file': $!");
        return;
    }
    while (<FILE>) {
        chomp;
        s/#.*//;
        $line .= $_;
        if ( $line =~ s/\\$/ / ) { next; }

        my ( $name, @tagvals ) = split( '\s+', $line );
        defined $name || next;
        my $host = new Host $name;
        if    ( !$host )         { $self->error("$file: $name not found"); }
        elsif ( $host->error() ) { $self->error( "$file: " . $host->error() ); }
        else {
            $self->list_add($host);
            foreach my $tagval (@tagvals) {
                if ( $tagval =~ m#^(\w+)=([\w\d/,]+)$# ) {
                    $host->tag( $1, $2 );
                }
                else {
                    $self->error("$file: tagval must be 'name=val' ($tagval)");
                }
            }
            $host->tag_store;
        }
        $line = '';
    }
    close(FILE);
    return ( !$self->error );
}

sub lookuphost {
    my ($self) = shift;
    my ($name) = @_;
    foreach my $host ( $self->list_all ) {
        if ( $host->namematch($name) ) { return ($host); }
    }
    undef;
}

sub new {
    my $class = shift;
    my $self  = {};
    bless $self, $class;
    $self->hosts_config_read("$config{basedir}/hosts.conf");
    return $self;
}

sub maxname {
    my ($self) = shift;
    my ($len)  = (0);

    foreach my $host ( $self->list_active ) {
        ( length( $host->name() ) > $len )
          && ( $len = length( $host->name() ) );
    }
    $len;
}

sub ping {
    my ($self) = shift;
    my ($cmd);
    my ( $output, $errors, %chk, @checking );

    foreach my $host ( $self->list_active ) {
        if ( $host->islocalhost() || $host->tag('fping') eq 'SKIP' ) {
            $chk{ $host->netname() } = 2;
        }
        else {
            push( @checking, $host );
            $cmd .= ' ' . $host->netname();
            $chk{ $host->netname() } = 1;
        }
    }

    if ( $self->list_active && !@checking ) { return (1); }

    print $self->title( "Ping", @checking );
    $cmd = "$config{fping} $config{fping_opts} -a $cmd";
    ( $output, $errors ) = main::run_cmd($cmd);
    if ( @{$errors} ) {
        $self->error("fping: @{$errors}");
        return (undef);
    }
    foreach my $netname ( @${output} ) {
        chomp $netname;
        $chk{$netname} = 2;
    }

    foreach my $host ( $self->list_active ) {
        if ( $chk{ $host->netname() } != 2 ) {
            $host->error("fping failed");
            print $host->name() . ": *** " . $host->error . "\n";
        }
    }
    $self->list_update_active_and_report;
}

sub probe {
    my ($self) = shift;

    my $fmtwidth = $self->maxname() + 1;
    my $count    = 0;
    my $to_try   = $self->list_active;
    my $local;

    print $self->title("Probe");

    foreach my $host ( $self->list_active ) {
        if ( $host->islocalhost() ) { $local = $host; }
    }

    # Check OK now before we loop
    if ( !$self->probe_master_version($local) ) { return; }

    $self->probe_hosts( $self->list_active );

    my (@retry);
    foreach my $host ( $self->list_active ) {
        if (   $self->probe_master_version ne $host->probe_version
            || $host->error_probe )
        {
            $host->error_reset;
            $host->probe_update;
            $host->tag_restore;
            push( @retry, $host );
        }
    }

    if (@retry) {
        print "\n", $self->title( "Reprobe", @retry );
        $self->probe_hosts(@retry);

        foreach my $host (@retry) {
            if ( $host->error_probe ) { $host->error( $host->error_probe ); }
            if ( $host->error ) {
                my $err = $host->error;
                $err =~ s/[\r\n]/ /g;
                print $host->name, ": *** $err\n";
            }
        }
    }
    $self->list_update_active_and_report;
}

sub probe_hosts {
    my ($self)  = shift;
    my (@hosts) = @_;
    my ( %chk, $cmd );

    foreach my $host (@hosts) {
        if ( !$host->islocalhost() ) {
            $cmd .= ' ' . $host->netname();
            $chk{ $host->netname() } = $host;
        }
    }
    %chk || return;    # May only be local

    $ENV{SHMUX_RSH} = $config{rsh};
    $cmd = "$config{shmux} $config{shmux_opts} -c '$config{probe_remote}' $cmd";
    my ( $output, $errors ) = main::run_cmd($cmd);

    foreach my $line ( @${errors} ) {
        main::verbose("Error: $line");
        if ( $line =~ /(\S+)! (.*)/ && $chk{$1} ) {
            if ( $2 eq "Host key verification failed." ) {
                $chk{$1}->error($2);
                print $chk{$1}->name, ": *** " . $chk{$1}->netname . " $2\n";
            }
            elsif ( $2 eq
                "Permission denied (publickey,password,keyboard-interactive)." )
            {
                $chk{$1}->error($2);
                print $chk{$1}->name, ": *** $2\n";
            }
            else {
                $chk{$1}->error_probe($2);
                print $chk{$1}->name, ": *** $2\n";
            }
        }
    }
    foreach my $line ( @${output} ) {
        main::verbose($line);
        if ( $line =~ /(\S+): (.+)/ && $chk{$1} ) {
            my $host = $chk{$1};
            $host->probe_record_line($2);
        }
        else { print "Unparsable reply: $line"; }
    }
}

sub probe_master_version {
    my ($self)      = shift;
    my ($localhost) = @_;      # Do we record for localhost

    if ( $self->{_probe_version} )    # Cache
    {
        return $self->{_probe_version};
    }
    if ( !-x $config{probe} ) {
        $self->error("Unable to locate probe script $config{probe}");
        return;
    }

    my ( $output, $errors ) =
      main::run_cmd( $config{probe}, $config{rsh_timeout} );
    if ( @{$errors} ) {
        $self->error("probe $config{probe} returns errors (@{$errors})");
        return;
    }
    foreach ( @{$output} ) {
        if (/probe_version=(.*)/) { $self->{_probe_version} = $1; }
        $localhost || next;
        chomp;
        $localhost->probe_record_line($_);
    }
    if ( !$self->{_probe_version} ) {
        $self->error("probe $config{probe} does not return probe_version");
        return;
    }
    $self->{_probe_version};
}

sub rdist {
    my ($self) = shift;
    my ( $fmtwidth, %rdist_config, @rdist_config );

    print $self->title("Rdist setup");
    print "'!' means taken from the cache\n";

    $fmtwidth = $self->maxname() + 1;

    foreach my $host ( $self->list_active ) {
        my ( @dirtreelist, %dirtreeseen );

        printf( "%-${fmtwidth}s", $host->name() . ':' );

        my @todo = split( /\s+/, $config{dirtrees} );
        while ( my $dir = shift @todo ) {
            if ( $dir =~ m/(.*?)\$\{(\w+)\}(.*)/ ) {
                if ( $host->tag($2) ) {
                    my ( $left, $tags, $right ) = ( $1, $host->tag($2), $3 );
                    foreach my $tag ( reverse split( ',', $tags ) ) {
                        unshift( @todo, $left . $tag . $right );
                    }
                }
                else {
                    main::verbose(" (skipped $2)");
                }
            }
            else { push( @dirtreelist, $dir ); }
        }
        if ( $opt{v} ) { print "@dirtreelist\n"; }

        foreach my $dirtree (@dirtreelist) {
            $dirtreeseen{$dirtree} && next;
            $dirtreeseen{$dirtree} = 1;
            -d $dirtree || next;
            if ( $config{mustbedir} ) {
                foreach my $dir ( @{ $config{mustbedir} } ) {
                    if   ( $dir eq '/' ) { $dir = $dirtree; }
                    else                 { $dir = "$dirtree$dir"; }
                    if ( -l $dir ) {
                        $self->error("$dir is a symlink not a directory.");
                    }
                    elsif ( -f $dir ) {
                        $self->error("$dir is a file not a directory.");
                    }
                }
            }
            push(
                @{
                    $rdist_config{
                        "$dirtree -> \${name}\n" . $self->rdist_tree($dirtree)
                      }
                  },
                $host->netname()
            );
        }
        delete $self->{_filetree};    # Used in rdist_tree
        print "\n";
    }

    my $any_skipped;
    foreach my $lock ( sort { $a->{file} cmp $b->{file} } values %locks ) {
        if ( $lock->{skipped} ) {
            if ( !$any_skipped ) {
                print "\n+++ Skipping locked files +++\n";
                $any_skipped = 1;
            }
            print "$lock->{file}: ", $lock->{why}, ".\n";
        }
    }

    if ( $self->{_tree_mismatch} ) {
        $self->error( "Directory permissions mismatch: "
              . join( ' ', keys %{ $self->{_tree_mismatch} } ) );
        return;
    }
    foreach my $name ( keys %rdist_config ) {
        my ( $names, $conf );
        if ( @{ $rdist_config{$name} } > 1 ) {
            $names = "(@{$rdist_config{$name}})";
        }
        else { $names = "@{$rdist_config{$name}}"; }
        $conf = $name;
        $name =~ s/\${name}/$names/;
        push( @rdist_config,
            $name, "except_pat ( $config{rdist_except_pat} ) ;\n", "\n" );
    }
    print "\n";
    if ( $opt{d} ) {
        print "$config{rdist} $config{rdist_opts} -f -\n\n";
        print @rdist_config;
    }
    else {
        my $cmd = "$config{rdist} $config{rdist_opts} -f -";
        my $pid;
        print $self->title("Rdist push");
        $ENV{RDIST_RSH} = $config{rsh};
        if ( !( $pid = open3( 'WRITE', 'READ', 'READERR', $cmd ) ) ) {
            $self->error("Unable to run $cmd: $!");
        }
        else {
            my ( $last_length, $pad );
            print WRITE @rdist_config;
            close(WRITE);
            STDOUT->autoflush(1);
            while (<READ>) {
                chomp;
                my ( $host, $file, $message, $overwrite, $error );

                if (
m#(\S+): (\S+: |)(\S+): (updating|updated|installing|need to update|need to install|Warning: remote copy is newer|chmod from \d+ to \d+|need to chmod to \d+|chown from \d+\.\d+ to \d+\.\d+|need to chown from \d+\.\d+ to \d+\.\d+|mkdir)$#
                  )
                {
                    $host    = $self->lookuphost($1);
                    $file    = $3;
                    $message = $4;
                    $file =~ s#^//#/#;
                }
                elsif (/^(\S+): updating (host \S+|of \S+ finished)$/) {
                    $host = $self->lookuphost($1);
                    if ( substr( $2, 0, 1 ) eq 'h' ) { $message = 'starting'; }
                    else                             { $message = 'finished'; }
                    $file      = '';
                    $overwrite = 1;
                }
                elsif (m#^([^/\s:]+): (.+)#) {
                    $host  = $self->lookuphost($1);
                    $error = "ERROR: $2";
                }
                if ( !$host ) { $error ||= "CANNOT PARSE OUTPUT: $_"; }
                if ($error) {
                    if ($host) { $host->error("rdist: $error"); }
                    $_ = $error;
                }
                elsif ($host) {
                    my $filewidth = 80 - 3 - $fmtwidth - length($message);
                    if ( $filewidth < 1 ) { $filewidth = 1; }
                    $_ = sprintf( "%-${fmtwidth}s %-${filewidth}s $message",
                        $host->name() . ':', $file );
                }

                if ( $last_length && $last_length > length($_) ) {
                    $pad = $last_length - length($_);
                }
                else { $pad = 0; }

                if   ($overwrite) { $last_length = length($_); }
                else              { $last_length = 0; }

                print $_ . ' ' x $pad . ( $overwrite ? "\r" : "\n" );
            }
            close(READ);
            if ($last_length) { print ' ' x $last_length . "\r"; }

            print( "\nCOMPLETED:" . $self->title() );
            if ( $self->list_failed ) {
                print "FAILED ON:";
                foreach my $host ( $self->list_failed ) {
                    print ' ' . $host->name();
                }
                print "\n";
            }
        }
    }
    !$self->error();
}

my ( %rdist_tree_cache, @rdist_tree_list, $rdist_tree_base,
    @rdist_tree_except );

sub rdist_tree {
    my ($self)     = shift;
    my ($treebase) = @_;
    my ( @thistree, $output );

    print " $treebase";

    if ( defined $rdist_tree_cache{$treebase} ) {
        @thistree = @{ $rdist_tree_cache{$treebase} };
        print '!';
    }
    else {
        my ($rdist_except_sub) = $config{rdist_except_pat};
        $rdist_except_sub =~ s/\\\$/\$/g;
        @rdist_tree_except = split( '\s', $rdist_except_sub );
        @rdist_tree_list   = ();
        $rdist_tree_base   = $treebase;
        find(
            {
                wanted          => \&rdist_tree_wanted,
                untaint         => 1,
                untaint_pattern => qr|^([-+@\\\w./]+)$|
            },
            $treebase
        );
        @thistree = @rdist_tree_list;
        $rdist_tree_cache{$treebase} = \@thistree;
    }

    $output = "install / ;\n";

    # For non directory entry:
    #	If a previous (higher priority) entry exists; exclude.
    # For each directory entry:
    #	If a previous non directory entry exists; exclude.
    #	If a previous directory entry exists, check owner and perms match.
    foreach my $path (@thistree) {
        if ( $self->{_filetree}{$path} ) {
            my ( @tstat, @ostat );
            if ( !( @tstat = lstat("$treebase$path") ) ) {
                $self->error("Unable to lstat($treebase$path): $!");
            }
            if ( !( @ostat = lstat("$self->{_filetree}{$path}$path") ) ) {
                $self->error(
                    "Unable to lstat($self->{_filetree}{$path}$path): $!");
            }

            if (   ( $tstat[2] & 0xF000 ) == 0x4000
                && ( $ostat[2] & 0xF000 ) == 0x4000 )
            {    # S_IFDIR
                if (   $tstat[2] != $ostat[2]
                    || $tstat[4] != $ostat[4]
                    || $tstat[5] != $ostat[5] )
                {
                    $self->{_tree_mismatch}
                      {"{$treebase,$self->{_filetree}{$path}}$path"} = 1;
                }
                next;
            }
        }
        else {
            $self->{_filetree}{$path} = $treebase;
            if ( !$locks{"$treebase$path"} ) { next; }
            $locks{"$treebase$path"}{skipped} = 1;
        }

        my ($nasty);
        $nasty = "$treebase$path";
        $nasty =~ s/:/\\:/g;    # but rdist does not like ':'
        $output .= "except $nasty;\n";
    }
    $output;
}

sub rdist_tree_wanted {
    my ($path) = ($File::Find::name);

    foreach my $pat (@rdist_tree_except) {
        if ( $path =~ /$pat/ ) {
            $File::Find::prune = 1;
            return;
        }
    }
    $path =~ s/^$rdist_tree_base//;
    push( @rdist_tree_list, $path );
}

sub report_tags {
    my ($self)  = shift;
    my ($regex) = @_;
    my (%len);
    foreach my $host ( $self->list_active ) {
        my ($tags);
        $tags = $host->taghash;
        foreach my $tag ( keys %{$tags} ) {
            if ( $tag !~ /$regex/ && $tag ne 'name' ) { next; }
            if ( !defined $len{$tag} ) { $len{$tag} = length $tag; }
            if ( length $tags->{$tag} > $len{$tag} ) {
                $len{$tag} = length $tags->{$tag};
            }
        }
    }

    foreach my $tag ( sort keys %len ) { printf( "%-$len{$tag}s ", $tag ); }
    print "\n";
    foreach my $tag ( sort keys %len ) { print '^' x $len{$tag}, ' '; }
    print "\n";
    foreach my $host ( $self->list_active ) {
        foreach my $tag ( sort keys %len ) {
            printf( "%-$len{$tag}s ", $host->tag($tag) );
        }
        print "\n";
    }
    print "\n";
}

# If $title is omitted with not include '--[' ']--'
# If @list is omitted will use list_active()
sub title {
    my $self = shift;
    my ( $title, @list ) = @_;
    my ( $pre, $output, $post );
    my ($len);
    if ( !@list ) { @list = $self->list_active() }

    $output = '';
    if ($title) {
        $pre  = $title . ' --[ ';
        $post = ']--';
    }
    else { $pre = ' '; $post = ''; }

    foreach my $host (@list) { $output .= $host->name() . ' '; }
    if ( length($pre) + length($output) + length($post) > 80 ) {
        $output = scalar(@list) . ' hosts ';
    }    # Should never be one
    $pre . $output . $post . "\n";
}
