home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _0d6f4cd51b408a71c99d0c581d25bcc0 < prev    next >
Encoding:
Text File  |  2004-06-01  |  3.9 KB  |  175 lines
  1. # Copyright (c) 1995-2003 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.  
  16. use vars qw($VERSION);
  17. $VERSION = sprintf '4.%03d', q$Revision: #14 $ =~ /\D(\d+)\s*$/;
  18.  
  19. use Tk::Submethods;
  20.  
  21. *{Tk::Wm::wmGrid}    = sub { shift->wm("grid", @_) };
  22. *{Tk::Wm::wmTracing} = sub { shift->wm("tracing", @_) };
  23.  
  24. Direct Tk::Submethods ('wm' => [qw(aspect attributes client colormapwindows command
  25.                        deiconify focusmodel frame geometry group
  26.                        iconbitmap iconify iconimage iconmask iconname
  27.                        iconwindow maxsize minsize overrideredirect positionfrom
  28.                        protocol resizable sizefrom state title transient
  29.                        withdraw wrapper)]);
  30.         
  31. sub SetBindtags
  32. {
  33.  my ($obj) = @_;
  34.  $obj->bindtags([ref($obj),$obj,'all']);
  35. }
  36.  
  37. sub Populate
  38. {
  39.  my ($cw,$args) = @_;
  40.  $cw->ConfigSpecs('-overanchor' => ['PASSIVE',undef,undef,undef],
  41.                   '-popanchor'  => ['PASSIVE',undef,undef,undef],
  42.                   '-popover'    => ['PASSIVE',undef,undef,undef]
  43.                  );
  44. }
  45.  
  46. sub MoveResizeWindow
  47. {
  48.  my ($w,$x,$y,$width,$height) = @_;
  49.  $w->withdraw;
  50.  $w->geometry($width.'x'.$height);
  51.  $w->MoveToplevelWindow($x,$y);
  52.  $w->deiconify;
  53. }
  54.  
  55. sub WmDeleteWindow
  56. {
  57.  my ($w) = @_;
  58.  my $cb  = $w->protocol('WM_DELETE_WINDOW');
  59.  if (defined $cb)
  60.   {
  61.    $cb->Call;
  62.   }
  63.  else
  64.   {
  65.    $w->destroy;
  66.   }
  67. }
  68.  
  69.  
  70. 1;
  71.  
  72. __END__
  73.  
  74.  
  75. sub Post
  76. {
  77.  my ($w,$X,$Y) = @_;
  78.  $X = int($X);
  79.  $Y = int($Y);
  80.  $w->positionfrom('user');
  81.  $w->geometry("+$X+$Y");
  82.  # $w->MoveToplevelWindow($X,$Y);
  83.  $w->deiconify;
  84.  $w->raise;
  85. }
  86.  
  87. sub AnchorAdjust
  88. {
  89.  my ($anchor,$X,$Y,$w,$h) = @_;
  90.  $anchor = 'c' unless (defined $anchor);
  91.  $Y += ($anchor =~ /s/) ? $h : ($anchor =~ /n/) ? 0 : $h/2;
  92.  $X += ($anchor =~ /e/) ? $w : ($anchor =~ /w/) ? 0 : $w/2;
  93.  return ($X,$Y);
  94. }
  95.  
  96. sub Popup
  97. {
  98.  my $w = shift;
  99.  $w->configure(@_) if @_;
  100.  $w->idletasks;
  101.  my ($mw,$mh) = ($w->reqwidth,$w->reqheight);
  102.  my ($rx,$ry,$rw,$rh) = (0,0,0,0);
  103.  my $base    = $w->cget('-popover');
  104.  my $outside = 0;
  105.  if (defined $base)
  106.   {
  107.    if ($base eq 'cursor')
  108.     {
  109.      ($rx,$ry) = $w->pointerxy;
  110.     }
  111.    else
  112.     {
  113.      $rx = $base->rootx;
  114.      $ry = $base->rooty;
  115.      $rw = $base->Width;
  116.      $rh = $base->Height;
  117.     }
  118.   }
  119.  else
  120.   {
  121.    my $sc = ($w->parent) ? $w->parent->toplevel : $w;
  122.    $rx = -$sc->vrootx;
  123.    $ry = -$sc->vrooty;
  124.    $rw = $w->screenwidth;
  125.    $rh = $w->screenheight;
  126.   }
  127.  my ($X,$Y) = AnchorAdjust($w->cget('-overanchor'),$rx,$ry,$rw,$rh);
  128.  ($X,$Y)    = AnchorAdjust($w->cget('-popanchor'),$X,$Y,-$mw,-$mh);
  129.  # adjust to not cross screen borders
  130.  if ($X < 0) { $X = 0 }
  131.  if ($Y < 0) { $Y = 0 }
  132.  if ($mw > $w->screenwidth)  { $X = 0 }
  133.  if ($mh > $w->screenheight) { $Y = 0 }
  134.  $w->Post($X,$Y);
  135.  $w->waitVisibility;
  136. }
  137.  
  138. sub FullScreen
  139. {
  140.  my $w = shift;
  141.  my $over = (@_) ? shift : 0;
  142.  my $width  = $w->screenwidth;
  143.  my $height = $w->screenheight;
  144.  $w->GeometryRequest($width,$height);
  145.  $w->overrideredirect($over & 1);
  146.  $w->Post(0,0);
  147.  $w->update;
  148.  if ($over & 2)
  149.   {
  150.    my $x = $w->rootx;
  151.    my $y = $w->rooty;
  152.    $width -= 2*$x;
  153.    $height -= $x + $y;
  154.    $w->GeometryRequest($width,$height);
  155.    $w->update;
  156.   }
  157. }
  158.  
  159. sub iconposition
  160. {
  161.  my $w = shift;
  162.  if (@_ == 1)
  163.   {
  164.    return $w->wm('iconposition',$1,$2) if $_[0] =~ /^(\d+),(\d+)$/;
  165.    if ($_[0] =~ /^([+-])(\d+)([+-])(\d+)$/)
  166.     {
  167.      my $x = ($1 eq '-') ? $w->screenwidth-$2 : $2;
  168.      my $y = ($3 eq '-') ? $w->screenheight-$4 : $4;
  169.      return $w->wm('iconposition',$x,$y);
  170.     }
  171.   }
  172.  $w->wm('iconposition',@_);
  173. }
  174.  
  175.