At my workplace i've to do with a bunch of win-servers. Several partially selfwritten services have to be observed for proper working. Therefore i wrote this little Tk-application. With dstat ("dienst-status") services on different win-servers can be observed, stopped and startet.
Imho it's a nice example for the far-reaching capabilities of Tk::HList and Win32::Service.
dstat.obs (envvar $OBSDIR) contains the servers and services which are to be observed.
#!/usr/bin/perl
#$Id: dstat,v 0.9 2004/11/23 10:53:32 tos Exp tos $
# gvim: tabstop=3, syntax=perl
use strict;
use warnings;
use URI::File;
use Tk;
use Tk::After;
use Tk::HList;
use Tk::ItemStyle;
use Data::Dumper;
use Win32::Service;
my %RegHash;
use Win32::TieRegistry(TiedHash => \%RegHash, Delimiter=>"/");
my $reg = \%RegHash;
# init vars {{{1
my $cycle = 10000; # milliseconds
my (@fonts) = (
'-*-Helvetica-Medium-R-Normal--*-180-*-*-*-*-*-*',
'-*-Courier-Medium-R-Normal--*-180-*-*-*-*-*-*',
'-*-times-medium-r-normal--*-240-*-*-*-*-*-*',
'-Adobe-Courier-Bold-O-Normal--*-120-*-*-*-*-*-*',
'fixed',
);
my(@colors) = qw(red gray green blue yellow red cyan black);
my @statCode = (
['undefined', 'grey'],
['stopped', 'red'],
['start pending', 'blue'],
['stop pending', 'orange'],
['running', 'green'],
['continue pending', 'grey'],
['pause pending', 'grey'],
['paused', 'lightblue'],
);
# }}}1
# widget-related {{{1
my $top = MainWindow->new;
my $h = $top->Scrolled (qw/HList -header 1
-columns 5
-width 90
-height 40/,
-selectbackground => '#dec
+435'
)->pack(qw/-fill both -expand 1/);
my $i;
foreach (qw(server serviceName status displayName description)) {
$h->header('create', $i++, -text => $_);
}
my @st = ( $top->ItemStyle('text',
-background => 'gray70',
-foreground => 'black',
-selectforeground => 'darkblue',
-font => $fonts[0]),
$top->ItemStyle('text',
-background => 'gray80',
-foreground => 'black',
-selectforeground => 'darkblue',
-font => $fonts[0])
);
my $services = readObs();
$top->Button(-text => "erfrischen",
-height => 0.3,
-command =>
sub { updtTable($services); },
-font => $fonts[0])
->pack(-side => 'left');
$top->bind('<q>' =>
sub {
exit;
});
# }}}1
getStat($services);
initTable($services);
$top->repeat($cycle, sub{updtTable($services)});
MainLoop;
sub readObs { # {{{1 ------------------------------------------------
my $AoA;
my $obsDir = $ENV{"OBSDIR"}
|| "//tux/tos/tc/lab/dvlp/tos/too";
print "\$obsDir: $obsDir\n";
open I, "$obsDir/dstat.obs";
$i = 0;
while (<I>) {
next if /^(#|\s*$)/;
s/\s*//g;
chomp;
@{$AoA->[$i]} = split ',';
push @{$AoA->[$i++]}, {};
}
close I;
$AoA;
} # getStat }}}1
sub getStat { # {{{1 ------------------------------------------------
$top->configure(-cursor => 'watch');
# @a: (serverName, serviceName, statusStructure,
# displayName, description)
my $a = shift;
foreach (@$a) {
Win32::Service::GetStatus($_->[0], $_->[1], $_->[2]);
my $x = $reg
->{"//" . $_->[0]}
->{"HKEY_LOCAL_MACHINE"}
->{"System"}
->{"ControlSet001"}
->{"Services"}
->{$_->[1]};
$_->[3] = $x->{"/DisplayName"},"\n";
$_->[4] = $x->{"/description"},"\n";
}
$top->configure(-cursor => 'arrow');
} # getStat }}}1
sub updtTable { # {{{1------------------------------------------------
# @a: (serverName, serviceName, statusStructure,
# displayName, description)
my $a = shift;
getStat($a);
my $i = 0;
for (@$a) {
# itemConfigure auf die 2. Säule liefert mir ein AoA.
# [3][4] ist 'ne gesegnete hRef auf Tk::Menubutton
# itemConfigure on second column returns an AoA.
# [3][4] is a blessed hRef on Tk::Menubutton
my $mb = $h->itemConfigure($i, 2)->[3][4];
#print Data::Dumper->Dump([$y], [qw($y)]);
my $stat = $_->[2]{CurrentState};
# modifiziere nun ((Menu)button)methodisch die Eigen-
# schaften
# modifying properties "((menu)button)methodically"
my $x = $mb->configure(-text, $statCode[$stat][0]);
$x = $mb->configure(-bg, $statCode[$stat][1]);
$x = $h->itemConfigure($i, 3);
#print Data::Dumper->Dump([$x], [qw($x)]);
$h->itemConfigure($i, 3, -text => $_->[3]);
$h->itemConfigure($i, 4, -text => $_->[4]);
$i++;
}
} # updtTable }}}1
sub initTable { # {{{1------------------------------------------------
# @a: (serverName, DienstName, StatusStruktur,
# AnzeigeName, Beschreibung)
my $a = shift;
my $t;
for (@$a) {
my $e = $h->addchild("");
$t = not $t;
for my $col (0 .. 4) {
my $btn;
my $style_type = 'text';
my $style = $h->ItemStyle($style_type);
if ($col == 2 ) {
$style_type = 'window';
my $hostNam = $_->[0];
my $serviceNam = $_->[1];
my $stat = $_->[$col]{CurrentState};
$btn = $h->Menubutton(qw/-relief raised -tearoff 0/,
-text => $statCode[$stat][0],
-background => $statCode[$stat][1],
-font => $fonts[0],
-activebackground => 'cyan',
-direction => 'right');
$btn->command(
-label => 'run',
-command => sub {
Win32::Service::StartService(
$hostNam,
$serviceNam
);
});
$btn->command(
-label => 'stop',
-command => sub {
Win32::Service::StopService(
$hostNam,
$serviceNam
);
});
} else {
$style_type = 'text';
};
$h->itemCreate ($e, $col,
($style_type eq 'window'
? do {
(
-itemtype => 'window',
-widget => $btn,
);
}
: do {
(
-text => $_->[$col],
-style => $st[$t],
);
}
),
);
}
}
} # table }}}1
example for a dstat.obs
# cat dstat.obs
jet03a, W32Time
jet03a, netman
jet03a, AudioSrv
sys-10102, W32Time
sys-10102, AudioSrv
sys-10102, stisvc
-
Are you posting in the right place? Check out Where do I post X? to know for sure.
-
Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
<code> <a> <b> <big>
<blockquote> <br /> <dd>
<dl> <dt> <em> <font>
<h1> <h2> <h3> <h4>
<h5> <h6> <hr /> <i>
<li> <nbsp> <ol> <p>
<small> <strike> <strong>
<sub> <sup> <table>
<td> <th> <tr> <tt>
<u> <ul>
-
Snippets of code should be wrapped in
<code> tags not
<pre> tags. In fact, <pre>
tags should generally be avoided. If they must
be used, extreme care should be
taken to ensure that their contents do not
have long lines (<70 chars), in order to prevent
horizontal scrolling (and possible janitor
intervention).
-
Want more info? How to link
or How to display code and escape characters
are good places to start.