source/rcdaq/rcdaq_runtypechooser.pl

0001 #! /usr/bin/perl
0002
0003 use Tk;
0004
0005
0006 sub getList
0007 {
0008     open (L, "rcdaq_client daq_list_runtypes |");
0009     while (<L>)
0010     {
0011     chop;
0012     my ( $name, $dummy, $value) = split;
0013 #   print "$name $value\n";
0014     $typelist{$name} = 0;
0015     $namelist{$name} = $value;
0016     }
0017     close L;
0018 }
0019
0020 sub set_type
0021 {
0022     my $t = shift;
0023     $result = `rcdaq_client daq_set_runtype $t`;
0024 }
0025
0026 sub dummy
0027 {
0028
0029 }
0030
0031
0032 $time_used = 2;
0033
0034 #$color1 = "#cccc99";
0035 #$color1 = "#999900";
0036 $color1 = "#CCCC99";
0037 $okcolor = "#00cc99";
0038 $errorcolor= "#ff6666";
0039 $neutralcolor ="#cc9900";
0040 $panelcolor = "#336633";
0041 $warncolor = "IndianRed4";
0042 $graycolor = "#666666";
0043
0044 $buttonbgcolor='#33CCCC';
0045
0046 $smalltextfg = '#00CCFF';
0047 $smalltextbg = '#333366';
0048
0049 $slinebg='#cccc00';
0050
0051 $oncolor = "orange2";
0052 $offcolor = "yellow4";
0053
0054
0055 #$bgcolor = "#cccc66";
0056 $bgcolor = "#990000";
0057
0058 $runstatcolor = "aquamarine";
0059 $stopstatcolor = "palegreen";
0060 $neutralcolor = "khaki";
0061
0062
0063 $titlefontsize=15;
0064 $fontsize=13;
0065 $subtitlefontsize=11;
0066 $smallfont = ['arial', $subtitlefontsize];
0067 $normalfont = ['arial', $fontsize];
0068 $bigfont = ['arial', $titlefontsize, 'bold'];
0069
0070
0071
0072 &getList;
0073
0074 $mw = MainWindow->new();
0075
0076
0077
0078 $mw->title("Run Type Control");
0079
0080
0081 $label{'sline'} = $mw->Label(-text => "Run Type Control", -background=>$slinebg, -font =>$bigfont);
0082 $label{'sline'}->pack(-side=> 'top', -fill=> 'x', -ipadx=> '15m', -ipady=> '1m');
0083
0084
0085 $frame{'center'} = $mw->Frame()->pack(-side => 'top', -fill => 'x');
0086
0087
0088 $framename = $frame{'center'}->Label(-bg => $color1, -relief=> 'raised')->pack(-side =>'left', -fill=> 'x', -ipadx=>'15m');
0089
0090
0091 $label_a = $framename->Label(-bg => $color1, -relief=> 'raised')->pack(-side =>'top', -fill=> 'x');
0092 $label_c = $framename->Label(-bg => $color1, -relief=> 'raised')->pack(-side =>'bottom', -fill=> 'x');
0093 $label_b = $framename->Label(-bg => $color1, -relief=> 'raised')->pack(-side =>'bottom', -fill=> 'x');
0094
0095
0096 $currenttypelabel = $label_a->
0097       Label(-font => $bigfont, -fg =>'red', -bg => $neutralcolor)->
0098       pack(-side =>'top', -fill=> 'x', -expand => 1, -ipadx=> '3m',  -ipady=> '3m');
0099
0100 $currentnamelabel = $label_b->
0101       Label( -font => $smallfont, -fg =>'black', -bg => $neutralcolor)->
0102       pack(-side =>'top', -fill=> 'x', -expand => 1, -ipadx=> '2m',  -ipady=> '2m');
0103
0104
0105 foreach $type ( sort keys %typelist )
0106 {
0107     $button{$type} = $label_c->
0108     Button( -bg => $buttonbgcolor, -text => $type, -command => [\&set_type,$type],  -relief =>'raised',  -font=> $normalfont)->
0109     pack(-side =>'left', -fill=> 'x',-expand => 1, -ipadx=>'1m', -ipady=> '1m');
0110
0111 }
0112
0113 # update once to fill all the values in
0114 update();
0115
0116 #and schedule an update every 5 seconds
0117
0118
0119
0120 $mw->repeat($time_used * 1000,\&update);
0121
0122 MainLoop();
0123
0124
0125
0126
0127 sub update()
0128 {
0129
0130
0131     my $res = `rcdaq_client daq_get_runtype  2>&1`;
0132 #    print $res;
0133
0134     if ( $res =~ /system error/  || $res =~ /Program not registered/ )
0135     {
0136     $currenttypelabel->configure(-text =>"RCDAQ not running");
0137
0138     }
0139     else
0140     {
0141
0142     foreach $type ( sort keys %typelist )
0143     {
0144         $button{$type}->configure( -bg => $buttonbgcolor);
0145     }
0146
0147     chomp $res;
0148     if ($res eq "")
0149     {
0150         $currenttypelabel->configure(-text => "( no run type set )");
0151         $currentnamelabel->configure(-text => "");
0152     }
0153     else
0154     {
0155
0156         $currenttypelabel->configure(-text => $res);
0157         $currentnamelabel->configure(-text => $namelist{$res});
0158         $button{$res}->configure( -bg => $oncolor);
0159     }
0160     }
0161 }