mirror of
https://github.com/duncs/clusterssh.git
synced 2025-04-20 16:59:06 +00:00
Start of migration from Tk to Gtk2
This commit is contained in:
Duncan Ferguson
parent
6aca350f8b
commit
7dc9f72e8d
4 changed files with 302 additions and 1 deletions
2
Build.PL
2
Build.PL
|
|
@ -20,7 +20,7 @@ my $build = Module::Build->new(
|
|||
dist_version_from => 'lib/App/ClusterSSH.pm',
|
||||
requires => {
|
||||
'version' => '0',
|
||||
'Tk' => '800.022',
|
||||
'Gtk2' => '1.244',
|
||||
'X11::Protocol' => '0.56',
|
||||
'Locale::Maketext' => 0,
|
||||
'Exception::Class' => '1.31',
|
||||
|
|
|
|||
|
|
@ -12,6 +12,7 @@ use App::ClusterSSH::Host;
|
|||
use App::ClusterSSH::Config;
|
||||
use App::ClusterSSH::Helper;
|
||||
use App::ClusterSSH::Cluster;
|
||||
use App::ClusterSSH::Windows;
|
||||
|
||||
use FindBin qw($Script);
|
||||
|
||||
|
|
@ -58,6 +59,7 @@ sub new {
|
|||
$self->{config} = App::ClusterSSH::Config->new();
|
||||
$self->{helper} = App::ClusterSSH::Helper->new();
|
||||
$self->{cluster} = App::ClusterSSH::Cluster->new();
|
||||
$self->{windows} = App::ClusterSSH::Windows->new();
|
||||
|
||||
# catch and reap any zombies
|
||||
$SIG{CHLD} = \&REAPER;
|
||||
|
|
@ -80,6 +82,11 @@ sub helper {
|
|||
return $self->{helper};
|
||||
}
|
||||
|
||||
sub windows {
|
||||
my ($self) = @_;
|
||||
return $self->{windows};
|
||||
}
|
||||
|
||||
sub REAPER {
|
||||
my $kid;
|
||||
do {
|
||||
|
|
@ -1943,6 +1950,9 @@ sub run {
|
|||
}
|
||||
}
|
||||
|
||||
$self->windows->console->show;
|
||||
$self->windows->enter_loop;
|
||||
die "DUNCS HERE";;
|
||||
$self->create_windows();
|
||||
$self->create_menubar();
|
||||
|
||||
|
|
|
|||
96
lib/App/ClusterSSH/Windows.pm
Normal file
96
lib/App/ClusterSSH/Windows.pm
Normal file
|
|
@ -0,0 +1,96 @@
|
|||
package App::ClusterSSH::Windows;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use version;
|
||||
our $VERSION = version->new('0.01');
|
||||
|
||||
use Carp;
|
||||
use Gtk2 -init;
|
||||
|
||||
use base qw/ App::ClusterSSH::Base /;
|
||||
|
||||
use App::ClusterSSH::Windows::Console;
|
||||
|
||||
our %windows;
|
||||
|
||||
sub new {
|
||||
my ( $class, %args ) = @_;
|
||||
|
||||
# if ( !$args{hostname} ) {
|
||||
# croak(
|
||||
# App::ClusterSSH::Exception->throw(
|
||||
# error => $class->loc('hostname is undefined')
|
||||
# )
|
||||
# );
|
||||
# }
|
||||
|
||||
# # remove any keys undef values - must be a better way...
|
||||
# foreach my $remove (qw/ port username /) {
|
||||
# if ( !$args{$remove} && grep {/^$remove$/} keys(%args) ) {
|
||||
# delete( $args{$remove} );
|
||||
# }
|
||||
# }
|
||||
|
||||
my $self = $class->SUPER::new(%args);
|
||||
|
||||
$self->{console} = App::ClusterSSH::Windows::Console->new();
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub console {
|
||||
my ($self) = @_;
|
||||
return $self->{console};
|
||||
}
|
||||
|
||||
sub enter_loop {
|
||||
my ($self) = @_;
|
||||
|
||||
Gtk2->main;
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
ClusterSSH::Windows - Object representing a terminal window.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use ClusterSSH::Windows;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Object representing a terminal window.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over 4
|
||||
|
||||
=item $window=ClusterSSH::Windows->new ({ something => 'something' })
|
||||
|
||||
=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;
|
||||
195
lib/App/ClusterSSH/Windows/Console.pm
Normal file
195
lib/App/ClusterSSH/Windows/Console.pm
Normal file
|
|
@ -0,0 +1,195 @@
|
|||
package App::ClusterSSH::Windows::Console;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use version;
|
||||
our $VERSION = version->new('0.01');
|
||||
|
||||
use Carp;
|
||||
use Gtk2 -init;
|
||||
|
||||
use base qw/ App::ClusterSSH::Base /;
|
||||
|
||||
sub new {
|
||||
my ( $class, %args ) = @_;
|
||||
|
||||
my $self = $class->SUPER::new(%args);
|
||||
|
||||
# if ( !$args{hostname} ) {
|
||||
# croak(
|
||||
# App::ClusterSSH::Exception->throw(
|
||||
# error => $class->loc('hostname is undefined')
|
||||
# )
|
||||
# );
|
||||
# }
|
||||
|
||||
# # remove any keys undef values - must be a better way...
|
||||
# foreach my $remove (qw/ port username /) {
|
||||
# if ( !$args{$remove} && grep {/^$remove$/} keys(%args) ) {
|
||||
# delete( $args{$remove} );
|
||||
# }
|
||||
# }
|
||||
|
||||
$self->{console} = Gtk2::Window->new('toplevel');
|
||||
$self->{console}->set_title('ClusterSSH');
|
||||
$self->{console}->set_wmclass( 'cssh', 'cssh' );
|
||||
$self->{console}->set_resizable(0);
|
||||
$self->{console}->signal_connect( destroy => sub { Gtk2->main_quit; } );
|
||||
|
||||
my $vbox = Gtk2::VBox->new( 0, 5 );
|
||||
$vbox->set_size_request( 300, 100 );
|
||||
|
||||
my $menubar = Gtk2::MenuBar->new;
|
||||
$menubar->append( $self->_file_menu );
|
||||
$menubar->append( $self->_host_menu );
|
||||
$menubar->append( $self->_send_menu );
|
||||
$menubar->append( $self->_help_menu );
|
||||
|
||||
$vbox->pack_start( $menubar, 0, 0, 0 );
|
||||
|
||||
$vbox->show_all;
|
||||
|
||||
$self->{console}->add($vbox);
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub _file_menu {
|
||||
my ($self) = @_;
|
||||
|
||||
my $items = Gtk2::Menu->new();
|
||||
|
||||
my $item_show_history = Gtk2::MenuItem->new('_Show History');
|
||||
$item_show_history->signal_connect(
|
||||
'activate' => sub { warn "NOT SET UP YET" } );
|
||||
$items->append($item_show_history);
|
||||
|
||||
my $item_exit = Gtk2::MenuItem->new('_Exit');
|
||||
$item_exit->signal_connect( 'activate' => sub { Gtk2->main_quit; } );
|
||||
|
||||
$items->append($item_exit);
|
||||
|
||||
my $menu = Gtk2::MenuItem->new('_File');
|
||||
$menu->set_submenu($items);
|
||||
|
||||
return $menu;
|
||||
}
|
||||
|
||||
sub _host_menu {
|
||||
my ($self) = @_;
|
||||
|
||||
my $items = Gtk2::Menu->new();
|
||||
$items->append( Gtk2::TearoffMenuItem->new );
|
||||
|
||||
my $item_retile = Gtk2::MenuItem->new('_Retile Windows');
|
||||
$item_retile->signal_connect( 'activate' => sub { warn "NOT SET UP YET" }
|
||||
);
|
||||
$items->append($item_retile);
|
||||
|
||||
my $item_toggle = Gtk2::MenuItem->new('_Toggle Active Windows');
|
||||
$item_toggle->signal_connect( 'activate' => sub { warn "NOT SET UP YET" }
|
||||
);
|
||||
$items->append($item_toggle);
|
||||
|
||||
my $item_close_inactive = Gtk2::MenuItem->new('_Close Inactive Windows');
|
||||
$item_close_inactive->signal_connect(
|
||||
'activate' => sub { warn "NOT SET UP YET" } );
|
||||
$items->append($item_close_inactive);
|
||||
|
||||
my $item_add = Gtk2::MenuItem->new('_Add Host or Cluster');
|
||||
$item_add->signal_connect( 'activate' => sub { warn "NOT SET UP YET" } );
|
||||
$items->append($item_add);
|
||||
|
||||
$items->append( Gtk2::SeparatorMenuItem->new() );
|
||||
|
||||
my $menu = Gtk2::MenuItem->new('_Host');
|
||||
$menu->set_submenu($items);
|
||||
|
||||
return $menu;
|
||||
}
|
||||
|
||||
sub _send_menu {
|
||||
my ($self) = @_;
|
||||
|
||||
my $items = Gtk2::Menu->new();
|
||||
$items->append( Gtk2::TearoffMenuItem->new );
|
||||
|
||||
my $menu = Gtk2::MenuItem->new('_Send');
|
||||
$menu->set_submenu($items);
|
||||
|
||||
return $menu;
|
||||
}
|
||||
|
||||
sub _help_menu {
|
||||
my ($self) = @_;
|
||||
|
||||
my $items = Gtk2::Menu->new();
|
||||
|
||||
my $item_about = Gtk2::MenuItem->new('_About');
|
||||
$item_about->signal_connect( 'activate' => sub { warn "NOT SET UP YET" }
|
||||
);
|
||||
$items->append($item_about);
|
||||
|
||||
my $item_docs = Gtk2::MenuItem->new('_Documentation');
|
||||
$item_docs->signal_connect( 'activate' => sub { warn "NOT SET UP YET" } );
|
||||
$items->append($item_docs);
|
||||
|
||||
my $menu = Gtk2::MenuItem->new('_Help');
|
||||
$menu->set_right_justified(1);
|
||||
$menu->set_submenu($items);
|
||||
|
||||
return $menu;
|
||||
}
|
||||
|
||||
sub show {
|
||||
my ($self) = @_;
|
||||
return $self->{console}->show;
|
||||
}
|
||||
|
||||
sub withdraw {
|
||||
my ($self) = @_;
|
||||
return $self->{console}->withdraw;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
ClusterSSH::Console - Object representing a terminal window.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use ClusterSSH::Console;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Object representing a terminal window.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over 4
|
||||
|
||||
=item $window=ClusterSSH::Console->new ({ something => 'something' })
|
||||
|
||||
=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;
|
||||
Loading…
Add table
Reference in a new issue