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