mirror of
https://github.com/duncs/clusterssh.git
synced 2025-07-03 18:03:23 +00:00
Revert "Add in some more backend functions"
This reverts commit 66e7fce6fa.
This commit is contained in:
Duncan Ferguson
parent
47a2a58f47
commit
90dbc37d83
6 changed files with 0 additions and 504 deletions
|
|
@ -1,71 +0,0 @@
|
||||||
package App::ClusterSSH::Gui;
|
|
||||||
|
|
||||||
use strict;
|
|
||||||
use warnings;
|
|
||||||
|
|
||||||
use version;
|
|
||||||
our $VERSION = version->new(qw$Revision: 1$);
|
|
||||||
|
|
||||||
use Carp;
|
|
||||||
|
|
||||||
use base qw/ App::ClusterSSH::Base /;
|
|
||||||
use App::ClusterSSH::Gui::XDisplay;
|
|
||||||
|
|
||||||
sub new {
|
|
||||||
my ( $class, %args ) = @_;
|
|
||||||
|
|
||||||
my $self = $class->SUPER::new( %args );
|
|
||||||
|
|
||||||
$self->{window_mgr} = App::ClusterSSH::Gui::XDisplay->new();
|
|
||||||
|
|
||||||
if(! $self->{window_mgr} ) {
|
|
||||||
croak 'Failed to get X connection', $/;
|
|
||||||
}
|
|
||||||
|
|
||||||
return $self;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub xdisplay {
|
|
||||||
my ($self) = @_;
|
|
||||||
return $self->{ window_mgr };
|
|
||||||
}
|
|
||||||
|
|
||||||
1;
|
|
||||||
|
|
||||||
=pod
|
|
||||||
|
|
||||||
=head1
|
|
||||||
|
|
||||||
ClusterSSH::Gui
|
|
||||||
|
|
||||||
=head1 SYNOPSIS
|
|
||||||
|
|
||||||
use ClusterSSH::Gui
|
|
||||||
|
|
||||||
=head1 DESCRIPTION
|
|
||||||
|
|
||||||
Object for interacting with the user for both console and terminals
|
|
||||||
|
|
||||||
=head1 METHODS
|
|
||||||
|
|
||||||
=over 4
|
|
||||||
|
|
||||||
=item $host=ClusterSSH::Gui->new()
|
|
||||||
|
|
||||||
=back
|
|
||||||
|
|
||||||
=head1 AUTHOR
|
|
||||||
|
|
||||||
Duncan Ferguson (<duncan_j_ferguson (at) yahoo.co.uk>)
|
|
||||||
|
|
||||||
=head1 LICENSE AND COPYRIGHT
|
|
||||||
|
|
||||||
Copyright (c) 2010 Duncan Ferguson (<duncan_j_ferguson (at) yahoo.co.uk>).
|
|
||||||
All rights reserved
|
|
||||||
|
|
||||||
This module is free software; you can redistribute it and/or
|
|
||||||
modify it under the same terms as Perl itself. See L<perlartistic>.
|
|
||||||
|
|
||||||
This program is distributed in the hope that it will be useful,
|
|
||||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
||||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
|
||||||
|
|
@ -1,121 +0,0 @@
|
||||||
package App::ClusterSSH::Gui::Terminal;
|
|
||||||
|
|
||||||
use strict;
|
|
||||||
use warnings;
|
|
||||||
|
|
||||||
use version;
|
|
||||||
our $VERSION = version->new(qw$Revision: 1$);
|
|
||||||
|
|
||||||
use Carp;
|
|
||||||
|
|
||||||
use base qw/ App::ClusterSSH::Base /;
|
|
||||||
use App::ClusterSSH::Gui::Terminal::Command;
|
|
||||||
|
|
||||||
our %terminal_id_for;
|
|
||||||
|
|
||||||
sub new {
|
|
||||||
my ( $class, %args ) = @_;
|
|
||||||
|
|
||||||
# if ( !$args{command} ) {
|
|
||||||
# croak('"command" not provided');
|
|
||||||
# }
|
|
||||||
|
|
||||||
if ( !$args{host} || ref $args{host} ne 'App::ClusterSSH::Host' ) {
|
|
||||||
croak('"command" not provided or invalid');
|
|
||||||
}
|
|
||||||
|
|
||||||
my $self = $class->SUPER::new(%args);
|
|
||||||
|
|
||||||
$self->{pipenm} = tmpnam();
|
|
||||||
$self->debug( 4, 'Set temp name to ', $self->{pipenm} );
|
|
||||||
mkfifo( $self->{pipenm}, 0600 ) or croak( 'Cannot create pipe: ', $! );
|
|
||||||
|
|
||||||
$self->{pid} = fork();
|
|
||||||
if ( !defined( $self->{pid} ) ) {
|
|
||||||
croak( 'Could not fork: ', $! );
|
|
||||||
}
|
|
||||||
|
|
||||||
# NOTE: the pid is re-fetched from the xterm window (via helper_script)
|
|
||||||
# later as it changes and we need an accurate PID as it is widely used
|
|
||||||
|
|
||||||
if ( $self->{pid} == 0 ) {
|
|
||||||
|
|
||||||
# this is the child
|
|
||||||
# Since this is the child, we can mark any server unresolved without
|
|
||||||
# affecting the main program
|
|
||||||
$self->{command} = App::ClusterSSH::Terminal::Command->new();
|
|
||||||
$self->debug( 4, 'Running: ', $self->{command} );
|
|
||||||
exec($self->{command}, '-p','sdfsdf','options') == 0 or die( 'Exec failed: ', $! );
|
|
||||||
}
|
|
||||||
|
|
||||||
if ( !$terminal_id_for{ $args{host}->{hostname} } ) {
|
|
||||||
$terminal_id_for{ $args{host}->{hostname} } = $self;
|
|
||||||
$self->{id} = $terminal_id_for{ $args{host}->{hostname} };
|
|
||||||
}
|
|
||||||
else {
|
|
||||||
my $count = 0;
|
|
||||||
until ( !$terminal_id_for{ $args{host}->{hostname} . ' ' . $count } )
|
|
||||||
{
|
|
||||||
$count++;
|
|
||||||
}
|
|
||||||
$terminal_id_for{ $args{host}->{hostname} . ' ' . $count } = $self;
|
|
||||||
$self->{id}
|
|
||||||
= $terminal_id_for{ $args{host}->{hostname} . ' ' . $count };
|
|
||||||
}
|
|
||||||
return $self;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub get_id {
|
|
||||||
my ($self) = @_;
|
|
||||||
return $self->{id};
|
|
||||||
}
|
|
||||||
|
|
||||||
sub get_pid {
|
|
||||||
my ($self) = @_;
|
|
||||||
return $self->{pid};
|
|
||||||
}
|
|
||||||
|
|
||||||
sub command {
|
|
||||||
my ($self) = @_;
|
|
||||||
return $self->{command};
|
|
||||||
}
|
|
||||||
|
|
||||||
1;
|
|
||||||
|
|
||||||
=pod
|
|
||||||
|
|
||||||
=head1
|
|
||||||
|
|
||||||
ClusterSSH::Gui::Terminal
|
|
||||||
|
|
||||||
=head1 SYNOPSIS
|
|
||||||
|
|
||||||
use ClusterSSH::Gui::Terminal;
|
|
||||||
|
|
||||||
=head1 DESCRIPTION
|
|
||||||
|
|
||||||
Object for creating and maintaining terminal session to server
|
|
||||||
|
|
||||||
=head1 METHODS
|
|
||||||
|
|
||||||
=over 4
|
|
||||||
|
|
||||||
=item $host=ClusterSSH::Gui->new()
|
|
||||||
|
|
||||||
=back
|
|
||||||
|
|
||||||
=head1 AUTHOR
|
|
||||||
|
|
||||||
Duncan Ferguson (<duncan_j_ferguson (at) yahoo.co.uk>)
|
|
||||||
|
|
||||||
=head1 LICENSE AND COPYRIGHT
|
|
||||||
|
|
||||||
Copyright (c) 2010 Duncan Ferguson (<duncan_j_ferguson (at) yahoo.co.uk>).
|
|
||||||
All rights reserved
|
|
||||||
|
|
||||||
This module is free software; you can redistribute it and/or
|
|
||||||
modify it under the same terms as Perl itself. See L<perlartistic>.
|
|
||||||
|
|
||||||
This program is distributed in the hope that it will be useful,
|
|
||||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
||||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
|
||||||
|
|
@ -1,122 +0,0 @@
|
||||||
package App::ClusterSSH::Gui::Terminal::Command;
|
|
||||||
|
|
||||||
use strict;
|
|
||||||
use warnings;
|
|
||||||
|
|
||||||
use version;
|
|
||||||
our $VERSION = version->new(qw$Revision: 1$);
|
|
||||||
|
|
||||||
use Carp;
|
|
||||||
|
|
||||||
use base qw/ App::ClusterSSH::Base /;
|
|
||||||
|
|
||||||
sub new {
|
|
||||||
my ( $class, %args ) = @_;
|
|
||||||
|
|
||||||
my $self = $class->SUPER::new(%args);
|
|
||||||
|
|
||||||
return $self;
|
|
||||||
}
|
|
||||||
|
|
||||||
use overload (
|
|
||||||
q{""} => sub {
|
|
||||||
my ($self) = @_;
|
|
||||||
return $self->{script};
|
|
||||||
},
|
|
||||||
fallback => 1,
|
|
||||||
);
|
|
||||||
|
|
||||||
sub script() {
|
|
||||||
my ($self) = @_;
|
|
||||||
|
|
||||||
# -p => pipe name
|
|
||||||
# -s => server name
|
|
||||||
# -u => username
|
|
||||||
# -p => port
|
|
||||||
# -c => command to run
|
|
||||||
# -b => session binary (ssh, telnet, rsh, etc)
|
|
||||||
# -a => session arguments
|
|
||||||
my $script = <<'!EOF!';
|
|
||||||
use strict;
|
|
||||||
use Getopt::Std;
|
|
||||||
my %o;
|
|
||||||
getopts( "p:s:u:p:c:d:b:a:", \%o );
|
|
||||||
|
|
||||||
if($o{p}) {
|
|
||||||
open( my $pipe, ">", $o{p} ) or die( "Failed to open pipe: ", $!, $/ );
|
|
||||||
print {$pipe} $$, ":", $ENV{WINDOWID}
|
|
||||||
or die( "Failed to write to pipe: ", $!, $/ );
|
|
||||||
close($pipe) or die( "Failed to close pipe: ", $!, $/ );
|
|
||||||
}
|
|
||||||
|
|
||||||
my $command = join( " ", $o{b}, $o{a}, );
|
|
||||||
|
|
||||||
if ( $o{u} ) {
|
|
||||||
if ( $o{b} !~ /telnet$/ ) {
|
|
||||||
$command .= join( " ", "-l", $o{u} );
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
if ( $o{b} =~ /telnet$/ ) {
|
|
||||||
$command .= join( " ", $o{s}, $o{p} );
|
|
||||||
}
|
|
||||||
else {
|
|
||||||
if ( $o{p} ) {
|
|
||||||
$command .= join( " ", "-p", $o{p} );
|
|
||||||
}
|
|
||||||
$command .= $o{s};
|
|
||||||
}
|
|
||||||
|
|
||||||
$command .= $o{c};
|
|
||||||
|
|
||||||
if ( $o{d} ) {
|
|
||||||
warn( "Running: ", $command, $/ );
|
|
||||||
}
|
|
||||||
exec($command);
|
|
||||||
!EOF!
|
|
||||||
eval $script;
|
|
||||||
if ($@) {
|
|
||||||
croak( 'Error in compiling helper script: ', $@ );
|
|
||||||
}
|
|
||||||
return $script;
|
|
||||||
}
|
|
||||||
|
|
||||||
1;
|
|
||||||
|
|
||||||
=pod
|
|
||||||
|
|
||||||
=head1
|
|
||||||
|
|
||||||
ClusterSSH::Gui::Terminal
|
|
||||||
|
|
||||||
=head1 SYNOPSIS
|
|
||||||
|
|
||||||
use ClusterSSH::Gui::Terminal;
|
|
||||||
|
|
||||||
=head1 DESCRIPTION
|
|
||||||
|
|
||||||
Object for creating and maintaining terminal session to server
|
|
||||||
|
|
||||||
=head1 METHODS
|
|
||||||
|
|
||||||
=over 4
|
|
||||||
|
|
||||||
=item $host=ClusterSSH::Gui->new()
|
|
||||||
|
|
||||||
=back
|
|
||||||
|
|
||||||
=head1 AUTHOR
|
|
||||||
|
|
||||||
Duncan Ferguson (<duncan_j_ferguson (at) yahoo.co.uk>)
|
|
||||||
|
|
||||||
=head1 LICENSE AND COPYRIGHT
|
|
||||||
|
|
||||||
Copyright (c) 2010 Duncan Ferguson (<duncan_j_ferguson (at) yahoo.co.uk>).
|
|
||||||
All rights reserved
|
|
||||||
|
|
||||||
This module is free software; you can redistribute it and/or
|
|
||||||
modify it under the same terms as Perl itself. See L<perlartistic>.
|
|
||||||
|
|
||||||
This program is distributed in the hope that it will be useful,
|
|
||||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
||||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
|
||||||
|
|
@ -1,102 +0,0 @@
|
||||||
package App::ClusterSSH::Gui::XDisplay;
|
|
||||||
|
|
||||||
use strict;
|
|
||||||
use warnings;
|
|
||||||
|
|
||||||
use version;
|
|
||||||
our $VERSION = version->new(qw$Revision: 1$);
|
|
||||||
|
|
||||||
use Carp;
|
|
||||||
use X11::Protocol;
|
|
||||||
|
|
||||||
use base qw/ X11::Protocol App::ClusterSSH::Base /;
|
|
||||||
|
|
||||||
sub new {
|
|
||||||
my ( $class, %args ) = @_;
|
|
||||||
|
|
||||||
my $self = $class->SUPER::new(%args);
|
|
||||||
|
|
||||||
$self->{x11} = X11::Protocol->new();
|
|
||||||
|
|
||||||
if ( !$self->{x11} ) {
|
|
||||||
croak 'Failed to get X connection', $/;
|
|
||||||
}
|
|
||||||
|
|
||||||
return $self;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub xdisplay {
|
|
||||||
my ($self) = @_;
|
|
||||||
return $self->{x11};
|
|
||||||
}
|
|
||||||
|
|
||||||
sub get_font_size() {
|
|
||||||
my ($self, $terminal_font) = @_;
|
|
||||||
$self->debug( 2, "Fetching font size" );
|
|
||||||
|
|
||||||
# get atom name<->number relations
|
|
||||||
my $quad_width = $self->xdisplay->atom("QUAD_WIDTH");
|
|
||||||
my $pixel_size = $self->xdisplay->atom("PIXEL_SIZE");
|
|
||||||
|
|
||||||
my $font = $self->xdisplay->new_rsrc;
|
|
||||||
$self->xdisplay->OpenFont( $font, $terminal_font );
|
|
||||||
|
|
||||||
my %font_info;
|
|
||||||
|
|
||||||
eval { (%font_info) = $self->xdisplay->QueryFont($font); }
|
|
||||||
|| die( "Fatal: Unrecognised font used ($terminal_font).\n"
|
|
||||||
. "Please amend \$HOME/.csshrc with a valid font (see man page).\n"
|
|
||||||
);
|
|
||||||
|
|
||||||
my $internal_font_width = $font_info{properties}{$quad_width};
|
|
||||||
my $internal_font_height = $font_info{properties}{$pixel_size};
|
|
||||||
|
|
||||||
if ( !$internal_font_width || !$internal_font_height ) {
|
|
||||||
die( "Fatal: Unrecognised font used ($terminal_font).\n"
|
|
||||||
. "Please amend \$HOME/.csshrc with a valid font (see man page).\n"
|
|
||||||
);
|
|
||||||
}
|
|
||||||
|
|
||||||
$self->debug( 2, "Done with font size" );
|
|
||||||
return ( internal_font_width => $internal_font_width , internal_font_height=>$internal_font_height);
|
|
||||||
}
|
|
||||||
|
|
||||||
1;
|
|
||||||
|
|
||||||
=pod
|
|
||||||
|
|
||||||
=head1
|
|
||||||
|
|
||||||
ClusterSSH::Gui
|
|
||||||
|
|
||||||
=head1 SYNOPSIS
|
|
||||||
|
|
||||||
use ClusterSSH::Gui
|
|
||||||
|
|
||||||
=head1 DESCRIPTION
|
|
||||||
|
|
||||||
Object for interacting with the user for both console and terminals
|
|
||||||
|
|
||||||
=head1 METHODS
|
|
||||||
|
|
||||||
=over 4
|
|
||||||
|
|
||||||
=item $host=ClusterSSH::Gui->new()
|
|
||||||
|
|
||||||
=back
|
|
||||||
|
|
||||||
=head1 AUTHOR
|
|
||||||
|
|
||||||
Duncan Ferguson (<duncan_j_ferguson (at) yahoo.co.uk>)
|
|
||||||
|
|
||||||
=head1 LICENSE AND COPYRIGHT
|
|
||||||
|
|
||||||
Copyright (c) 2010 Duncan Ferguson (<duncan_j_ferguson (at) yahoo.co.uk>).
|
|
||||||
All rights reserved
|
|
||||||
|
|
||||||
This module is free software; you can redistribute it and/or
|
|
||||||
modify it under the same terms as Perl itself. See L<perlartistic>.
|
|
||||||
|
|
||||||
This program is distributed in the hope that it will be useful,
|
|
||||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
||||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
|
||||||
20
t/20gui.t
20
t/20gui.t
|
|
@ -1,20 +0,0 @@
|
||||||
use strict;
|
|
||||||
use warnings;
|
|
||||||
|
|
||||||
use FindBin qw($Bin);
|
|
||||||
use lib "$Bin/../lib";
|
|
||||||
|
|
||||||
use Test::More;
|
|
||||||
use Test::Trap;
|
|
||||||
|
|
||||||
BEGIN { use_ok( 'App::ClusterSSH::Gui' ) }
|
|
||||||
|
|
||||||
# force default language for tests
|
|
||||||
App::ClusterSSH::Gui->set_lang('en');
|
|
||||||
|
|
||||||
my $gui;
|
|
||||||
|
|
||||||
$gui = App::ClusterSSH::Gui->new();
|
|
||||||
isa_ok( $gui, 'App::ClusterSSH::Gui' );
|
|
||||||
|
|
||||||
done_testing();
|
|
||||||
|
|
@ -1,68 +0,0 @@
|
||||||
use strict;
|
|
||||||
use warnings;
|
|
||||||
|
|
||||||
use FindBin qw($Bin);
|
|
||||||
use lib "$Bin/../lib";
|
|
||||||
|
|
||||||
use Test::More;
|
|
||||||
use Test::Trap;
|
|
||||||
use Sys::Hostname;
|
|
||||||
|
|
||||||
BEGIN { use_ok('App::ClusterSSH::Gui::Terminal::Command') }
|
|
||||||
|
|
||||||
# force default language for tests
|
|
||||||
App::ClusterSSH::Gui::Terminal::Command->set_lang('en');
|
|
||||||
|
|
||||||
my $obj;
|
|
||||||
|
|
||||||
trap {
|
|
||||||
$obj = App::ClusterSSH::Gui::Terminal::Command->new();
|
|
||||||
};
|
|
||||||
is( $trap->leaveby, 'die', 'returned ok' );
|
|
||||||
like( $trap->die, qr/command is undefined at /, 'Got appropriate croak message' );
|
|
||||||
is( $trap->stderr, '', 'Expecting no STDERR' );
|
|
||||||
is( $trap->stdout, '', 'Expecting no STDOUT' );
|
|
||||||
|
|
||||||
trap {
|
|
||||||
$obj = App::ClusterSSH::Gui::Terminal::Command->new( command => 'true' );
|
|
||||||
};
|
|
||||||
is( $trap->leaveby, 'return', 'returned ok' );
|
|
||||||
is( $trap->die, undef, 'returned ok' );
|
|
||||||
is( $trap->stdout, '', 'Expecting no STDOUT' );
|
|
||||||
is( $trap->stdout, '', 'Expected no STDERR' );
|
|
||||||
isa_ok( $obj, 'App::ClusterSSH::Gui::Terminal::Command' );
|
|
||||||
|
|
||||||
my $script;
|
|
||||||
trap {
|
|
||||||
$script = $obj->script();
|
|
||||||
};
|
|
||||||
is( $trap->leaveby, 'return', 'returned ok' );
|
|
||||||
is( $trap->die, undef, 'returned ok' );
|
|
||||||
is( $trap->stdout, '', 'Expecting no STDOUT' );
|
|
||||||
is( $trap->stdout, '', 'Expected no STDERR' );
|
|
||||||
isa_ok( $obj, 'App::ClusterSSH::Gui::Terminal::Command' );
|
|
||||||
|
|
||||||
my $output;
|
|
||||||
trap {
|
|
||||||
$output = qx/$^X -e '$script' -- -c hostname/;
|
|
||||||
};
|
|
||||||
is( $trap->leaveby, 'return', 'returned ok' );
|
|
||||||
is( $trap->die, undef, 'returned ok' );
|
|
||||||
is( $trap->stdout, '', 'Expecting no STDOUT' );
|
|
||||||
is( $trap->stdout, '', 'Expected no STDERR' );
|
|
||||||
isa_ok( $obj, 'App::ClusterSSH::Gui::Terminal::Command' );
|
|
||||||
chomp($output);
|
|
||||||
is( $output, hostname(), 'Hostname output as expected');
|
|
||||||
|
|
||||||
trap {
|
|
||||||
$output = qx/$^X -e '$script' -- -d 3 -c hostname 2>&1/;
|
|
||||||
};
|
|
||||||
is( $trap->leaveby, 'return', 'returned ok' );
|
|
||||||
is( $trap->die, undef, 'returned ok' );
|
|
||||||
is( $trap->stdout, '', 'Expecting no STDOUT' );
|
|
||||||
is( $trap->stderr, '', 'Expected no STDERR' );
|
|
||||||
isa_ok( $obj, 'App::ClusterSSH::Gui::Terminal::Command' );
|
|
||||||
chomp($output);
|
|
||||||
is( $output, 'Running: hostname'.$/.hostname(), 'Hostname output as expected');
|
|
||||||
|
|
||||||
done_testing();
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue