#!/usr/bin/perl
use warnings;
use strict;
use Tk;
use threads;
use threads::shared;

# 1 setting for big or default font, see lines 

my $prog : shared;
$prog = shift or die "Need a program to run a arg 1 $!\n";
#$prog = './float2';

#create threads first, to make Tk thread-safe
my $buf : shared;
my $thread0_die : shared;
my $thread0_go : shared;
$buf = '';
$thread0_die = 0;
$thread0_go = 0;

my $pid : shared;
my $thread1_go : shared;
$pid = '';
$thread1_go = 0;

my $thread0 = threads->new( \&monitor );
my $thread1 = threads->new( \&run );

my $pos = 0;
my $string1 = 'pid  user   '; 
my $string2 = ' mem ';
my $string3 = ' cpu ';
my $string4 = 'program';

my $mouse = 0;

my $mw = new MainWindow;
$mw->protocol('WM_DELETE_WINDOW' => sub {                             
+                    
                kill 9, $pid;
                $thread0_die = 1;
        $thread0->join;                                  
        $thread1->join;                                  
                exit;                                                 
+                    
           });        

my $tframe = $mw->Frame(-bg=>'black')->pack(-fill=>'x');
$tframe->Label(-text=> 'RAM ------',-bg=>'black',-fg=>'red')->pack(-si
+de=>'left');
$tframe->Label(-text=> 'CPU ------',-bg=>'black',-fg=>'green')->pack(-
+side=>'left');
my $sb;
$sb = $tframe->Button(-text=> 'Start',
                         -bg=>'white',
                         -fg=>'black',
             -command =>sub{
                                if($sb->cget('-text') eq 'Start'){
                  $sb->configure(-text => 'Stop');                   
                      $thread1_go = 1;
                                  $thread0_go = 1;
                  my $id = Tk::After->new($mw,100,'repeat',\&refresh);
                    }else{ 
                    kill 9, $pid;
                    $thread0_go = 0;
                     }
                      }    )->pack(-side=>'right');

my $canvas0 = $mw->Canvas(
          -bg =>'black',
          -height => 20,
      -width => 600,
        )->pack(-expand=>0,-fill=>'x');


my $canvas = $mw->Scrolled('Canvas',
          -bg =>'black',
          -height => 300,
      -width => 600,
          -scrollregion => [0,0,1000,600],
      -scrollbars => 'osoe',
    )->pack(-expand=>1,-fill=>'both');

my $realcan = $canvas->Subwidget('scrolled');

#my $font = 'default';
my $font = $mw->fontCreate('font',
    -family=>'arial',
    -weight=>'bold',
    -size=>int(-18*18/14));

my $fonttest =  $canvas->createText(0,0,
              -fill    => 'black',
              -text    => 'W',            
              -font => $font,
              );
   
my ($bx,$by,$bx1,$by1) = $canvas->bbox($fonttest);
my $f_w = $bx1 - $bx;
my $f_h = $by1 - $by;
$canvas->delete($fonttest);

my $text1 = $canvas0->createText($f_w, 0 ,
                -fill    => 'orange',
                -text => $string1,
            -font => $font,
                -anchor => 'nw',
        -justify => 'left',
            -tags => ['slider']
          );

my $text2 = $canvas0->createText(length($string1)* $f_w , 0,
                -fill    => 'red',
                -text => $string2,
            -font => $font,
                -anchor => 'nw',
        -justify => 'left',
                -tags => ['slider']
          );

my $text3 = $canvas0->createText( (length($string1)+length($string2))*
+ $f_w, 0,
                -fill    => 'green',
                -text => $string3,
            -font => $font,
                -anchor => 'nw',
        -justify => 'left',
            -tags => ['slider']
          );

my $text4 = $canvas0->createText(
             (length($string1)+length($string2)+length($string3) )* $f
+_w, 0,
                -fill    => 'yellow',
                -text => $string4,
            -font => $font,
                -anchor => 'nw',
        -justify => 'left',
            -tags => ['slider']
          );

$canvas->createLine($f_w, $pos * $f_h + 1.5*$f_h, 
                         $f_w + 1000  , $pos * $f_h + 1.5*$f_h ,  
                -fill   => 'white',
        -dash   => '- -',
        -width  =>1,
          );

$canvas->createLine($f_w, $pos * $f_h + 1.5*$f_h, 
                    $f_w, 250 + $pos * $f_h + 1.5*$f_h ,  
                -fill   => 'white',
        -dash   => '- -',
        -width  =>1,
          );

     my (undef,undef,$x,$y) = $realcan->bbox("all");
     if( defined $x){
       $realcan->configure(-scrollregion => [0,0,$x + 30, $y+30 ] ); 
      }

$mw->waitVisibility;

#setup an autoscroll when active area is near righ edge
my $o_xscrollcommand = $realcan->cget( -xscrollcommand );
$realcan->configure( -xscrollcommand => sub {
      if ( $_[1] > 0.95 ){ 
            $canvas->xview('moveto',1)
    }else{    
             $o_xscrollcommand->Call( @_ );
             }
   }
);


MainLoop;

sub refresh{
  my @data = split(/\n/, $buf);

  my ($user,$command,$mem,$cpu);

  foreach my $line(@data){
          $line =~ s/^\s+//;
          if($line =~ /^\d+/){ 
            my @p = split(/\s+/, $line); 
        $user = $p[1];
        $command = $p[11];
        $mem = $p[9];
        $cpu = $p[8];
     }
     }

   if(defined $user){
     $string1 =  $pid.'   '.$user.'    ';
     $string2 =  $mem.'   ';
     $string3 =  $cpu.'   ';
     $string4 =  $command;
     
     $canvas0->itemconfigure($text1, -text=> $string1);
     $canvas0->itemconfigure($text2, -text=> $string2);
     $canvas0->itemconfigure($text3, -text=> $string3);
     $canvas0->itemconfigure($text4, -text=> $string4);
   
    
    $pos +=4;
     #500 pixel max width, so 500 = 1.0 or 100%
    $canvas->createLine($f_w + $pos, 1.5*$f_h , 
                        $f_w + $pos, 1.5*$f_h + $cpu * 2.5,  
                -fill    => 'green',  
        -width =>4,
    #    -stipple =>'gray75',
          );

    $pos +=4;
    $canvas->createLine( $f_w + $pos, 1.5* $f_h, 
                        $f_w + $pos, 1.5*$f_h + $mem * 2.5,  
                -fill    => 'red',
                -width =>4,
        -stipple =>'gray75',
          );
 
  }
 
 
  if(($pos > 600) and ($thread0_go == 1)){
   my (undef,undef,$x,$y) = $realcan->bbox("all");
     if( defined $x){
       $realcan->configure(-scrollregion => [0,0,$x + 30, $y+30 ] ); 
     }
   }


}
##################################################################
sub monitor{
   $|++;
   use IO::Select;

while(1){
 if( $thread0_go == 1){
   my $pid0 = open( READ, "top -b -d .1 -p $pid |");
   waitpid($pid0, 1);
   my $sel = new IO::Select();
   $sel->add(\*READ);
 
  while(1){
    foreach my $h ($sel->can_read){
         sysread(READ,$buf,4096);
       }
  if( $thread0_die == 1 ){return} #kill thread
  }
 }

select(undef,undef,undef,.5);

}

}
#####################################################################

sub run{
   $|++;

  while(1){  # stay in holding pattern until go is given
    if( $thread1_go == 0){
      select(undef,undef,undef,.1);
     }else{ last }
    }
 
   $pid = open( RUN, "| $prog ");
   print RUN ''; #hack to prevent harmless error message
   waitpid($pid, 1);
  
}
#####################################################################
[download]