mirror of
https://github.com/paparazzi/paparazzi.git
synced 2026-06-05 15:30:08 +08:00
[supervision] remove obsolete perl gui
This commit is contained in:
Felix Ruess
@@ -1,358 +0,0 @@
|
|||||||
package Paparazzi::CpGui;
|
|
||||||
|
|
||||||
use Subject;
|
|
||||||
use Paparazzi::CpSessionMgr;
|
|
||||||
@ISA = qw(Paparazzi::CpSessionMgr);
|
|
||||||
|
|
||||||
use strict;
|
|
||||||
|
|
||||||
use Tk;
|
|
||||||
use Tk::MainWindow;
|
|
||||||
use Tk::NoteBook;
|
|
||||||
use Tk::HList;
|
|
||||||
use Tk::ItemStyle;
|
|
||||||
use Data::Dumper;
|
|
||||||
|
|
||||||
sub populate {
|
|
||||||
my ($self, $args) = @_;
|
|
||||||
$self->SUPER::populate($args);
|
|
||||||
$self->configspec(-logo_file => [S_NOINIT, S_PASSIVE, S_RDWR, S_OVRWRT, S_NOPRPG, undef],
|
|
||||||
-variables => [S_SUPER, S_SUPER, S_SUPER, S_SUPER, S_SUPER, {}],
|
|
||||||
);
|
|
||||||
}
|
|
||||||
sub completeinit {
|
|
||||||
my ($self) = @_;
|
|
||||||
$self->SUPER::completeinit();
|
|
||||||
$self->build_gui();
|
|
||||||
}
|
|
||||||
|
|
||||||
sub onProgramSelected {
|
|
||||||
my ($self, $pgm_name) = @_;
|
|
||||||
$self->toggle_program($pgm_name);
|
|
||||||
}
|
|
||||||
|
|
||||||
sub onSessionSelected {
|
|
||||||
my ($self, $session_name) = @_;
|
|
||||||
$self->{'session_command_'.$session_name}->configure(-state => 'disabled');
|
|
||||||
$self->start_session($session_name);
|
|
||||||
$self->add_session_page($session_name);
|
|
||||||
}
|
|
||||||
|
|
||||||
sub onCloseSession {
|
|
||||||
my ($self, $session_name) = @_;
|
|
||||||
print "on close session\n";
|
|
||||||
$self->kill_session($session_name);
|
|
||||||
$self->{'session_command_'.$session_name}->configure(-state => 'active');
|
|
||||||
$self->remove_session_page($session_name);
|
|
||||||
}
|
|
||||||
|
|
||||||
use constant LIST_WIDTH => 80;
|
|
||||||
use constant LIST_HEIGHT => 20;
|
|
||||||
|
|
||||||
|
|
||||||
sub onCompile {
|
|
||||||
my ($self) = @_;
|
|
||||||
my $paparazzi_src = Paparazzi::Environment::paparazzi_src();
|
|
||||||
print `cd $paparazzi_src; make`;
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
sub build_gui {
|
|
||||||
my ($self) = @_;
|
|
||||||
my $mw = MainWindow->new();
|
|
||||||
$self->{mw} = $mw;
|
|
||||||
$mw->title ($self->{cp_name});
|
|
||||||
# menu bar
|
|
||||||
my $menubar =
|
|
||||||
$mw->Frame( -relief => 'ridge')->pack(-side => 'top', -fill => 'x');
|
|
||||||
my $session_menu = $menubar->Menubutton(-text => 'Sessions')->pack(-side => 'left');;
|
|
||||||
my $sessions = $self->get('-sessions');
|
|
||||||
foreach my $session_name (sort keys %{$sessions}) {
|
|
||||||
$self->{'session_command_'.$session_name} =
|
|
||||||
$session_menu->command( -label => $session_name,
|
|
||||||
-command => [\&onSessionSelected, $self, $session_name] );
|
|
||||||
}
|
|
||||||
my $program_menu = $menubar->Menubutton(-text => 'Programs')->pack(-side => 'left');;
|
|
||||||
my $programs = $self->get(-programs);
|
|
||||||
foreach my $pgm_name (keys %{$programs}) {
|
|
||||||
$program_menu->command( -label => $pgm_name,
|
|
||||||
-command => [\&onProgramSelected, $self, $pgm_name]
|
|
||||||
);
|
|
||||||
}
|
|
||||||
# session frame
|
|
||||||
my $session_frame = $mw->Frame( -relief => 'groove')->pack(-side => 'bottom', -fill => 'both', -expand => "yes",);
|
|
||||||
my $notebook = $session_frame->NoteBook( -ipadx => 6, -ipady => 6);
|
|
||||||
$self->{notebook} = $notebook;
|
|
||||||
$notebook->pack(-expand => "yes",
|
|
||||||
-fill => "both",
|
|
||||||
-padx => 5, -pady => 5,
|
|
||||||
-side => "top");
|
|
||||||
$self->build_logo_page($notebook);
|
|
||||||
# $self->build_compile_page($notebook);
|
|
||||||
# $self->build_list_page($notebook, "hosts", "Hosts", ["name", "ip", "status"], \&build_hosts_page);
|
|
||||||
# $self->build_list_page($notebook, "variables", "Variables", ["name", "value"], \&build_variables_page);
|
|
||||||
# $self->build_list_page($notebook, "programs", "Programs", ["name", "command", "args"], \&build_programs_page);
|
|
||||||
# $self->build_programs_page($notebook);
|
|
||||||
# $self->build_list_page($notebook, "sessions", "Sessions", ["name", "command", "args"], \&build_sessions_page);
|
|
||||||
# $self->build_programs_page($notebook);
|
|
||||||
# my $programs_page = $notebook->add("programs", -label => "Programs", -underline => 0);
|
|
||||||
# my $sessions_page = $notebook->add("sessions", -label => "Sessions", -underline => 0);
|
|
||||||
|
|
||||||
$self->{session_frame} = $session_frame;
|
|
||||||
|
|
||||||
check_paparazzi_home($mw);
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
sub check_paparazzi_home {
|
|
||||||
my ($mw) = @_;
|
|
||||||
if (Paparazzi::Environment::paparazzi_home() eq "/usr/share/paparazzi") {
|
|
||||||
my $button = $mw->messageBox(
|
|
||||||
-title => 'Welcome to Paparazzi',
|
|
||||||
-type => 'YesNo',
|
|
||||||
-message => "Paparazzi needs access to a writable directory to store your data and settings. Do you want Paparazzi to use a temporary system directory ?");
|
|
||||||
|
|
||||||
my $pph = "";
|
|
||||||
|
|
||||||
if ($button eq "Yes") {
|
|
||||||
$pph = `mktemp -d /tmp/paparazzi.XXXXXXXX`;
|
|
||||||
print "using dir $pph as paparazzi_home\n"
|
|
||||||
}
|
|
||||||
else {
|
|
||||||
$pph = $mw->chooseDirectory(-title => 'choose a directory',
|
|
||||||
-initialdir => '~/paparazzi'
|
|
||||||
);
|
|
||||||
# print "choosed $file_name\n";
|
|
||||||
if ($pph eq "") {
|
|
||||||
die("need a writable dir. Exiting");
|
|
||||||
}
|
|
||||||
}
|
|
||||||
my $pps = "/usr/share/paparazzi";
|
|
||||||
`cd $pps && make -f conf/Makefile.install DESTDIR=$pph install_skel\n`;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
sub build_logo_page {
|
|
||||||
my ($self, $notebook) = @_;
|
|
||||||
my $logo_filename = $self->get('-logo_file');
|
|
||||||
return unless defined $logo_filename;
|
|
||||||
my $logo_page = $notebook->add("logo", -label => "Logo", -underline => 0);
|
|
||||||
my $image = $logo_page->Photo('logogif', -format => 'GIF',
|
|
||||||
-file => $logo_filename);
|
|
||||||
my $labelImage = $logo_page->Label('-image' => 'logogif')->pack();
|
|
||||||
return $logo_page;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub build_compile_page {
|
|
||||||
my ($self, $notebook) = @_;
|
|
||||||
my $compile_page = $notebook->add("compile", -label => "Compile", -underline => 0);
|
|
||||||
my $paparazzi_src = Paparazzi::Environment::paparazzi_src();
|
|
||||||
my(@pl) = qw/-side top -expand yes -padx 10 -pady 10 -fill both/;
|
|
||||||
my $ground_frame = $compile_page->Frame(-label => 'Ground', -borderwidth => 2, - relief =>'groove')->pack(@pl);
|
|
||||||
# my $airborne_frame = $compile_page->Frame(-label => "Air", -borderwidth => 2, - relief =>'groove')->pack(@pl);
|
|
||||||
# my $ground_frame = $compile_page->Frame(-borderwidth => 2, - relief =>'groove')->pack(@pl);
|
|
||||||
my $airborne_frame = $compile_page->Frame(-borderwidth => 2, - relief =>'groove')->pack(@pl);
|
|
||||||
@pl = qw/-side top -expand yes -pady 2 -anchor w/;
|
|
||||||
my $mode_txt = 'Mode : '. (defined $paparazzi_src ? "Source tree" : "System install");
|
|
||||||
my $mode_label = $ground_frame->Label(-text => $mode_txt)->pack(@pl);
|
|
||||||
my $paparazzi_src_txt = 'location : '. (defined $paparazzi_src ? $paparazzi_src : "/usr/share/paparazzi");
|
|
||||||
my $paparazzi_src_label = $ground_frame->Label(-text => $paparazzi_src_txt)->pack(@pl);
|
|
||||||
my $make_button = $ground_frame->Button(
|
|
||||||
-text => "Compile",
|
|
||||||
-width => 10,
|
|
||||||
-command => [\&onCompile, $self],
|
|
||||||
);
|
|
||||||
$make_button->pack(qw/-side top -expand yes -pady 2/);
|
|
||||||
|
|
||||||
my @header = ("name", "airframe", "radio", "flight plan");
|
|
||||||
my $hlist = $airborne_frame->Scrolled ('HList',
|
|
||||||
# -selectmode => 'extended',
|
|
||||||
-header => 1,
|
|
||||||
# -columns => $#header + 1,
|
|
||||||
-width => LIST_WIDTH,
|
|
||||||
# -height => LIST_HEIGHT,
|
|
||||||
-itemtype => 'imagetext',
|
|
||||||
-indent => 35,
|
|
||||||
-separator => '/',
|
|
||||||
)->grid(-sticky => 'nsew');
|
|
||||||
|
|
||||||
Paparazzi::Environment::read_config();
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
sub build_hosts_page {
|
|
||||||
my ($self, $hlist, $e, $section_h, $item) = @_;
|
|
||||||
$hlist->itemCreate ($e, 0,
|
|
||||||
-itemtype => 'text',
|
|
||||||
-text => $item
|
|
||||||
);
|
|
||||||
my $ip = $section_h->{$item};
|
|
||||||
$hlist->itemCreate ($e, 1,
|
|
||||||
-itemtype => 'text',
|
|
||||||
-text => $ip?$ip:"unknown"
|
|
||||||
);
|
|
||||||
$hlist->itemCreate ($e, 2,
|
|
||||||
-itemtype => 'text',
|
|
||||||
-text => "unknown"
|
|
||||||
);
|
|
||||||
}
|
|
||||||
|
|
||||||
sub build_variables_page {
|
|
||||||
my ($self, $hlist, $e, $section_h, $item) = @_;
|
|
||||||
$hlist->itemCreate ($e, 0, -itemtype => 'text',
|
|
||||||
-text => $item
|
|
||||||
);
|
|
||||||
$hlist->itemCreate ($e, 1, -itemtype => 'text',
|
|
||||||
-text => $section_h->{$item},
|
|
||||||
);
|
|
||||||
}
|
|
||||||
|
|
||||||
#sub build_programs_page {
|
|
||||||
# my ($self, $hlist, $e, $section_h, $item) = @_;
|
|
||||||
# $hlist->itemCreate ($e, 0, -itemtype => 'text',
|
|
||||||
# -text => $item
|
|
||||||
# );
|
|
||||||
# $hlist->itemCreate ($e, 1, -itemtype => 'text',
|
|
||||||
# -text => $section_h->{$item}->{command},
|
|
||||||
# );
|
|
||||||
|
|
||||||
# $hlist->itemCreate ($e, 2, -itemtype => 'text',
|
|
||||||
# -text => $section_h->{$item}->{args},
|
|
||||||
# );
|
|
||||||
#}
|
|
||||||
|
|
||||||
sub build_sessions_page {
|
|
||||||
my ($self, $hlist, $e, $section_h, $item) = @_;
|
|
||||||
$hlist->itemCreate ($e, 0, -itemtype => 'text',
|
|
||||||
-text => $item
|
|
||||||
);
|
|
||||||
$hlist->itemCreate ($e, 1, -itemtype => 'text',
|
|
||||||
-text => $section_h->{$item}->{command},
|
|
||||||
);
|
|
||||||
|
|
||||||
$hlist->itemCreate ($e, 2, -itemtype => 'text',
|
|
||||||
-text => $section_h->{$item}->{args},
|
|
||||||
);
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
sub build_programs_page {
|
|
||||||
my ($self, $notebook) = @_;
|
|
||||||
my $page = $notebook->add("programs", -label => "Programs", -underline => 0);
|
|
||||||
my @header = ("name", "command", "args");
|
|
||||||
my $hlist = $page->Scrolled ('HList',
|
|
||||||
# -selectmode => 'extended',
|
|
||||||
-header => 1,
|
|
||||||
# -columns => $#header + 1,
|
|
||||||
-width => LIST_WIDTH,
|
|
||||||
-height => LIST_HEIGHT,
|
|
||||||
-itemtype => 'imagetext',
|
|
||||||
-indent => 35,
|
|
||||||
-separator => '/',
|
|
||||||
)->grid(-sticky => 'nsew');
|
|
||||||
# for my $i (0 .. $#header) {
|
|
||||||
# $hlist->header('create', $i, -text => $header[$i]);
|
|
||||||
# }
|
|
||||||
my $section_h = $self->get('-programs');
|
|
||||||
foreach my $program (keys %{$section_h}) {
|
|
||||||
# print Dumper($section_h->{$program})."\n";
|
|
||||||
$hlist->add($program, -text => $program );
|
|
||||||
|
|
||||||
$hlist->add($program."/command", -text => "command : ".$section_h->{$program}->{command});
|
|
||||||
$hlist->add($program."/args", -text => "args :");
|
|
||||||
my $args = $section_h->{$program}->{args};
|
|
||||||
foreach my $argh (@{$args}) {
|
|
||||||
$hlist->add($program."/args/".$argh->{flag}, -text => $argh->{flag}."\t". $argh->{type}."\t". $argh->{value});
|
|
||||||
}
|
|
||||||
}
|
|
||||||
return $page
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
sub build_list_page {
|
|
||||||
my ($self, $notebook, $section, $label, $header, $row_fun) = @_;
|
|
||||||
my $page = $notebook->add($section, -label => $label, -underline => 0);
|
|
||||||
my @header = @{$header};
|
|
||||||
my $hlist = $page->Scrolled ('HList',
|
|
||||||
-header => 1,
|
|
||||||
-columns => $#header + 1,
|
|
||||||
-width => LIST_WIDTH,
|
|
||||||
-height => LIST_HEIGHT,
|
|
||||||
)->grid(-sticky => 'nsew');
|
|
||||||
for my $i (0 .. $#header) {
|
|
||||||
# print("header $header[$i]\n");
|
|
||||||
$hlist->header('create', $i, -text => $header[$i]);
|
|
||||||
}
|
|
||||||
my $section_h = $self->get('-'.$section);
|
|
||||||
# print "CpGui variables ".Dumper($section_h) if ($section eq "variables");
|
|
||||||
foreach my $item (keys %{$section_h}) {
|
|
||||||
my $e = $hlist->addchild("");
|
|
||||||
&$row_fun($self, $hlist, $e, $section_h, $item);
|
|
||||||
# print("$hlist, $e, $section_h, $item\n");
|
|
||||||
}
|
|
||||||
return $page
|
|
||||||
}
|
|
||||||
|
|
||||||
sub add_session_page {
|
|
||||||
my ($self, $session_name) = @_;
|
|
||||||
my ($mw, $notebook) = ($self->{mw}, $self->{notebook});
|
|
||||||
my $page_id = "session_".$session_name;
|
|
||||||
my $session_page = $notebook->add($page_id, -label => "$session_name",
|
|
||||||
-underline => 0);
|
|
||||||
my $sessions = $self->get('-sessions');
|
|
||||||
my $session = $sessions->{$session_name};
|
|
||||||
my $hlist = $session_page->Scrolled ('HList',
|
|
||||||
-scrollbars => 'o',
|
|
||||||
-header => 1,
|
|
||||||
-columns => 3,
|
|
||||||
-width => LIST_WIDTH,
|
|
||||||
-height => LIST_HEIGHT,
|
|
||||||
-command => [\&on_session_pgm_clicked, $self, $session_name],
|
|
||||||
)->grid(-columnspan => 2);
|
|
||||||
$hlist->header('create', 0, -text => 'name');
|
|
||||||
$hlist->header('create', 1, -text => 'status');
|
|
||||||
$hlist->header('create', 2, -text => 'args');
|
|
||||||
foreach my $i (0..@{$session->{pgms}}-1) {
|
|
||||||
my $pgm = $session->{pgms}->[$i];
|
|
||||||
my $pgm_name = $pgm->{name};
|
|
||||||
print "i $i name : $pgm_name\n";
|
|
||||||
$hlist->add($i);
|
|
||||||
$hlist->itemCreate($i, 0, -text => $pgm_name );
|
|
||||||
$hlist->itemCreate($i, 1, -text => 'on' );
|
|
||||||
$hlist->itemCreate($i, 2, -text => 'blah' );
|
|
||||||
}
|
|
||||||
$self->{$session_name.'hlist'} = $hlist;
|
|
||||||
# $session_page->Button( -text => "killall")->grid(-column => 0, -row => 1);
|
|
||||||
$session_page->Button( -text => "close",
|
|
||||||
-command => [\&onCloseSession, $self, $session_name])->grid(-column => 1, -row => 1);
|
|
||||||
$notebook->raise($page_id);
|
|
||||||
}
|
|
||||||
|
|
||||||
sub remove_session_page {
|
|
||||||
my ($self, $session_name) = @_;
|
|
||||||
my $notebook = $self->{notebook};
|
|
||||||
my $page_id = "session_".$session_name;
|
|
||||||
$notebook->delete($page_id);
|
|
||||||
}
|
|
||||||
|
|
||||||
sub on_session_pgm_clicked {
|
|
||||||
print "in CpGui::on_session_pgm_clicked @_\n";
|
|
||||||
my ($self, $session_name, $pgm_idx) = @_;
|
|
||||||
$self->toggle_program_in_session($session_name, $pgm_idx);
|
|
||||||
my $text = $self->get_session_program_status($session_name, $pgm_idx) ? 'on' : 'off';
|
|
||||||
$self->{$session_name.'hlist'}->itemConfigure($pgm_idx, 1, -text => $text);
|
|
||||||
}
|
|
||||||
|
|
||||||
1;
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
@@ -1,79 +0,0 @@
|
|||||||
package Paparazzi::CpPgmMgr;
|
|
||||||
|
|
||||||
use Subject;
|
|
||||||
@ISA = ("Subject");
|
|
||||||
|
|
||||||
use strict;
|
|
||||||
|
|
||||||
sub populate {
|
|
||||||
my ($self, $args) = @_;
|
|
||||||
$self->SUPER::populate($args);
|
|
||||||
$self->configspec(-children => [S_NOINIT, S_PASSIVE, S_RDWR, S_OVRWRT, S_NOPRPG, {}],
|
|
||||||
);
|
|
||||||
}
|
|
||||||
|
|
||||||
sub completeinit {
|
|
||||||
my $self = shift;
|
|
||||||
$self->SUPER::completeinit;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub start_program() {
|
|
||||||
my ($self, $pgm, @options, @args, $keep_stdin) = @_;
|
|
||||||
my %children = %{$self->get('-children')};
|
|
||||||
|
|
||||||
# print("in ChildrenSpawner::start_programm args [$pgm @args]\n");
|
|
||||||
my $pid = undef;
|
|
||||||
my $sleep_count = 0;
|
|
||||||
my $fh;
|
|
||||||
do {
|
|
||||||
$pid = fork();
|
|
||||||
$SIG{PIPE} = sub { die "whoops, $pgm pipe broke" };
|
|
||||||
unless (defined $pid) {
|
|
||||||
warn "cannot fork: $!";
|
|
||||||
die "bailing out" if $sleep_count++ > 6;
|
|
||||||
sleep 1;
|
|
||||||
}
|
|
||||||
} until defined $pid;
|
|
||||||
|
|
||||||
if (! $pid) { # child
|
|
||||||
$SIG{TERM} = 'IGNORE';
|
|
||||||
exec ($pgm, @options, @args);# or die "couldnt exec foo: $pgm @args";
|
|
||||||
# NOTREACHED
|
|
||||||
exit(1);
|
|
||||||
}
|
|
||||||
# parent
|
|
||||||
$children{$pid} = {cmd => $pgm, args => \@args};#, ktw => $fh};
|
|
||||||
$self->configure('-children', \%children);
|
|
||||||
# foreach my $key (keys %children) {
|
|
||||||
# print("in ChildrenSpawner::start_programm child: [$key $children{$key}]\n");
|
|
||||||
# }
|
|
||||||
return $pid;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub stop_program() {
|
|
||||||
my ($self, $pid) = @_;
|
|
||||||
# print "in_stop_program $pid\n";
|
|
||||||
|
|
||||||
my %children = %{$self->get('-children')};
|
|
||||||
my $pgm = $children{$pid};
|
|
||||||
|
|
||||||
if (defined $pgm) {
|
|
||||||
# printf STDOUT "Killing Process %d [%s %s]\n", $pid, $pgm->{cmd}, $pgm->{args};
|
|
||||||
kill 9, $pid;
|
|
||||||
$children{$pid} = undef;
|
|
||||||
$self->configure('-children', \%children);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
sub terminate_all() {
|
|
||||||
my ($self) = @_;
|
|
||||||
# print("in ChildrenSpawner::terminate_all\n");
|
|
||||||
my %pgms = %{$self->get('-children')};
|
|
||||||
foreach my $pid (keys %pgms) {
|
|
||||||
# print "killing $pid ($pgms{$pid})\n";
|
|
||||||
$self->stop_program($pid);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
1;
|
|
||||||
@@ -1,248 +0,0 @@
|
|||||||
package Paparazzi::CpSessionMgr;
|
|
||||||
|
|
||||||
use Data::Dumper;
|
|
||||||
use XML::DOM;
|
|
||||||
use Subject;
|
|
||||||
|
|
||||||
use Paparazzi::CpPgmMgr;
|
|
||||||
@ISA = qw(Paparazzi::CpPgmMgr);
|
|
||||||
|
|
||||||
use strict;
|
|
||||||
|
|
||||||
sub populate {
|
|
||||||
my ($self, $args) = @_;
|
|
||||||
$self->SUPER::populate($args);
|
|
||||||
$self->configspec(-config_file => [S_NEEDINIT, S_PASSIVE, S_RDONLY, S_OVRWRT, S_NOPRPG, undef],
|
|
||||||
-bin_base_dir => [S_NOINIT, S_PASSIVE, S_RDWR, S_OVRWRT, S_NOPRPG, "/usr/bin"],
|
|
||||||
-log_dir => [S_NOINIT, S_PASSIVE, S_RDWR, S_OVRWRT, S_NOPRPG, "/var/tmp"],
|
|
||||||
-variables => [S_NOINIT, S_PASSIVE, S_RDWR, S_OVRWRT, S_NOPRPG, {}],
|
|
||||||
-hosts => [S_NOINIT, S_PASSIVE, S_RDWR, S_OVRWRT, S_NOPRPG, {}],
|
|
||||||
-programs => [S_NOINIT, S_PASSIVE, S_RDWR, S_OVRWRT, S_NOPRPG, {}],
|
|
||||||
-sessions => [S_NOINIT, S_PASSIVE, S_RDWR, S_OVRWRT, S_NOPRPG, {}],
|
|
||||||
);
|
|
||||||
}
|
|
||||||
|
|
||||||
sub completeinit {
|
|
||||||
my ($self) = @_;
|
|
||||||
$self->SUPER::completeinit();
|
|
||||||
# my $cfg_file = $self->get('-config_file');
|
|
||||||
# my $variables = $self->get('-variables');
|
|
||||||
# $self->read_cfg($cfg_file);
|
|
||||||
$self->check_config();
|
|
||||||
}
|
|
||||||
|
|
||||||
sub prepare_args {
|
|
||||||
my ($self, $args, $session) = @_;
|
|
||||||
my (@options, @rargs);
|
|
||||||
my $variables = $self->get('-variables');
|
|
||||||
# print "CpSessionMgr : variables ".Dumper($variables);
|
|
||||||
foreach my $opt (@{$args}) {
|
|
||||||
my $type = $opt->{type};
|
|
||||||
my $flag = $opt->{flag};
|
|
||||||
my $value;
|
|
||||||
if ($type eq 'var') {
|
|
||||||
if (defined $session and exists $session->{vars}->{$opt->{value}}) {
|
|
||||||
$value = $session->{vars}->{$opt->{value}}
|
|
||||||
}
|
|
||||||
else {
|
|
||||||
$value = $variables->{$opt->{value}}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
else {
|
|
||||||
$value = $opt->{value};
|
|
||||||
}
|
|
||||||
if ($flag) {
|
|
||||||
if ($flag =~ /\.*=/) { push @options, $flag.$value}
|
|
||||||
else {push @options, $flag, $value}
|
|
||||||
}
|
|
||||||
else { push @rargs, $value}
|
|
||||||
}
|
|
||||||
return (@options, @rargs);
|
|
||||||
}
|
|
||||||
|
|
||||||
sub find_binary {
|
|
||||||
my ($self, $program) = @_;
|
|
||||||
my $command;
|
|
||||||
if ($program->{command} =~ /^\/.*/) {
|
|
||||||
$command = $program->{command};
|
|
||||||
}
|
|
||||||
else {
|
|
||||||
$command = $self->get('-bin_base_dir')."/".$program->{command};
|
|
||||||
}
|
|
||||||
return $command;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub toggle_program {
|
|
||||||
my ($self, $pgm_name) = @_;
|
|
||||||
print "processing program out session context\n";
|
|
||||||
my $program = $self->get('-programs')->{$pgm_name};
|
|
||||||
if (defined $program->{pid}) {
|
|
||||||
$self->SUPER::stop_program($program->{pid});
|
|
||||||
$program->{pid} = undef;
|
|
||||||
}
|
|
||||||
else {
|
|
||||||
my (@options, @args) = $self->prepare_args($program->{args});
|
|
||||||
my $command = $self->find_binary($program);
|
|
||||||
print "starting $program->{name} [$command @options @args]\n";
|
|
||||||
$program->{pid} = $self->SUPER::start_program($command, @options[0..$#options], @args[0..$#args]);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
sub toggle_program_in_session {
|
|
||||||
my ($self, $session_name, $pgm_idx) = @_;
|
|
||||||
$self->check_config();
|
|
||||||
my $session = $self->get('-sessions')->{$session_name};
|
|
||||||
my $session_program = $session->{pgms}->[$pgm_idx];
|
|
||||||
# print "processing program in session context\n".Dumper($session);
|
|
||||||
if (defined $session_program->{pid}) {
|
|
||||||
print "killing program $session_program->{name} => $session_program->{pid}\n";
|
|
||||||
$self->SUPER::stop_program($session_program->{pid});
|
|
||||||
$session_program->{pid} = undef;
|
|
||||||
}
|
|
||||||
else {
|
|
||||||
print "launching program\n";
|
|
||||||
my $program_name = $session_program->{name};
|
|
||||||
my $program = $self->get('-programs')->{$program_name};
|
|
||||||
my (@pgm_options, @pgm_args) = $self->prepare_args($program->{args}, $session);
|
|
||||||
my (@session_options, @session_args) = $self->prepare_args($session_program->{args});
|
|
||||||
push @pgm_options, @session_options;
|
|
||||||
push @pgm_args, @session_args;
|
|
||||||
my $command = $self->find_binary($program);
|
|
||||||
print "starting $program->{name} [$command @pgm_options @pgm_args]\n";
|
|
||||||
$session_program->{pid} = $self->SUPER::start_program($command, @pgm_options[0..$#pgm_options], @pgm_args[0..$#pgm_args]);
|
|
||||||
# print "launched $program_name => pid $session_program->{pid}\n";
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
sub start_session {
|
|
||||||
my ($self, $session_name) = @_;
|
|
||||||
$self->check_config();
|
|
||||||
# print "starting session $session_name\n";
|
|
||||||
my $sessions = $self->get('-sessions');
|
|
||||||
my $session = $sessions->{$session_name};
|
|
||||||
my @progs = @{$session->{pgms}};
|
|
||||||
# print "progs ".Dumper(@progs);
|
|
||||||
foreach my $pgm_idx (0..@progs-1) {
|
|
||||||
$self->toggle_program_in_session($session_name, $pgm_idx);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
sub kill_session {
|
|
||||||
my ($self, $session_name) = @_;
|
|
||||||
my $session = $self->get('-sessions')->{$session_name};
|
|
||||||
my @progs = @{$session->{pgms}};
|
|
||||||
foreach my $pgm_idx (0..@progs-1) {
|
|
||||||
$self->toggle_program_in_session($session_name, $pgm_idx) if ($self->get_session_program_status($session_name, $pgm_idx));
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
sub get_session_program_status {
|
|
||||||
my ($self, $session_name, $pgm_idx) = @_;
|
|
||||||
my $session = $self->get('-sessions')->{$session_name};
|
|
||||||
my $session_program = $session->{pgms}->[$pgm_idx];
|
|
||||||
return (defined $session_program->{pid});
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
#
|
|
||||||
# check if the config file has been modified since we parsed it and
|
|
||||||
# eventually reread it
|
|
||||||
#
|
|
||||||
sub check_config {
|
|
||||||
my ($self) = @_;
|
|
||||||
my $cfg_file = $self->get('-config_file');
|
|
||||||
my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
|
|
||||||
$atime,$mtime,$ctime,$blksize,$blocks)
|
|
||||||
= stat($cfg_file);
|
|
||||||
|
|
||||||
if (not exists $self->{last_cfg_read_time} or $mtime > $self->{last_cfg_read_time}) {
|
|
||||||
print("(re) reading config\n");
|
|
||||||
$self->read_cfg($cfg_file);
|
|
||||||
$self->{last_cfg_read_time} = $mtime;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
sub xml_parse_args {
|
|
||||||
my ($args) = @_;
|
|
||||||
my @args_a;
|
|
||||||
foreach my $arg (@{$args}){
|
|
||||||
my $var = $arg->getAttribute('variable');
|
|
||||||
my $args_h = {
|
|
||||||
flag => $arg->getAttribute('flag'),
|
|
||||||
type => $var eq '' ? 'const' : 'var',
|
|
||||||
value => $var eq '' ? $arg->getAttribute('constant'): $var,
|
|
||||||
};
|
|
||||||
push @args_a, $args_h;
|
|
||||||
}
|
|
||||||
# print "@args_a\n";
|
|
||||||
return \@args_a;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub xml_parse_section {
|
|
||||||
my ($self, $section) = @_;
|
|
||||||
my $section_name = $section->getAttribute('name');
|
|
||||||
my ($items_name) = ($section_name =~ /(.*)s$/);
|
|
||||||
# print "section $section_name items_name $items_name\n";
|
|
||||||
my $items = $section->getElementsByTagName($items_name);
|
|
||||||
my $h_name = '-'.$section_name;
|
|
||||||
# print "h_name $h_name\n";
|
|
||||||
my $tmp = $self->get($h_name);
|
|
||||||
foreach my $item (@{$items}){
|
|
||||||
if ($section_name eq "hosts") {
|
|
||||||
$tmp->{$item->getAttribute('name')} = $item->getAttribute('ip');
|
|
||||||
}
|
|
||||||
elsif ($section_name eq 'variables') {
|
|
||||||
$tmp->{$item->getAttribute('name')} = $item->getAttribute('value');
|
|
||||||
}
|
|
||||||
elsif ($section_name eq 'programs') {
|
|
||||||
my $pgm_name = $item->getAttribute('name');
|
|
||||||
my $args = $item->getElementsByTagName("arg");
|
|
||||||
my $args_h = xml_parse_args($args);
|
|
||||||
$tmp->{$pgm_name} =
|
|
||||||
{name => $pgm_name,
|
|
||||||
command => $item->getAttribute('command'),
|
|
||||||
args => $args_h,
|
|
||||||
};
|
|
||||||
}
|
|
||||||
elsif ($section_name eq 'sessions') {
|
|
||||||
my $session_name = $item->getAttribute('name');
|
|
||||||
my $xsessions_pgms = $item->getElementsByTagName("program");
|
|
||||||
my @sessions_pgms;
|
|
||||||
foreach my $session_pgm (@{$xsessions_pgms}){
|
|
||||||
my $pgm_name = $session_pgm->getAttribute('name');
|
|
||||||
my $session_args = $session_pgm->getElementsByTagName("arg");
|
|
||||||
my $args_h = xml_parse_args($session_args);
|
|
||||||
push @sessions_pgms, {
|
|
||||||
name => $pgm_name,
|
|
||||||
args => $args_h
|
|
||||||
};
|
|
||||||
}
|
|
||||||
my $session_vars = {};
|
|
||||||
my @xsession_vars = $item->getElementsByTagName("variable");
|
|
||||||
foreach my $session_var (@xsession_vars){
|
|
||||||
$session_vars->{$session_var->getAttribute('name')} = $session_var->getAttribute('value')
|
|
||||||
}
|
|
||||||
$tmp->{$session_name} = {
|
|
||||||
name => $session_name,
|
|
||||||
pgms => \@sessions_pgms,
|
|
||||||
vars => $session_vars,
|
|
||||||
};
|
|
||||||
}
|
|
||||||
}
|
|
||||||
$self->configure($h_name => $tmp);
|
|
||||||
}
|
|
||||||
|
|
||||||
sub read_cfg {
|
|
||||||
my ($self, $filename) = @_;
|
|
||||||
my $parser = XML::DOM::Parser->new();
|
|
||||||
my $doc = $parser->parsefile($filename);
|
|
||||||
my $cp = $doc->getElementsByTagName("control_panel")->[0];
|
|
||||||
$self->{cp_name} = $cp->getAttribute('name');
|
|
||||||
my $sections = $cp->getElementsByTagName("section");
|
|
||||||
foreach my $section (@{$sections}) {
|
|
||||||
$self->xml_parse_section($section);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
1;
|
|
||||||
Reference in New Issue
Block a user