Beefy Boxes and Bandwidth Generously Provided by pair Networks
Think about Loose Coupling
 
PerlMonks  

comment on

( [id://3333]=superdoc: print w/replies, xml ) Need Help??
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

In reply to Tk-tool for remote access on win-services by tos

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • 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.
Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others meditating upon the Monastery: (7)
As of 2024-03-29 14:10 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found