mirror of
https://github.com/duncs/clusterssh.git
synced 2025-07-02 01:21:14 +00:00
374 lines
8.1 KiB
Perl
374 lines
8.1 KiB
Perl
package App::ClusterSSH::Base;
|
|
|
|
use warnings;
|
|
use strict;
|
|
use Carp;
|
|
use App::ClusterSSH::L10N;
|
|
|
|
use Exception::Class (
|
|
'App::ClusterSSH::Exception',
|
|
'App::ClusterSSH::Exception::Config' => {
|
|
fields => 'unknown_config',
|
|
},
|
|
'App::ClusterSSH::Exception::Cluster',
|
|
'App::ClusterSSH::Exception::LoadFile',
|
|
);
|
|
|
|
# Dont use SVN revision as it can cause problems
|
|
use version;
|
|
our $VERSION = version->new('0.02');
|
|
|
|
my $debug_level = 4;
|
|
our $language = 'en';
|
|
our $language_handle;
|
|
our $app_configuration;
|
|
|
|
sub new {
|
|
my ( $class, %args ) = @_;
|
|
|
|
my $config = {
|
|
lang => 'en',
|
|
debug => 0,
|
|
%args,
|
|
};
|
|
|
|
my $self = bless $config, $class;
|
|
|
|
$self->set_debug_level( $config->{debug} );
|
|
$self->set_lang( $config->{lang} );
|
|
|
|
$self->debug(
|
|
7,
|
|
$self->loc( 'Arguments to [_1]->new(): ', $class ),
|
|
$self->_dump_args_hash(%args),
|
|
);
|
|
|
|
return $self;
|
|
}
|
|
|
|
sub _dump_args_hash {
|
|
my ( $class, %args ) = @_;
|
|
my $string = $/;
|
|
|
|
foreach ( sort( keys(%args) ) ) {
|
|
$string .= "\t";
|
|
$string .= $_;
|
|
$string .= ' => ';
|
|
if ( ref( $args{$_} ) eq 'ARRAY' ) {
|
|
$string .= "@{ $args{$_} }";
|
|
}
|
|
else {
|
|
$string .= $args{$_};
|
|
}
|
|
$string .= ',';
|
|
$string .= $/;
|
|
}
|
|
chomp($string);
|
|
|
|
return $string;
|
|
}
|
|
|
|
sub _translate {
|
|
my @args = @_;
|
|
if ( !$language_handle ) {
|
|
$language_handle = App::ClusterSSH::L10N->get_handle($language);
|
|
}
|
|
|
|
return $language_handle->maketext(@args);
|
|
}
|
|
|
|
sub loc {
|
|
my ( $self, @args ) = @_;
|
|
$_ ||= q{} foreach (@args);
|
|
return _translate(@args);
|
|
}
|
|
|
|
sub set_lang {
|
|
my ( $self, $lang ) = @_;
|
|
$language = $lang;
|
|
if ($self) {
|
|
$self->debug( 6, $self->loc( 'Setting language to "[_1]"', $lang ), );
|
|
}
|
|
return $self;
|
|
}
|
|
|
|
sub set_debug_level {
|
|
my ( $self, $level ) = @_;
|
|
if ( !defined $level ) {
|
|
croak(
|
|
App::ClusterSSH::Exception->throw(
|
|
error => _translate('Debug level not provided')
|
|
)
|
|
);
|
|
}
|
|
if ( $level > 9 ) {
|
|
$level = 9;
|
|
}
|
|
$debug_level = $level;
|
|
return $self;
|
|
}
|
|
|
|
sub debug_level {
|
|
my ($self) = @_;
|
|
return $debug_level;
|
|
}
|
|
|
|
sub output {
|
|
my ( $self, @text ) = @_;
|
|
print @text, $/;
|
|
return $self;
|
|
}
|
|
|
|
sub debug {
|
|
my ( $self, $level, @text ) = @_;
|
|
if ( $level <= $debug_level ) {
|
|
$self->output(@text);
|
|
}
|
|
return $self;
|
|
}
|
|
|
|
sub exit {
|
|
my ($self) = @_;
|
|
|
|
exit;
|
|
}
|
|
|
|
sub config {
|
|
my ($self) = @_;
|
|
|
|
if ( !$app_configuration ) {
|
|
croak(
|
|
App::ClusterSSH::Exception->throw(
|
|
_translate('config has not yet been set')
|
|
)
|
|
);
|
|
}
|
|
|
|
return $app_configuration;
|
|
}
|
|
|
|
sub set_config {
|
|
my ( $self, $config ) = @_;
|
|
|
|
if ($app_configuration) {
|
|
croak(
|
|
App::ClusterSSH::Exception->throw(
|
|
_translate('config has already been set')
|
|
)
|
|
);
|
|
}
|
|
|
|
if ( !$config ) {
|
|
croak(
|
|
App::ClusterSSH::Exception->throw(
|
|
_translate('passed config is empty')
|
|
)
|
|
);
|
|
}
|
|
|
|
$self->debug( 3, _translate('Setting app configuration') );
|
|
|
|
$app_configuration = $config;
|
|
|
|
return $self;
|
|
}
|
|
|
|
sub load_file {
|
|
my ( $self, %args ) = @_;
|
|
|
|
if ( !$args{filename} ) {
|
|
croak(
|
|
App::ClusterSSH::Exception->throw(
|
|
error => '"filename" arg not passed'
|
|
)
|
|
);
|
|
}
|
|
|
|
if ( !$args{type} || $args{type} !~ m/cluster|config/ ) {
|
|
croak(
|
|
App::ClusterSSH::Exception->throw(
|
|
error => '"type" arg invalid'
|
|
)
|
|
);
|
|
}
|
|
|
|
$self->debug( 2, 'Loading in config file: ', $args{filename} );
|
|
|
|
if ( !-e $args{filename} ) {
|
|
croak(
|
|
App::ClusterSSH::Exception::LoadFile->throw(
|
|
error => $self->loc(
|
|
'Unable to read file [_1]: [_2]' . $/, $args{filename},
|
|
$!
|
|
),
|
|
),
|
|
);
|
|
}
|
|
|
|
my $regexp
|
|
= $args{type} eq 'config' ? qr/\s*(\S+)\s*=\s*(.*)/
|
|
: $args{type} eq 'cluster' ? qr/\s*(\S+)\s+(.*)/
|
|
: croak(
|
|
App::ClusterSSH::Exception::LoadFile->throw(
|
|
error => 'Unknown arg type: ',
|
|
$args{type}
|
|
)
|
|
);
|
|
|
|
open( my $fh, '<', $args{filename} )
|
|
or croak(
|
|
App::ClusterSSH::Exception::LoadFile->throw(
|
|
error => $self->loc(
|
|
"Unable to read file [_1]: [_2]",
|
|
$args{filename}, $!
|
|
)
|
|
),
|
|
);
|
|
|
|
my %results;
|
|
my $line;
|
|
|
|
while ( defined( $line = <$fh> ) ) {
|
|
next
|
|
if ( $line =~ /^\s*$/ || $line =~ /^#/ )
|
|
; # ignore blank lines & commented lines
|
|
|
|
$line =~ s/\s*#.*//; # remove comments from remaining lines
|
|
$line =~ s/\s*$//; # remove trailing whitespace
|
|
|
|
# look for continuation lines
|
|
chomp $line;
|
|
if ( $line =~ s/\\\s*$// ) {
|
|
$line .= <$fh>;
|
|
redo unless eof($fh);
|
|
}
|
|
|
|
next unless $line =~ $regexp;
|
|
my ( $key, $value ) = ( $1, $2 );
|
|
if ( defined $key && defined $value ) {
|
|
if ( $results{$key} ) {
|
|
$results{$key} .= ' ' . $value;
|
|
}
|
|
else {
|
|
$results{$key} = $value;
|
|
}
|
|
$self->debug( 3, "$key=$value" );
|
|
$self->debug( 7, "entry now reads: $key=$results{$key}" );
|
|
}
|
|
}
|
|
|
|
close($fh)
|
|
or croak(
|
|
App::ClusterSSH::Exception::LoadFile->throw(
|
|
error => "Could not close $args{filename} after reading: $!"
|
|
),
|
|
);
|
|
|
|
return %results;
|
|
}
|
|
|
|
1;
|
|
|
|
=pod
|
|
|
|
=head1 NAME
|
|
|
|
App::ClusterSSH::Base - Base object provding utility functions
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
use base qw/ App::ClusterSSH::Base /;
|
|
|
|
# in object new method
|
|
sub new {
|
|
( $class, $arg_ref ) = @_;
|
|
my $self = $class->SUPER::new($arg_ref);
|
|
return $self;
|
|
}
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
Base object to provide some utility functions on objects - should not be
|
|
used directly
|
|
|
|
=head1 METHODS
|
|
|
|
These extra methods are provided on the object
|
|
|
|
=over 4
|
|
|
|
=item $obj = App::ClusterSSH::Base->new({ arg => val, });
|
|
|
|
Creates object. In higher debug levels the args are printed out.
|
|
|
|
=item $obj->id
|
|
|
|
Return the unique id of the object for use in subclasses, such as
|
|
|
|
$info_for{ $self->id } = $info
|
|
|
|
=item $obj->debug_level();
|
|
|
|
Returns current debug level
|
|
|
|
=item $obj->set_debug_level( n )
|
|
|
|
Set debug level to 'n' for all child objects.
|
|
|
|
=item $obj->debug($level, @text)
|
|
|
|
Output @text on STDOUT if $level is the same or lower that debug_level
|
|
|
|
=item $obj->set_lang
|
|
|
|
Set the Locale::Maketext language. Defaults to 'en'. Expects the
|
|
App::ClusterSSH/L10N/{lang}.pm module to exist and contain all relevant
|
|
translations, else defaults to English.
|
|
|
|
=item $obj->loc('text to translate [_1]')
|
|
|
|
Using the App::ClusterSSH/L10N/{lang}.pm module convert the given text to
|
|
appropriate language. See L<App::ClusterSSH::L10N> for more details. Essentially
|
|
a wrapper to maketext in Locale::Maketext
|
|
|
|
=item $obj->output(@);
|
|
|
|
Output text on STDOUT.
|
|
|
|
=item $obj->exit;
|
|
|
|
Stub to allow program to exit neatly from wherever in the code
|
|
|
|
=item $config = $obj->config;
|
|
|
|
Returns whatever configuration object has been set up. Croaks if set_config
|
|
hasnt been called
|
|
|
|
=item $obj->set_config($config);
|
|
|
|
Set the config to the given value - croaks if has already been called
|
|
|
|
=item %results = $obj->load_file( filename => '/path/to/file', type => '(cluster|config}' )
|
|
|
|
Load in the specified file and return a hash, parsing the file depending on
|
|
wther it is a config file (key = value) or cluster file (key value)
|
|
|
|
=back
|
|
|
|
=head1 AUTHOR
|
|
|
|
Duncan Ferguson, C<< <duncan_j_ferguson at yahoo.co.uk> >>
|
|
|
|
=head1 LICENSE AND COPYRIGHT
|
|
|
|
Copyright 1999-2010 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;
|