1# Conversion from Tk4.0 scrollbar.tcl competed. 2package Tk::Scrollbar; 3 4use vars qw($VERSION); 5$VERSION = '4.010'; # $Id: //depot/Tkutf8/Scrollbar/Scrollbar.pm#10 $ 6 7use Tk qw($XS_VERSION Ev); 8use AutoLoader; 9 10use base qw(Tk::Widget); 11 12#use strict; 13#use vars qw($pressX $pressY @initValues $initPos $activeBg); 14 15Construct Tk::Widget 'Scrollbar'; 16 17bootstrap Tk::Scrollbar; 18 19sub Tk_cmd { \&Tk::scrollbar } 20 21Tk::Methods('activate','delta','fraction','get','identify','set'); 22 23sub Needed 24{ 25 my ($sb) = @_; 26 my @val = $sb->get; 27 return 1 unless (@val == 2); 28 return 1 if $val[0] != 0.0; 29 return 1 if $val[1] != 1.0; 30 return 0; 31} 32 33 34sub ClassInit 35{ 36 my ($class,$mw) = @_; 37 $mw->bind($class, '<Enter>', 'Enter'); 38 $mw->bind($class, '<Motion>', 'Motion'); 39 $mw->bind($class, '<Leave>', 'Leave'); 40 41 $mw->bind($class, '<1>', 'ButtonDown'); 42 $mw->bind($class, '<B1-Motion>', ['Drag', Ev('x'), Ev('y')]); 43 $mw->bind($class, '<ButtonRelease-1>', 'ButtonUp'); 44 $mw->bind($class, '<B1-Leave>', 'NoOp'); # prevent generic <Leave> 45 $mw->bind($class, '<B1-Enter>', 'NoOp'); # prevent generic <Enter> 46 $mw->bind($class, '<Control-1>', 'ScrlTopBottom'); 47 48 $mw->bind($class, '<2>', 'ButtonDown'); 49 $mw->bind($class, '<B2-Motion>', ['Drag', Ev('x'), Ev('y')]); 50 $mw->bind($class, '<ButtonRelease-2>', 'ButtonUp'); 51 $mw->bind($class, '<B2-Leave>', 'NoOp'); # prevent generic <Leave> 52 $mw->bind($class, '<B2-Enter>', 'NoOp'); # prevent generic <Enter> 53 $mw->bind($class, '<Control-2>', 'ScrlTopBottom'); 54 55 $mw->bind($class, '<Up>', ['ScrlByUnits','v',-1]); 56 $mw->bind($class, '<Down>', ['ScrlByUnits','v', 1]); 57 $mw->bind($class, '<Control-Up>', ['ScrlByPages','v',-1]); 58 $mw->bind($class, '<Control-Down>', ['ScrlByPages','v', 1]); 59 60 $mw->bind($class, '<Left>', ['ScrlByUnits','h',-1]); 61 $mw->bind($class, '<Right>', ['ScrlByUnits','h', 1]); 62 $mw->bind($class, '<Control-Left>', ['ScrlByPages','h',-1]); 63 $mw->bind($class, '<Control-Right>', ['ScrlByPages','h', 1]); 64 65 $mw->bind($class, '<Prior>', ['ScrlByPages','hv',-1]); 66 $mw->bind($class, '<Next>', ['ScrlByPages','hv', 1]); 67 68 # X11 mousewheel - honour for horizontal too. 69 $mw->bind($class, '<4>', ['ScrlByUnits','hv',-5]); 70 $mw->bind($class, '<5>', ['ScrlByUnits','hv', 5]); 71 72 $mw->bind($class, '<Home>', ['ScrlToPos', 0]); 73 $mw->bind($class, '<End>', ['ScrlToPos', 1]); 74 75 $mw->bind($class, '<4>', ['ScrlByUnits','v',-3]); 76 $mw->bind($class, '<5>', ['ScrlByUnits','v', 3]); 77 78 return $class; 79 80} 81 821; 83 84__END__ 85 86sub Enter 87{ 88 my $w = shift; 89 my $e = $w->XEvent; 90 if ($Tk::strictMotif) 91 { 92 my $bg = $w->cget('-background'); 93 $activeBg = $w->cget('-activebackground'); 94 $w->configure('-activebackground' => $bg); 95 } 96 $w->activate($w->identify($e->x,$e->y)); 97} 98 99sub Leave 100{ 101 my $w = shift; 102 if ($Tk::strictMotif) 103 { 104 $w->configure('-activebackground' => $activeBg) if (defined $activeBg) ; 105 } 106 $w->activate(''); 107} 108 109sub Motion 110{ 111 my $w = shift; 112 my $e = $w->XEvent; 113 $w->activate($w->identify($e->x,$e->y)); 114} 115 116# tkScrollButtonDown -- 117# This procedure is invoked when a button is pressed in a scrollbar. 118# It changes the way the scrollbar is displayed and takes actions 119# depending on where the mouse is. 120# 121# Arguments: 122# w - The scrollbar widget. 123# x, y - Mouse coordinates. 124 125sub ButtonDown 126{my $w = shift; 127 my $e = $w->XEvent; 128 my $element = $w->identify($e->x,$e->y); 129 $w->configure('-activerelief' => 'sunken'); 130 if ($e->b == 1 and 131 (defined($element) && $element eq 'slider')) 132 { 133 $w->StartDrag($e->x,$e->y); 134 } 135 elsif ($e->b == 2 and 136 (defined($element) && $element =~ /^(trough[12]|slider)$/o)) 137 { 138 my $pos = $w->fraction($e->x, $e->y); 139 my($head, $tail) = $w->get; 140 my $len = $tail - $head; 141 142 $head = $pos - $len/2; 143 $tail = $pos + $len/2; 144 if ($head < 0) { 145 $head = 0; 146 $tail = $len; 147 } 148 elsif ($tail > 1) { 149 $head = 1 - $len; 150 $tail = 1; 151 } 152 $w->ScrlToPos($head); 153 $w->set($head, $tail); 154 155 $w->StartDrag($e->x,$e->y); 156 } 157 else 158 { 159 $w->Select($element,'initial'); 160 } 161} 162 163# tkScrollButtonUp -- 164# This procedure is invoked when a button is released in a scrollbar. 165# It cancels scans and auto-repeats that were in progress, and restores 166# the way the active element is displayed. 167# 168# Arguments: 169# w - The scrollbar widget. 170# x, y - Mouse coordinates. 171 172sub ButtonUp 173{my $w = shift; 174 my $e = $w->XEvent; 175 $w->CancelRepeat; 176 $w->configure('-activerelief' => 'raised'); 177 $w->EndDrag($e->x,$e->y); 178 $w->activate($w->identify($e->x,$e->y)); 179} 180 181# tkScrollSelect -- 182# This procedure is invoked when button 1 is pressed over the scrollbar. 183# It invokes one of several scrolling actions depending on where in 184# the scrollbar the button was pressed. 185# 186# Arguments: 187# w - The scrollbar widget. 188# element - The element of the scrollbar that was selected, such 189# as "arrow1" or "trough2". Shouldn't be "slider". 190# repeat - Whether and how to auto-repeat the action: "noRepeat" 191# means don't auto-repeat, "initial" means this is the 192# first action in an auto-repeat sequence, and "again" 193# means this is the second repetition or later. 194 195sub Select 196{ 197 my $w = shift; 198 my $element = shift; 199 my $repeat = shift; 200 return unless defined ($element); 201 if ($element eq 'arrow1') 202 { 203 $w->ScrlByUnits('hv',-1); 204 } 205 elsif ($element eq 'trough1') 206 { 207 $w->ScrlByPages('hv',-1); 208 } 209 elsif ($element eq 'trough2') 210 { 211 $w->ScrlByPages('hv', 1); 212 } 213 elsif ($element eq 'arrow2') 214 { 215 $w->ScrlByUnits('hv', 1); 216 } 217 else 218 { 219 return; 220 } 221 222 if ($repeat eq 'again') 223 { 224 $w->RepeatId($w->after($w->cget('-repeatinterval'),['Select',$w,$element,'again'])); 225 } 226 elsif ($repeat eq 'initial') 227 { 228 $w->RepeatId($w->after($w->cget('-repeatdelay'),['Select',$w,$element,'again'])); 229 } 230} 231 232# tkScrollStartDrag -- 233# This procedure is called to initiate a drag of the slider. It just 234# remembers the starting position of the slider. 235# 236# Arguments: 237# w - The scrollbar widget. 238# x, y - The mouse position at the start of the drag operation. 239 240sub StartDrag 241{ 242 my($w,$x,$y) = @_; 243 return unless (defined ($w->cget('-command'))); 244 $pressX = $x; 245 $pressY = $y; 246 @initValues = $w->get; 247 my $iv0 = $initValues[0]; 248 if (@initValues == 2) 249 { 250 $initPos = $iv0; 251 } 252 elsif ($iv0 == 0) 253 { 254 $initPos = 0; 255 } 256 else 257 { 258 $initPos = $initValues[2]/$initValues[0]; 259 } 260} 261 262# tkScrollDrag -- 263# This procedure is called for each mouse motion even when the slider 264# is being dragged. It notifies the associated widget if we're not 265# jump scrolling, and it just updates the scrollbar if we are jump 266# scrolling. 267# 268# Arguments: 269# w - The scrollbar widget. 270# x, y - The current mouse position. 271 272sub Drag 273{ 274 my($w,$x,$y) = @_; 275 return if !defined $initPos; 276 my $delta = $w->delta($x-$pressX, $y-$pressY); 277 if ($w->cget('-jump')) 278 { 279 if (@initValues == 2) 280 { 281 $w->set($initValues[0]+$delta, $initValues[1]+$delta); 282 } 283 else 284 { 285 $delta = sprintf "%d", $delta * $initValues[0]; # round() 286 $initValues[2] += $delta; 287 $initValues[3] += $delta; 288 $w->set(@initValues[2,3]); 289 } 290 } 291 else 292 { 293 $w->ScrlToPos($initPos+$delta); 294 } 295} 296 297# tkScrollEndDrag -- 298# This procedure is called to end an interactive drag of the slider. 299# It scrolls the window if we're in jump mode, otherwise it does nothing. 300# 301# Arguments: 302# w - The scrollbar widget. 303# x, y - The mouse position at the end of the drag operation. 304 305sub EndDrag 306{ 307 my($w,$x,$y) = @_; 308 return if (!defined $initPos); 309 if ($w->cget('-jump')) 310 { 311 my $delta = $w->delta($x-$pressX, $y-$pressY); 312 $w->ScrlToPos($initPos+$delta); 313 } 314 undef $initPos; 315} 316 317# tkScrlByUnits -- 318# This procedure tells the scrollbar's associated widget to scroll up 319# or down by a given number of units. It notifies the associated widget 320# in different ways for old and new command syntaxes. 321# 322# Arguments: 323# w - The scrollbar widget. 324# orient - Which kinds of scrollbars this applies to: "h" for 325# horizontal, "v" for vertical, "hv" for both. 326# amount - How many units to scroll: typically 1 or -1. 327 328sub ScrlByUnits 329{my $w = shift; 330 my $orient = shift; 331 my $amount = shift; 332 my $cmd = $w->cget('-command'); 333 return unless (defined $cmd); 334 return if (index($orient,substr($w->cget('-orient'),0,1)) < 0); 335 my @info = $w->get; 336 if (@info == 2) 337 { 338 $cmd->Call('scroll',$amount,'units'); 339 } 340 else 341 { 342 $cmd->Call($info[2]+$amount); 343 } 344} 345 346# tkScrlByPages -- 347# This procedure tells the scrollbar's associated widget to scroll up 348# or down by a given number of screenfuls. It notifies the associated 349# widget in different ways for old and new command syntaxes. 350# 351# Arguments: 352# w - The scrollbar widget. 353# orient - Which kinds of scrollbars this applies to: "h" for 354# horizontal, "v" for vertical, "hv" for both. 355# amount - How many screens to scroll: typically 1 or -1. 356 357sub ScrlByPages 358{ 359 my $w = shift; 360 my $orient = shift; 361 my $amount = shift; 362 my $cmd = $w->cget('-command'); 363 return unless (defined $cmd); 364 return if (index($orient,substr($w->cget('-orient'),0,1)) < 0); 365 my @info = $w->get; 366 if (@info == 2) 367 { 368 $cmd->Call('scroll',$amount,'pages'); 369 } 370 else 371 { 372 $cmd->Call($info[2]+$amount*($info[1]-1)); 373 } 374} 375 376# tkScrlToPos -- 377# This procedure tells the scrollbar's associated widget to scroll to 378# a particular location, given by a fraction between 0 and 1. It notifies 379# the associated widget in different ways for old and new command syntaxes. 380# 381# Arguments: 382# w - The scrollbar widget. 383# pos - A fraction between 0 and 1 indicating a desired position 384# in the document. 385 386sub ScrlToPos 387{ 388 my $w = shift; 389 my $pos = shift; 390 my $cmd = $w->cget('-command'); 391 return unless (defined $cmd); 392 my @info = $w->get; 393 if (@info == 2) 394 { 395 $cmd->Call('moveto',$pos); 396 } 397 else 398 { 399 $cmd->Call(int($info[0]*$pos)); 400 } 401} 402 403# tkScrlTopBottom 404# Scroll to the top or bottom of the document, depending on the mouse 405# position. 406# 407# Arguments: 408# w - The scrollbar widget. 409# x, y - Mouse coordinates within the widget. 410 411sub ScrlTopBottom 412{ 413 my $w = shift; 414 my $e = $w->XEvent; 415 my $element = $w->identify($e->x,$e->y); 416 return unless ($element); 417 if ($element =~ /1$/) 418 { 419 $w->ScrlToPos(0); 420 } 421 elsif ($element =~ /2$/) 422 { 423 $w->ScrlToPos(1); 424 } 425} 426 427 428 429 430