home *** CD-ROM | disk | FTP | other *** search
/ CD Actual Thematic 7: Programming / CDAT7.iso / Share / Editores / Perl5 / perl / lib / site / Tk / Wm.pm < prev    next >
Encoding:
Perl POD Document  |  1997-08-10  |  2.4 KB  |  104 lines
  1. # Copyright (c) 1995-1997 Nick Ing-Simmons. All rights reserved.
  2. # This program is free software; you can redistribute it and/or
  3. # modify it under the same terms as Perl itself.
  4. package Tk::Wm;
  5. use AutoLoader;
  6.  
  7. require Tk::Widget;
  8. *AUTOLOAD = \&Tk::Widget::AUTOLOAD;
  9.  
  10. use strict qw(vars);
  11.  
  12. # There are issues with this stuff now we have Tix's wm release/capture
  13. # as toplevel-ness is now dynamic.
  14.  
  15. use Tk::Submethods ( 'wm' => [qw(grid)] );
  16.  
  17. Direct Tk::Submethods ('wm' => [qw(aspect client colormapwindows command 
  18.                        deiconify focusmodel frame geometry group
  19.                        iconbitmap iconify iconmask iconname
  20.                        iconwindow maxsize minsize overrideredirect positionfrom
  21.                        protocol resizable saveunder sizefrom state title transient
  22.                        withdraw)]);
  23.  
  24. sub SetBindtags
  25. {
  26.  my ($obj) = @_;
  27.  $obj->bindtags([ref($obj),$obj,'all']);
  28. }
  29.  
  30. sub Populate
  31. {
  32.  my ($cw,$args) = @_;
  33.  $cw->ConfigSpecs('-overanchor' => ['PASSIVE',undef,undef,undef],
  34.                   '-popanchor'  => ['PASSIVE',undef,undef,undef],
  35.                   '-popover'    => ['PASSIVE',undef,undef,undef] 
  36.                  );
  37. }
  38.  
  39. 1;
  40.  
  41. __END__
  42.  
  43. sub Post
  44. {
  45.  my ($w,$X,$Y) = @_;
  46.  $X = int($X);
  47.  $Y = int($Y);
  48.  $w->geometry("+$X+$Y");
  49.  $w->deiconify;
  50.  $w->raise;
  51. }
  52.  
  53. sub AnchorAdjust
  54. {
  55.  my ($anchor,$X,$Y,$w,$h) = @_;
  56.  $anchor = 'c' unless (defined $anchor);
  57.  $Y += ($anchor =~ /s/) ? $h : ($anchor =~ /n/) ? 0 : $h/2;
  58.  $X += ($anchor =~ /e/) ? $w : ($anchor =~ /w/) ? 0 : $w/2;
  59.  return ($X,$Y);
  60. }
  61.  
  62. sub Popup
  63. {
  64.  my $w = shift;
  65.  $w->configure(@_) if @_;
  66.  $w->idletasks;
  67.  my ($mw,$mh) = ($w->reqwidth,$w->reqheight);
  68.  my ($rx,$ry,$rw,$rh) = (0,0,0,0);
  69.  my $base    = $w->cget('-popover');
  70.  my $outside = 0;
  71.  if (defined $base)
  72.   {
  73.    if ($base eq 'cursor')
  74.     {
  75.      ($rx,$ry) = $w->pointerxy;
  76.     }
  77.    else
  78.     {
  79.      $rx = $base->rootx; 
  80.      $ry = $base->rooty; 
  81.      $rw = $base->Width; 
  82.      $rh = $base->Height;
  83.     }
  84.   }
  85.  else
  86.   {
  87.    my $sc = $w->parent->toplevel;
  88.    $rx = -$sc->vrootx;
  89.    $ry = -$sc->vrooty;
  90.    $rw = $w->screenwidth;
  91.    $rh = $w->screenheight;
  92.   }
  93.  my ($X,$Y) = AnchorAdjust($w->cget('-overanchor'),$rx,$ry,$rw,$rh);
  94.  ($X,$Y)    = AnchorAdjust($w->cget('-popanchor'),$X,$Y,-$mw,-$mh);
  95.  $w->Post($X,$Y);
  96. }
  97.  
  98. sub iconposition
  99. {
  100.  my $w = shift;
  101.  return $w->wm('iconposition',$1,$2) if (@_ == 1 && $_[0] =~ /^(\d+),(\d+)$/); 
  102.  $w->wm('iconposition',@_);
  103. }
  104.