mgm/mgm

   1 #!/usr/bin/perl -w
   2
   3 use Tk;
   4 use Tk qw(exit);
   5 use IPC::Open2;
   6 use Config;
   7 use strict;
   8 use vars qw($basedir $moddir $libdir $modname $fontfile $toplevel
   9             $orient $stack $background $foreground);
  10
  11 # current install strategy: plop ourselves somewhere line
  12 # /usr/local/mgm.  Make sure the mgm entry that is found in the path
  13 # is a symlink to the absolute path of the actual Perl script.  That
  14 # way, $0 will be a full path.
  15
  16 $basedir=$0;
  17 # find the real mgm, not a symlink
  18 while(defined(my$test=readlink($basedir))){$basedir=$test};
  19 # strip off the filename
  20 $basedir=~s/\/?([^\/]*)$//;
  21 $basedir="./"if($basedir eq "");
  22
  23 # assume the other schtuff we need is in the standard places.
  24
  25 $moddir="$basedir/modules";
  26 $libdir="$basedir/lib";
  27 $fontfile="$libdir/helvetica2.xpm";
  28
  29 $0="moaning-goat-meter"; # OK, this is evil.
  30
  31 #$|=1;
  32
  33 $toplevel=new MainWindow(-class=>'Mgm');
  34
  35 # get us our logo xpm
  36
  37 my$mgmlogoH=$toplevel->Pixmap(-file => "$libdir/mgm-small.xpm");
  38 my$mgmlogoV=$toplevel->Pixmap(-file => "$libdir/mgm-vertical.xpm");
  39
  40 my%modules;
  41 my%instances;
  42 my@ordered;
  43
  44 my$Xname=$toplevel->Class;
  45 require "$libdir/widget";
  46
  47 $toplevel->optionAdd("$Xname*background",       '#202020',20);
  48 $toplevel->optionAdd("$Xname*foreground",       '#a0a0a0',20);
  49 $toplevel->optionAdd("$Xname*borderwidth",      0,10);
  50 $toplevel->optionAdd("$Xname*relief",           'flat',10);
  51
  52 # adj of 100% result in config demand of 50 pixels
  53 $toplevel->optionAdd("$Xname.lendemand",         '25',20);
  54 # adj of 100% result in config demand of 12 pixels per bar
  55 $toplevel->optionAdd("$Xname.widdemand",         '12',20);
  56
  57 $toplevel->optionAdd("$Xname.stack",            'horizontal',20);
  58 $toplevel->optionAdd("$Xname.bars",             'vertical',20);
  59 $toplevel->optionAdd("$Xname*textpad",          '1',20);
  60 $toplevel->optionAdd("$Xname*widgetpad",        '2',20);
  61
  62 $toplevel->optionAdd("$Xname*font",
  63                      '-*-helvetica-medium-r-semicondensed-*-8-*-*-*-*-*-*-*',20);
  64
  65 $toplevel->optionAdd("$Xname*labelsize",       '9',20);
  66
  67 $toplevel->optionAdd("$Xname*active",           'true',20);
  68 $toplevel->optionAdd("$Xname*reconfig",         'true',20);
  69 $toplevel->optionAdd("$Xname*order",            1000,20);
  70 $toplevel->optionAdd("$Xname*scale",            'true',20);
  71 $toplevel->optionAdd("$Xname*scalejustify",     '1',20);
  72 $toplevel->optionAdd("$Xname*scalethresh",      '4',20);
  73 $toplevel->optionAdd("$Xname*scalelenadj",      '100',20);
  74 $toplevel->optionAdd("$Xname*scalewidadj",      '100',20);
  75 $toplevel->optionAdd("$Xname*scalecolor",       'yellow',20);
  76 $toplevel->optionAdd("$Xname*scalescroll",          'true',20);
  77 $toplevel->optionAdd("$Xname*scalerefresh",          '1000',20);
  78 $toplevel->optionAdd("$Xname*scalereturn",           '8',20);  # 2 seconds
  79
  80
  81 $toplevel->optionAdd("$Xname*dimbackground",'#414676',20);
  82 $toplevel->optionAdd("$Xname*litbackground",'#74ade7',20);
  83 $toplevel->optionAdd("$Xname*bar*dimrelief",    'flat',20);
  84 $toplevel->optionAdd("$Xname*bar*litrelief",    'raised',20);
  85
  86 $toplevel->optionAdd("$Xname*bar*label",        "fill in",20);
  87 $toplevel->optionAdd("$Xname*bar*ratio",        '1.2',20);
  88
  89 # suck in command line resources
  90 while(my $arg=shift @ARGV){
  91     $arg=~s/-(\S*)$/$1/;
  92
  93     if($arg){
  94         my$val=shift;
  95         $toplevel->optionAdd("$Xname*$arg",  "$val",80);
  96     }
  97 }
  98
  99 $orient=$toplevel->optionGet("bars","");
 100 $stack=$toplevel->optionGet("stack","");
 101 $background=$toplevel->optionGet("background","");
 102 $foreground=$toplevel->optionGet("foreground","");
 103
 104 $toplevel->optionAdd("$Xname*dimforeground",  "$background",20);
 105 $toplevel->optionAdd("$Xname*litforeground", "$background",20);
 106
 107 $toplevel->configure('-background'=>"$background",'-foreground'
 108                      =>"$foreground");
 109
 110 # hack to set geometry when specified in .Xresources; reinstance can't
 111 # do this, or we'll 'creep' on reconfig
 112 my$geometry=$toplevel->optionGet("geometry","");
 113 if(defined($geometry)){
 114     $toplevel->geometry($geometry);
 115 }
 116
 117 # three stages: 1) get module references and extract how many to build
 118 #               2) make module instances, extract geometry
 119 #               3) draw modules, place and run
 120
 121 my($actualx,$actualy,$renderflag,$renderx,$rendery);
 122 my($minx,$miny,$reqx,$reqy,$ladj,$wadj);
 123 $renderflag=0;
 124
 125 # platform specific module references
 126 my $modname = $Config{'osname'};
 127 $modname =~ tr/A-Z/a-z/;
 128 &LoadModules($moddir,$modname);
 129
 130 &reinstance();
 131
 132 Tk::MainLoop();
 133
 134 #########################################################################
 135
 136 sub max{
 137     my$val=shift;
 138
 139     while(my$test=shift){$val=$test if $test>$val}
 140     $val;
 141 }
 142
 143 sub min{
 144     my$val=shift;
 145
 146     while(my$test=shift){$val=$test if $test<$val}
 147     $val;
 148 }
 149
 150 # load the modules
 151
 152 sub LoadModules{
 153     my($prefix,$dir)=@_;
 154
 155     $prefix=~s{/\s*$}{}; # strip trailing slash
 156
 157     # get the filenames in $prefix/<platform>
 158     my $searchdir="$prefix/$dir";
 159     if(opendir(D,$searchdir)){
 160         my$file;
 161         my@files;
 162         while(defined($file=readdir(D))){
 163             if(substr($file,0,1) ne '.'){
 164                 if(substr($file,0) ne 'CVS'){
 165                     push @files, $file;
 166                 }
 167             }
 168         }
 169
 170         closedir(D);
 171
 172         # sort/load the modules (we need deterministic load order, in
 173         # this case alphabetical)
 174         foreach $file (sort @files){
 175             print "loading module $file...\n";
 176             &LoadModule($searchdir,$file);
 177         }
 178
 179     }else{
 180         print STDERR "Unable to open plugin directory $searchdir: $!\n";
 181     }
 182
 183 }
 184
 185 sub LoadModule{
 186     my($path,$filename)=@_;
 187
 188     if(open(PL,"$path/$filename")){
 189
 190         undef $/;
 191         my$script=<PL>;
 192         close PL;
 193         $/="\n";
 194
 195         my $moduleref= eval $script if (defined($script));
 196
 197         if(defined($moduleref)){
 198
 199             # The hash returned is an object. It defines the following methods:
 200             #    module_init         => set up basic config, once per mod.
 201             #                           Call that now
 202             #    module_instance     => set up instance of module
 203             #    module_run          => draw the module and start timers
 204             #    module_update       => run at refresh interval
 205
 206             # Be certain we've not already loaded this plugin.
 207
 208             my$name=$moduleref->{"name"}=
 209                 ucfirst ((split /::/,ref $moduleref)[-1]);
 210             $moduleref->{"toplevel"}=$toplevel;
 211             $moduleref->{"xclass"}="$Xname*$name"; # class name
 212
 213             if(defined($modules{$name})){
 214                 print STDERR
 215                     "Module $name already loaded.\n";
 216                 return(0);
 217             }
 218             $modules{$name}=$moduleref;
 219
 220             # dummy; Tk doesn't let us look up resources for windows
 221             # that don't exist.
 222             $moduleref->{"widget"}=$toplevel->Label(-class=>$name);
 223
 224             # call init; this sets up the module, but not an instance
 225             my$ret=eval {$moduleref->module_init};
 226             if(!defined($ret)){
 227                 print STDERR "Error eval()ing ->module_init for $name:".
 228                     "$@\n";
 229                 0;
 230             }else{
 231                 1;
 232             }
 233         }else{
 234             print "Error loading module $path/$filename: $@\n";
 235         }
 236     }else{
 237         print "Error opening module $path/$filename: $!\n";
 238     }
 239 }
 240
 241 # decide how many instances to build and what order they appear in
 242 sub order_modules{
 243     # Build the order-of-appearance list
 244     my$count=0;
 245     foreach my $key (sort (keys %modules)){
 246         # each order entry may have more than one location
 247         my$act=&moption($modules{$key},'active');
 248         if($act eq 'true'){
 249             my$opt=&moption($modules{$key},'order');
 250             my@l=split ',', $opt;
 251             foreach my $loc (@l){
 252                 $instances{"$loc $count"}=$modules{$key};
 253                 $count++;
 254             }
 255         }
 256     }
 257
 258     @ordered= sort {my($A,$AA)=(split ' ',$a);
 259                     my($B,$BB)=(split ' ',$b);
 260                     if($A==$B){
 261                           $AA <=> $BB
 262                       }else{
 263                           $A <=> $B
 264                       }} keys %instances;
 265 }
 266
 267 # build module instances from the module refs
 268 sub instance_modules{
 269     my$count=0;
 270     foreach my $key (@ordered){
 271         my $mod=$instances{"$key"};
 272
 273         my$this={ map{("$_"=>$mod->{"$_"})}keys %$mod};
 274         bless $this, (ref $mod);
 275
 276         # dummy; Tk doesn't let us look up resources for windows
 277         # that don't exist.
 278         $this->{"xpath"}="$Xname.$count"; # window name
 279         $this->{"widget"}=$toplevel->Label(Name=>$count,
 280                                            -class=>$this->{"name"});
 281
 282         my$ret=eval {$this->module_instance};
 283         if(!defined($ret)){
 284             if(!defined($@)){
 285                 print STDERR "->module_instance for ".
 286                     ($mod->{name})." returned undef: instance already ".
 287                         "exists (or module forgot to set return val)\n";
 288             }else{
 289                 print STDERR "Error eval()ing ->module_instance for ".
 290                     ($mod->{name}).": $@\n";
 291             }
 292             undef $instances{$key};
 293         }else{
 294             $instances{$key}=$ret;
 295         }
 296         $count++;
 297     }
 298 }
 299
 300 # extract minimum and requested geometries to do some pre-placement
 301 sub geometries{
 302     my$minx=0;
 303     my$miny=0;
 304     my$ladj=0;
 305     my$wadj=0;
 306     my$wdemand=$toplevel->optionGet("widdemand",'');
 307     my$ldemand=$toplevel->optionGet("lendemand",'');
 308
 309     foreach my $key (@ordered){
 310         my $mod=$instances{$key};
 311
 312         if(defined($mod) && &mplace($mod)){
 313
 314             my $active=&moption($mod,"active");
 315             my $pad=&moption($mod,"widgetpad");
 316
 317             if($active eq 'true'){
 318                 if($stack eq $orient){
 319                     $wadj=&max(1,&max($wadj,&moption($mod,"scalewidadj")));
 320                     $ladj+=&max(1,&moption($mod,"scalelenadj"));
 321                 }else{
 322                     $ladj=&max(1,&max($ladj,&moption($mod,"scalelenadj")));
 323                     $wadj+=&max(1,&moption($mod,"scalewidadj"));
 324                 }
 325
 326                 if($stack eq 'vertical'){
 327                     my$tempx=&moption($mod,'minx')+$pad*2;
 328                     $minx=$tempx if ($minx<$tempx);
 329                     $miny+=&moption($mod,'miny');
 330                     $miny+=$pad;
 331                 }else{
 332                     my$tempy=&moption($mod,'miny')+$pad*2;
 333                     $miny=$tempy if ($miny<$tempy);
 334                     $minx+=&moption($mod,'minx');
 335                     $minx+=$pad;
 336                 }
 337             }
 338         }
 339     }
 340
 341     if($orient eq 'vertical'){
 342         ($minx,$miny,int($minx+($wadj/100*$wdemand)),
 343          int($miny+($ladj/100*$ldemand)),$ladj,$wadj);
 344     }else{
 345         ($minx,$miny,int($minx+($ladj/100*$ldemand)),
 346          int($miny+($wadj/100*$wdemand)),$ladj,$wadj);
 347     }
 348 }
 349
 350 # final layout and widget creation
 351 sub build_and_run{
 352     # calculate demand/sizes
 353
 354     my$extrax=$actualx-$minx;
 355     my$extray=$actualy-$miny;
 356
 357     my$extradelx=0;
 358     my$extradely=0;
 359     if($orient eq 'vertical'){
 360         $extradelx=$extrax/$wadj if($wadj>0);
 361         $extradely=$extray/$ladj if($ladj>0);
 362     }else{
 363         $extradelx=$extrax/$ladj if($ladj>0);
 364         $extradely=$extray/$wadj if($wadj>0);
 365     }
 366
 367     # determine new logo size and placement.
 368     # unmap old widgets
 369
 370     my$i=0;
 371     my$pos=0;
 372     foreach my $key (@ordered){
 373         my $mod=$instances{$key};
 374         if(defined($mod) && mplace($mod)){
 375             my $pad=&moption($mod,"widgetpad");
 376             my $justify=&moption($mod,"scalejustify");
 377             my$x;
 378             my$y;
 379             my$width;
 380             my$height;
 381
 382             my$xlocaldemand;
 383             my$ylocaldemand;
 384
 385             if($orient eq 'vertical'){
 386                 $xlocaldemand=&max(1,&moption($mod,"scalewidadj"));
 387                 $ylocaldemand=&max(1,&moption($mod,"scalelenadj"));
 388             }else{
 389                 $xlocaldemand=&max(1,&moption($mod,"scalelenadj"));
 390                 $ylocaldemand=&max(1,&moption($mod,"scalewidadj"));
 391             }
 392
 393             # note that some versions of Tk have an off by one error
 394             # positioning along the south border.  Always use nw
 395             # anchors for safety when possible even if the math is
 396             # annoying
 397
 398             if($stack eq 'vertical'){
 399                 $width=$minx+$extradelx*$xlocaldemand-$pad*2;
 400                 $height=&moption($mod,"miny")+
 401                     $extradely*$ylocaldemand;
 402                 $x=$pad+
 403                     ($justify-1)/-2*($actualx-$pad*2-$width);
 404                 $y=$pos+$pad/2;
 405                 $pos+=$height+$pad;
 406             }else{
 407                 $width=&moption($mod,"minx")+
 408                     $extradelx*$xlocaldemand;
 409                 $height=$miny+$extradely*$ylocaldemand-$pad*2;
 410                 $y=$pad+
 411                     ($justify+1)/2*($actualy-$pad*2-$height);
 412                 $x=$pos+$pad/2;
 413                 $pos+=$width+$pad;
 414             }
 415
 416             # these are controlled by us and needed in the object anyway,
 417             # so we set them
 418             $mod->{"width"}=$width;
 419             $mod->{"height"}=$height;
 420             $mod->{"placex"}=$x;
 421             $mod->{"placey"}=$y;
 422             $mod->{"sequence"}=$i;
 423             $mod->{'widget'}->placeForget;
 424
 425         }
 426         $i++;
 427     }
 428
 429     # pop in the logo while we render.  Rendering takes a while.
 430     my $logoframe=$toplevel->Canvas(width=>$actualx,height=>$actualy,
 431                                     borderwidth=>0,highlightthickness=>0,
 432                                     background=>'#404040')->
 433                                         place(-anchor=>"nw",'-x'=>0,'-y'=>0);
 434     if($actualx>$actualy){
 435         $logoframe->createImage($actualx/2,$actualy/2,
 436                                 -image=>$mgmlogoH,-anchor=>'center');
 437     }else{
 438         $logoframe->createImage($actualx/2,$actualy/2,
 439                                 -image=>$mgmlogoV,-anchor=>'center');
 440     }
 441     $toplevel->update();
 442
 443     # build the widgets in order, then render the new
 444     # instances. Destroy old widgets as they're no longer needed
 445
 446     foreach my $key (@ordered){
 447         my $mod=$instances{$key};
 448         if(defined($mod)){
 449             $mod->{"widget"}->destroy;
 450             undef $mod->{"widget"};
 451             my$ret=eval{$mod->module_run};
 452
 453             if(!defined($ret)){
 454                 print STDERR "Error eval()ing ->module_run for ".
 455                     ($mod->{"name"}).": $@\n";
 456             }else{
 457                 # destroy the resource dummy/old widget
 458                 $mod->{"widget"}=$ret; # must store the widget
 459             }
 460         }
 461         $i++;
 462         $toplevel->update();
 463         if($actualx!=$renderx || $actualy!=$rendery){last}
 464     }
 465
 466     # make the logo go away
 467
 468     $logoframe->destroy();
 469
 470     # map/schedule the new widgets
 471     foreach my $key (@ordered){
 472         my $mod=$instances{$key};
 473         if(defined($mod)){
 474             my$ret=$mod->{'widget'};
 475             if(defined($ret)){
 476                 $ret->place('-x'=>$mod->{'placex'},
 477                             '-y'=>$mod->{'placey'},-anchor=>'nw')
 478                     if(mplace($mod));
 479
 480                 my$refresh=$ret->optionGet("scalerefresh","");
 481                 $ret->repeat($refresh,sub{$mod->module_update})
 482                     if($refresh && ref($mod)->can('module_update'));
 483
 484             }
 485         }
 486     }
 487 }
 488
 489 # this could be reentrant as we do toplevel updates during rendering.
 490 # Make sure we DTRT.
 491
 492 # this is also called to render placemant and sizing for the initial
 493 # mapping of the the toplevel.
 494
 495 sub resize{
 496     my($toplevel,$width,$height)=@_;
 497
 498     if($width!=$actualx || $height!=$actualy){
 499
 500         # set size;
 501         $actualx=$width;
 502         $actualy=$height;
 503
 504         # create a new crop
 505         if(!$renderflag){
 506             # not async reentrant.  Don't need to worry about atomicity.
 507             $renderflag=1;
 508
 509             while($renderx!=$actualx || $rendery!=$actualy){
 510                 $renderx=$actualx;
 511                 $rendery=$actualy;
 512                 &build_and_run;
 513             }
 514             $renderflag=0;
 515         }
 516     }
 517 }
 518
 519 # this hook rebuilds all the module instances in case a reconfigure
 520 # happened.  Not especially efficient, but it's a drop int he bucket
 521 # compared to the full re-render that has to happen anyway.
 522
 523 sub reinstance{
 524
 525     # blow away the current instances.
 526     # unmap, undef each instance from instances.
 527     foreach my $key (keys %instances){
 528         my $mod=$instances{$key};
 529         if(defined($mod)){
 530             # call widget destructor
 531             $mod->{'widget'}->destroy;
 532             undef $mod->{'widget'};
 533
 534             # call instance destructor
 535             $mod->destroy() if (ref($mod)->can('destroy'));
 536
 537             # undef
 538             undef $instances{$key};
 539
 540         }
 541     }
 542
 543     # undef the ordering
 544     undef @ordered;
 545
 546     &order_modules;        # extract how many to build
 547     &instance_modules;     # make copies of the references and build
 548                            # complete instances
 549
 550     $actualx=-1;
 551     $actualy=-1;
 552     $renderx=-1;
 553     $rendery=-1;
 554     ($minx,$miny,$reqx,$reqy,$ladj,$wadj)=&geometries; #extract new geometry
 555
 556     # do we resize?  Our approach is clean but perhaps impractical; if
 557     # the geometry has been forced, we obey that even if the size is
 558     # below the forced minimums.  Thus a random reconfigure could
 559     # spontaneously break things.  eit.  Caveat user.
 560
 561     $toplevel->minsize($minx,$miny);
 562     $toplevel->resizable('TRUE','TRUE');
 563
 564     my$geometry=$toplevel->optionGet("geometry","");
 565     if(defined($geometry)){
 566         $geometry=~m{(\d*)x(\d*)};
 567         $reqx=$1;$reqy=$2;
 568     }else{
 569         $toplevel->optionAdd("$Xname.geometry",    $reqx.'x'.$reqy,20);
 570         $toplevel->geometry($reqx."x".$reqy);
 571     }
 572
 573     $toplevel->bind('MainWindow','<Configure>',[\&resize,Ev('w'),Ev('h')]);
 574
 575     # all set.  Build the widgets and start the timers
 576     &resize($toplevel,$reqx,$reqy);
 577 }
 578
 579 sub moption{
 580     my($mod,$option)=@_;
 581     $mod->{"widget"}->optionGet($option,"");
 582 }
 583
 584 sub mplace{
 585     my($mod)=@_;
 586     if(ref($mod)->can('module_place_p')){
 587         $mod->module_place_p();
 588     }else{
 589         1;
 590     }
 591 }