clusterssh 4.08-2 / usr / share / perl5 / App / ClusterSSH / Config.pm

package App::ClusterSSH::Config;

use strict;
use warnings;

use version;
our $VERSION = version->new('0.02');

use Carp;
use Try::Tiny;

use FindBin qw($Script);
use File::Copy;

use base qw/ App::ClusterSSH::Base /;
use App::ClusterSSH::Cluster;

my $clusters;
my %old_clusters;
my @app_specific = (qw/ command title comms method parent /);

# list of config items to not write out when writing the default config
my @ignore_default_config = (qw/ user /);

my %default_config = (
    terminal                   => "xterm",
    terminal_args              => "",
    terminal_title_opt         => "-T",
    terminal_colorize          => 1,
    terminal_bg_style          => 'dark',
    terminal_allow_send_events => "-xrm '*.VT100.allowSendEvents:true'",
    terminal_font              => "6x13",
    terminal_size              => "80x24",

    use_hotkeys             => "yes",
    key_quit                => "Alt-q",
    key_addhost             => "Control-Shift-plus",
    key_clientname          => "Alt-n",
    key_history             => "Alt-h",
    key_localname           => "Alt-l",
    key_retilehosts         => "Alt-r",
    key_macros_enable       => "Alt-p",
    key_paste               => "Control-v",
    key_username            => "Alt-u",
    mouse_paste             => "Button-2",
    auto_quit               => "yes",
    auto_close              => 5,
    use_natural_sort        => 0,
    window_tiling           => "yes",
    window_tiling_direction => "right",
    console_position        => "",

    screen_reserve_top    => 0,
    screen_reserve_bottom => 60,
    screen_reserve_left   => 0,
    screen_reserve_right  => 0,

    terminal_reserve_top    => 5,
    terminal_reserve_bottom => 0,
    terminal_reserve_left   => 5,
    terminal_reserve_right  => 0,

    terminal_decoration_height => 10,
    terminal_decoration_width  => 8,

    console      => 'console',
    console_args => '',
    rsh          => 'rsh',
    rsh_args     => "",
    telnet       => 'telnet',
    telnet_args  => "",
    ssh          => 'ssh',
    ssh_args     => "",
    sftp         => 'sftp',
    sftp_args    => "",

    extra_tag_file           => '',
    extra_cluster_file       => '',
    external_cluster_command => '',

    unmap_on_redraw => "no",    # Debian #329440

    show_history   => 0,
    history_width  => 40,
    history_height => 10,

    command             => q{},
    hide_menu           => 0,
    max_host_menu_items => 30,

    macros_enabled   => 'yes',
    macro_servername => '%s',
    macro_hostname   => '%h',
    macro_username   => '%u',
    macro_newline    => '%n',
    macro_version    => '%v',

    max_addhost_menu_cluster_items => 6,
    menu_send_autotearoff          => 0,
    menu_host_autotearoff          => 0,

    unique_servers    => 0,
    use_all_a_records => 0,

    send_menu_xml_file => $ENV{HOME} . '/.clusterssh/send_menu',

    auto_wm_decoration_offsets => "no",    # Debian #842965

    # don't set username here as takes precendence over ssh config
    user => '',
);

sub new {
    my ( $class, %args ) = @_;

    my $self = $class->SUPER::new(%default_config);

    ( my $comms = $Script ) =~ s/^c//;

    $comms = 'telnet'  if ( $comms eq 'tel' );
    $comms = 'console' if ( $comms eq 'con' );
    $comms = 'ssh'     if ( $comms eq 'lusterssh' );
    $comms = 'sftp'    if ( $comms eq 'sftp' );

    # list of allowed comms methods
    if ( 'ssh rsh telnet sftp console' !~ m/\b$comms\b/ ) {
        $self->{comms} = 'ssh';
    }
    else {
        $self->{comms} = $comms;
    }

    $self->{title} = uc($Script);

    $clusters = App::ClusterSSH::Cluster->new();

    return $self->validate_args(%args);
}

sub validate_args {
    my ( $self, %args ) = @_;

    my @unknown_config = ();

    foreach my $config ( sort( keys(%args) ) ) {
        if ( grep /$config/, @app_specific ) {

            #     $self->{$config} ||= 'unknown';
            next;
        }

        if ( exists $self->{$config} ) {
            $self->{$config} = $args{$config};
        }
        else {
            push( @unknown_config, $config );
        }
    }

    if (@unknown_config) {
        croak(
            App::ClusterSSH::Exception::Config->throw(
                unknown_config => \@unknown_config,
                error          => $self->loc(
                    'Unknown configuration parameters: [_1]' . $/,
                    join( ',', @unknown_config )
                )
            )
        );
    }

    if ( !$self->{comms} ) {
        croak(
            App::ClusterSSH::Exception::Config->throw(
                error => $self->loc( 'Invalid variable: comms' . $/ ),
            ),
        );
    }

    if ( !$self->{ $self->{comms} } ) {
        croak(
            App::ClusterSSH::Exception::Config->throw(
                error => $self->loc(
                    'Invalid variable: [_1]' . $/,
                    $self->{comms}
                ),
            ),
        );
    }

    # check the terminal has been found correctly
    # looking for the terminal should not be fatal
    if ( !-e $self->{terminal} ) {
        eval { $self->{terminal} = $self->find_binary( $self->{terminal} ); };
        if ($@) {
            warn $@->message;
        }
    }

    return $self;
}

sub parse_config_file {
    my ( $self, $config_file ) = @_;

    $self->debug( 2, 'Loading in config file: ', $config_file );

    #    if ( !-e $config_file || !-r $config_file ) {
    #        croak(
    #            App::ClusterSSH::Exception::Config->throw(
    #                error => $self->loc(
    #                    'File [_1] does not exist or cannot be read' . $/,
    #                    $config_file
    #                ),
    #            ),
    #        );
    #    }
    #
    #    open( CFG, $config_file ) or die("Couldnt open $config_file: $!");
    #    my $l;
    #    my %read_config;
    #    while ( defined( $l = <CFG> ) ) {
    #        next
    #            if ( $l =~ /^\s*$/ || $l =~ /^#/ )
    #            ;    # ignore blank lines & commented lines
    #        $l =~ s/#.*//;     # remove comments from remaining lines
    #        $l =~ s/\s*$//;    # remove trailing whitespace
    #
    #        # look for continuation lines
    #        chomp $l;
    #        if ( $l =~ s/\\\s*$// ) {
    #            $l .= <CFG>;
    #            redo unless eof(CFG);
    #        }
    #
    #        next unless $l =~ m/\s*(\S+)\s*=\s*(.*)\s*/;
    #        my ( $key, $value ) = ( $1, $2 );
    #        if ( defined $key && defined $value ) {
    #            $read_config{$key} = $value;
    #            $self->debug( 3, "$key=$value" );
    #        }
    #    }
    #    close(CFG);

    my %read_config;
    %read_config
        = $self->load_file( type => 'config', filename => $config_file );

    # grab any clusters from the config before validating it
    if ( $read_config{clusters} ) {
        $self->debug( 3, "Picked up clusters defined in $config_file" );
        foreach my $cluster ( sort split / /, $read_config{clusters} ) {
            if ( $read_config{$cluster} ) {
                $clusters->register_tag( $cluster,
                    split( / /, $read_config{$cluster} ) );
                $old_clusters{$cluster} = $read_config{$cluster};
                delete( $read_config{$cluster} );
            }
        }
        delete( $read_config{clusters} );
    }

    # tidy up entries, just in case
    $read_config{terminal_font} =~ s/['"]//g
        if ( $read_config{terminal_font} );

    $self->validate_args(%read_config);
}

sub load_configs {
    my ( $self, @configs ) = @_;

    for my $config (
        '/etc/csshrc',
        $ENV{HOME} . '/.csshrc',
        $ENV{HOME} . '/.clusterssh/config',
        )
    {
        $self->parse_config_file($config) if ( -e $config );
    }

    # write out default config file if necesasry
    try {
        $self->write_user_config_file();
    }
    catch {
        warn $_, $/;
    };

    # Attempt to load in provided config files.  Also look for anything
    # relative to config directory
    for my $config (@configs) {
        next unless ($config);    # can be null when passed from Getopt::Long
        $self->parse_config_file($config) if ( -e $config );

        my $file = $ENV{HOME} . '/.clusterssh/config_' . $config;
        $self->parse_config_file($file) if ( -e $file );
    }

    return $self;
}

sub write_user_config_file {
    my ($self) = @_;

    # attempt to move the old config file to one side
    if ( -f "$ENV{HOME}/.csshrc" ) {
        eval { move( "$ENV{HOME}/.csshrc", "$ENV{HOME}/.csshrc.DISABLED" ) };

        if ($@) {
            croak(
                App::ClusterSSH::Exception::Config->throw(
                    error => $self->loc(
                        'Unable to move [_1] to [_2]: [_3]' . $/,
                        '$HOME/.csshrc', '$HOME/.csshrc.DISABLED', $@
                    ),
                )
            );
        }
        else {
            warn(
                $self->loc(
                    'Moved [_1] to [_2]' . $/, '$HOME/.csshrc',
                    '$HOME/.csshrc.DISABLED'
                ),
            );
        }
    }

    return if ( -f "$ENV{HOME}/.clusterssh/config" );

    if ( !-d "$ENV{HOME}/.clusterssh" ) {
        if ( !mkdir("$ENV{HOME}/.clusterssh") ) {
            croak(
                App::ClusterSSH::Exception::Config->throw(
                    error => $self->loc(
                        'Unable to create directory [_1]: [_2]' . $/,
                        '$HOME/.clusterssh', $!
                    ),
                ),
            );

        }
    }

    # Debian #673507 - migrate clusters prior to writing ~/.clusterssh/config
    # in order to update the extra_cluster_file property
    if (%old_clusters) {
        if ( open( my $fh, ">", "$ENV{HOME}/.clusterssh/clusters" ) ) {
            print $fh '# '
                . $self->loc('Tag definitions moved from old .csshrc file'),
                $/;
            foreach ( sort( keys(%old_clusters) ) ) {
                print $fh $_, ' ', join( ' ', $old_clusters{$_} ), $/;
            }
            close($fh);
        }
        else {
            croak(
                App::ClusterSSH::Exception::Config->throw(
                    error => $self->loc(
                        'Unable to write [_1]: [_2]' . $/,
                        '$HOME/.clusterssh/clusters',
                        $!
                    ),
                ),
            );
        }
    }

    if ( open( CONFIG, ">", "$ENV{HOME}/.clusterssh/config" ) ) {
        foreach ( sort( keys(%$self) ) ) {
            my $comment = '';
            if ( grep /$_/, @ignore_default_config ) {
                $comment = '#';
            }
            print CONFIG ${comment}, $_, '=', $self->{$_}, $/;
        }
        close(CONFIG);
        warn(
            $self->loc(
                'Created new configuration file within [_1]' . $/,
                '$HOME/.clusterssh/'
            )
        );
    }
    else {
        croak(
            App::ClusterSSH::Exception::Config->throw(
                error => $self->loc(
                    'Unable to write default [_1]: [_2]' . $/,
                    '$HOME/.clusterssh/config', $!
                ),
            ),
        );
    }

    return $self;
}

# search given directories for the given file
sub search_dirs {
    my ( $self, $file, @directories ) = @_;

    my $path;

    foreach my $dir (@directories) {
        $self->debug( 3, "Looking for $file in $dir" );

        if ( -f $dir . '/' . $file && -x $dir . '/' . $file ) {
            $path = $dir . '/' . $file;
            $self->debug( 2, "Found at $path" );
            last;
        }
    }

    return $path;
}

# could use File::Which for some of this but we also search a few other places
# just in case $PATH isnt set up right
sub find_binary {
    my ( $self, $binary ) = @_;

    if ( !$binary ) {
        croak(
            App::ClusterSSH::Exception::Config->throw(
                error => $self->loc('argument not provided') . $/,
            ),
        );
    }

    $self->debug( 2, "Looking for $binary" );

    # if not found, strip the path and look again
    if ( $binary =~ m!^/! ) {
        if ( -f $binary ) {
            $self->debug( 2, "Already have full path to in $binary" );
            return $binary;
        }
        else {
            $self->debug( 2, "Full path for $binary incorrect; searching" );
            $binary =~ s!^.*/!!;
        }
    }

    my $path;
    if ( !-x $binary || substr( $binary, 0, 1 ) ne '/' ) {
        $path = $self->search_dirs( $binary, split( /:/, $ENV{PATH} ) );

        # if it is on $PATH then no need to qualitfy the path to it
        # keep it as it is
        if ($path) {
            return $binary;
        }
        else {
            $path = $self->search_dirs(
                $binary, qw!
                    /bin
                    /sbin
                    /usr/sbin
                    /usr/bin
                    /usr/local/bin
                    /usr/local/sbin
                    /opt/local/bin
                    /opt/local/sbin
                    !
            );
        }

    }
    else {
        $self->debug( 2, "Already configured OK" );
        $path = $binary;
    }
    if ( !$path || !-f $path || !-x $path ) {
        croak(
            App::ClusterSSH::Exception::Config->throw(
                error => $self->loc(
                    '"[_1]" binary not found - please amend $PATH or the cssh config file'
                        . $/,
                    $binary
                ),
            ),
        );
    }

    chomp($path);
    return $path;
}

sub dump {
    my ( $self, $no_exit, ) = @_;

    $self->debug( 3, 'Dumping config to STDOUT' );
    print( '# Configuration dump produced by "cssh -u"', $/ );

    foreach my $key ( sort keys %$self ) {
        my $comment = '';
        if ( grep /$key/, @app_specific ) {
            next;
        }
        if ( grep /$key/, @ignore_default_config ) {
            $comment = '#';
        }
        print $comment, $key, '=', $self->{$key}, $/;
    }

    $self->exit if ( !$no_exit );
}

#use overload (
#    q{""} => sub {
#        my ($self) = @_;
#        return $self->{hostname};
#    },
#    fallback => 1,
#);

1;

=pod

=head1 NAME

ClusterSSH::Config - Object representing application configuration

=head1 SYNOPSIS

=head1 DESCRIPTION

Object representing application configuration

=head1 METHODS

=over 4

=item $host=ClusterSSH::Config->new ({ })

Create a new configuration object.

=item $config->parse_config_file('<filename>');

Read in configuration from given filename

=item $config->validate_args();

Validate and apply all configuration loaded at this point

=item $path = $config->search_dirs('<name>', @seaarch_directories);

Search the given directories for the name given.  Return undef if not found.

=item $path = $config->find_binary('<name>');

Locate the binary <name> and return the full path.  Doesn't just search 
$PATH in case the environment isn't set up correctly

=item $config->load_configs(@extra);

Load up configuration from known locations (warn if .csshrc file found) and 
load in option files as necessary.

=item $config->write_user_config_file();

Write out default $HOME/.clusterssh/config file (before option config files
are loaded).

=item $config->dump()

Write currently defined configuration to STDOUT

=back

=head1 AUTHOR

Duncan Ferguson, C<< <duncan_j_ferguson at yahoo.co.uk> >>

=head1 LICENSE AND COPYRIGHT

Copyright 1999-2015 Duncan Ferguson.

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See http://dev.perl.org/licenses/ for more information.

=cut

1;