Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | package Tk::Entry; |
2 | ||
3 | # Converted from entry.tcl -- | |
4 | # | |
5 | # This file defines the default bindings for Tk entry widgets. | |
6 | # | |
7 | # @(#) entry.tcl 1.22 94/12/17 16:05:14 | |
8 | # | |
9 | # Copyright (c) 1992-1994 The Regents of the University of California. | |
10 | # Copyright (c) 1994 Sun Microsystems, Inc. | |
11 | # Copyright (c) 1995-1999 Nick Ing-Simmons. All rights reserved. | |
12 | # This program is free software; you can redistribute it and/or | |
13 | ||
14 | use vars qw($VERSION); | |
15 | $VERSION = '3.037'; # $Id: //depot/Tk8/Entry/Entry.pm#37 $ | |
16 | ||
17 | # modify it under the same terms as Perl itself, subject | |
18 | # to additional disclaimer in license.terms due to partial | |
19 | # derivation from Tk4.0 sources. | |
20 | ||
21 | use Tk::Widget (); | |
22 | use Tk::Clipboard (); | |
23 | use base qw(Tk::Clipboard Tk::Widget); | |
24 | ||
25 | import Tk qw(Ev $XS_VERSION); | |
26 | ||
27 | Construct Tk::Widget 'Entry'; | |
28 | ||
29 | bootstrap Tk::Entry; | |
30 | ||
31 | sub Tk_cmd { \&Tk::entry } | |
32 | ||
33 | Tk::Methods('bbox','delete','get','icursor','index','insert','scan', | |
34 | 'selection','xview'); | |
35 | ||
36 | use Tk::Submethods ( 'selection' => [qw(clear range adjust present to from)], | |
37 | 'xview' => [qw(moveto scroll)], | |
38 | ); | |
39 | ||
40 | sub wordstart | |
41 | {my ($w,$pos) = @_; | |
42 | my $string = $w->get; | |
43 | $pos = $w->index('insert')-1 unless(defined $pos); | |
44 | $string = substr($string,0,$pos); | |
45 | $string =~ s/\S*$//; | |
46 | length $string; | |
47 | } | |
48 | ||
49 | sub wordend | |
50 | {my ($w,$pos) = @_; | |
51 | my $string = $w->get; | |
52 | my $anc = length $string; | |
53 | $pos = $w->index('insert') unless(defined $pos); | |
54 | $string = substr($string,$pos); | |
55 | $string =~ s/^(?:((?=\s)\s*|(?=\S)\S*))//x; | |
56 | $anc - length($string); | |
57 | } | |
58 | ||
59 | sub deltainsert | |
60 | { | |
61 | my ($w,$d) = @_; | |
62 | return $w->index('insert')+$d; | |
63 | } | |
64 | ||
65 | # | |
66 | # Bind -- | |
67 | # This procedure is invoked the first time the mouse enters an | |
68 | # entry widget or an entry widget receives the input focus. It creates | |
69 | # all of the class bindings for entries. | |
70 | # | |
71 | # Arguments: | |
72 | # event - Indicates which event caused the procedure to be invoked | |
73 | # (Enter or FocusIn). It is used so that we can carry out | |
74 | # the functions of that event in addition to setting up | |
75 | # bindings. | |
76 | sub ClassInit | |
77 | { | |
78 | my ($class,$mw) = @_; | |
79 | ||
80 | $class->SUPER::ClassInit($mw); | |
81 | ||
82 | # Standard Motif bindings: | |
83 | $mw->bind($class,'<Escape>','selectionClear'); | |
84 | ||
85 | $mw->bind($class,'<1>',['Button1',Ev('x')]); | |
86 | ||
87 | $mw->bind($class,'<B1-Motion>',['MouseSelect',Ev('x')]); | |
88 | ||
89 | $mw->bind($class,'<Double-1>',['MouseSelect',Ev('x'),'word','sel.first']); | |
90 | $mw->bind($class,'<Double-Shift-1>',['MouseSelect',Ev('x'),'word']); | |
91 | $mw->bind($class,'<Triple-1>',['MouseSelect',Ev('x'),'line',0]); | |
92 | $mw->bind($class,'<Triple-Shift-1>',['MouseSelect',Ev('x'),'line']); | |
93 | ||
94 | $mw->bind($class,'<Shift-1>','Shift_1'); | |
95 | ||
96 | ||
97 | $mw->bind($class,'<B1-Leave>',['AutoScan',Ev('x')]); | |
98 | $mw->bind($class,'<B1-Enter>','CancelRepeat'); | |
99 | $mw->bind($class,'<ButtonRelease-1>','CancelRepeat'); | |
100 | $mw->bind($class,'<Control-1>','Control_1'); | |
101 | $mw->bind($class,'<Left>', ['SetCursor',Ev('deltainsert',-1)]); | |
102 | $mw->bind($class,'<Right>',['SetCursor',Ev('deltainsert',1)]); | |
103 | $mw->bind($class,'<Shift-Left>',['KeySelect',Ev('deltainsert',-1)]); | |
104 | $mw->bind($class,'<Shift-Right>',['KeySelect',Ev('deltainsert',1)]); | |
105 | $mw->bind($class,'<Control-Left>',['SetCursor',Ev(['wordstart'])]); | |
106 | $mw->bind($class,'<Control-Right>',['SetCursor',Ev(['wordend'])]); | |
107 | $mw->bind($class,'<Shift-Control-Left>',['KeySelect',Ev(['wordstart'])]); | |
108 | $mw->bind($class,'<Shift-Control-Right>',['KeySelect',Ev(['wordend'])]); | |
109 | $mw->bind($class,'<Home>',['SetCursor',0]); | |
110 | $mw->bind($class,'<Shift-Home>',['KeySelect',0]); | |
111 | $mw->bind($class,'<End>',['SetCursor','end']); | |
112 | $mw->bind($class,'<Shift-End>',['KeySelect','end']); | |
113 | $mw->bind($class,'<Delete>','Delete'); | |
114 | ||
115 | $mw->bind($class,'<BackSpace>','Backspace'); | |
116 | ||
117 | $mw->bind($class,'<Control-space>',['selectionFrom','insert']); | |
118 | $mw->bind($class,'<Select>',['selectionFrom','insert']); | |
119 | $mw->bind($class,'<Control-Shift-space>',['selectionAdjust','insert']); | |
120 | $mw->bind($class,'<Shift-Select>',['selectionAdjust','insert']); | |
121 | ||
122 | $mw->bind($class,'<Control-slash>',['selectionRange',0,'end']); | |
123 | $mw->bind($class,'<Control-backslash>','selectionClear'); | |
124 | ||
125 | # $class->clipboardOperations($mw,qw[Copy Cut Paste]); | |
126 | ||
127 | $mw->bind($class,'<KeyPress>', ['Insert',Ev('A')]); | |
128 | ||
129 | # Ignore all Alt, Meta, and Control keypresses unless explicitly bound. | |
130 | # Otherwise, if a widget binding for one of these is defined, the | |
131 | # <KeyPress> class binding will also fire and insert the character, | |
132 | # which is wrong. Ditto for Return, and Tab. | |
133 | ||
134 | $mw->bind($class,'<Alt-KeyPress>' ,'NoOp'); | |
135 | $mw->bind($class,'<Meta-KeyPress>' ,'NoOp'); | |
136 | $mw->bind($class,'<Control-KeyPress>' ,'NoOp'); | |
137 | $mw->bind($class,'<Return>' ,'NoOp'); | |
138 | $mw->bind($class,'<KP_Enter>' ,'NoOp'); | |
139 | $mw->bind($class,'<Tab>' ,'NoOp'); | |
140 | ||
141 | $mw->bind($class,'<Insert>','InsertSelection'); | |
142 | if (!$Tk::strictMotif) | |
143 | { | |
144 | # Additional emacs-like bindings: | |
145 | $mw->bind($class,'<Control-a>',['SetCursor',0]); | |
146 | $mw->bind($class,'<Control-b>',['SetCursor',Ev('deltainsert',-1)]); | |
147 | $mw->bind($class,'<Control-d>',['delete','insert']); | |
148 | $mw->bind($class,'<Control-e>',['SetCursor','end']); | |
149 | $mw->bind($class,'<Control-f>',['SetCursor',Ev('deltainsert',1)]); | |
150 | $mw->bind($class,'<Control-h>','Backspace'); | |
151 | $mw->bind($class,'<Control-k>',['delete','insert','end']); | |
152 | ||
153 | $mw->bind($class,'<Control-t>','Transpose'); | |
154 | ||
155 | $mw->bind($class,'<Meta-b>',['SetCursor',Ev(['wordstart'])]); | |
156 | $mw->bind($class,'<Meta-d>',['delete','insert',Ev(['wordend'])]); | |
157 | $mw->bind($class,'<Meta-f>',['SetCursor',Ev(['wordend'])]); | |
158 | $mw->bind($class,'<Meta-BackSpace>',['delete',Ev(['wordstart']),'insert']); | |
159 | ||
160 | # A few additional bindings from John Ousterhout. | |
161 | $mw->bind($class,'<Control-w>',['delete',Ev(['wordstart']),'insert']); | |
162 | $mw->bind($class,'<2>','Button_2'); | |
163 | $mw->bind($class,'<B2-Motion>','B2_Motion'); | |
164 | $mw->bind($class,'<ButtonRelease-2>','ButtonRelease_2'); | |
165 | } | |
166 | return $class; | |
167 | } | |
168 | ||
169 | sub Shift_1 | |
170 | { | |
171 | my $w = shift; | |
172 | my $Ev = $w->XEvent; | |
173 | $Tk::selectMode = 'char'; | |
174 | $w->selectionAdjust('@' . $Ev->x) | |
175 | } | |
176 | ||
177 | ||
178 | sub Control_1 | |
179 | { | |
180 | my $w = shift; | |
181 | my $Ev = $w->XEvent; | |
182 | $w->icursor('@' . $Ev->x) | |
183 | } | |
184 | ||
185 | ||
186 | sub Delete | |
187 | { | |
188 | my $w = shift; | |
189 | if ($w->selectionPresent) | |
190 | { | |
191 | $w->deleteSelected | |
192 | } | |
193 | else | |
194 | { | |
195 | $w->delete('insert') | |
196 | } | |
197 | } | |
198 | ||
199 | ||
200 | sub InsertSelection | |
201 | { | |
202 | my $w = shift; | |
203 | eval {local $SIG{__DIE__}; $w->Insert($w->SelectionGet)} | |
204 | } | |
205 | ||
206 | ||
207 | sub Button_2 | |
208 | { | |
209 | my $w = shift; | |
210 | my $Ev = $w->XEvent; | |
211 | $w->scan('mark',$Ev->x); | |
212 | $Tk::x = $Ev->x; | |
213 | $Tk::y = $Ev->y; | |
214 | $Tk::mouseMoved = 0 | |
215 | } | |
216 | ||
217 | ||
218 | sub B2_Motion | |
219 | { | |
220 | my $w = shift; | |
221 | my $Ev = $w->XEvent; | |
222 | if (abs(($Ev->x-$Tk::x)) > 2) | |
223 | { | |
224 | $Tk::mouseMoved = 1 | |
225 | } | |
226 | $w->scan('dragto',$Ev->x) | |
227 | } | |
228 | ||
229 | ||
230 | sub ButtonRelease_2 | |
231 | { | |
232 | my $w = shift; | |
233 | my $Ev = $w->XEvent; | |
234 | if (!$Tk::mouseMoved) | |
235 | { | |
236 | eval | |
237 | {local $SIG{__DIE__}; | |
238 | $w->insert('insert',$w->SelectionGet); | |
239 | $w->SeeInsert; | |
240 | } | |
241 | } | |
242 | } | |
243 | ||
244 | # Button1 -- | |
245 | # This procedure is invoked to handle button-1 presses in entry | |
246 | # widgets. It moves the insertion cursor, sets the selection anchor, | |
247 | # and claims the input focus. | |
248 | # | |
249 | # Arguments: | |
250 | # w - The entry window in which the button was pressed. | |
251 | # x - The x-coordinate of the button press. | |
252 | sub Button1 | |
253 | { | |
254 | my $w = shift; | |
255 | my $x = shift; | |
256 | $Tk::selectMode = 'char'; | |
257 | $Tk::mouseMoved = 0; | |
258 | $Tk::pressX = $x; | |
259 | $w->icursor('@' . $x); | |
260 | $w->selectionFrom('@' . $x); | |
261 | $w->selectionClear; | |
262 | if ($w->cget('-state') eq 'normal') | |
263 | { | |
264 | $w->focus() | |
265 | } | |
266 | } | |
267 | # MouseSelect -- | |
268 | # This procedure is invoked when dragging out a selection with | |
269 | # the mouse. Depending on the selection mode (character, word, | |
270 | # line) it selects in different-sized units. This procedure | |
271 | # ignores mouse motions initially until the mouse has moved from | |
272 | # one character to another or until there have been multiple clicks. | |
273 | # | |
274 | # Arguments: | |
275 | # w - The entry window in which the button was pressed. | |
276 | # x - The x-coordinate of the mouse. | |
277 | sub MouseSelect | |
278 | { | |
279 | my $w = shift; | |
280 | my $x = shift; | |
281 | $Tk::selectMode = shift if (@_); | |
282 | my $cur = $w->index('@' . $x); | |
283 | return unless defined $cur; | |
284 | my $anchor = $w->index('anchor'); | |
285 | return unless defined $anchor; | |
286 | if (($cur != $anchor) || (abs($Tk::pressX - $x) >= 3)) | |
287 | { | |
288 | $Tk::mouseMoved = 1 | |
289 | } | |
290 | my $mode = $Tk::selectMode; | |
291 | return unless $mode; | |
292 | if ($mode eq 'char') | |
293 | { | |
294 | if ($Tk::mouseMoved) | |
295 | { | |
296 | if ($cur < $anchor) | |
297 | { | |
298 | $w->selectionTo($cur) | |
299 | } | |
300 | else | |
301 | { | |
302 | $w->selectionTo($cur+1) | |
303 | } | |
304 | } | |
305 | } | |
306 | elsif ($mode eq 'word') | |
307 | { | |
308 | if ($cur < $w->index('anchor')) | |
309 | { | |
310 | $w->selectionRange($w->wordstart($cur),$w->wordend($anchor-1)) | |
311 | } | |
312 | else | |
313 | { | |
314 | $w->selectionRange($w->wordstart($anchor),$w->wordend($cur)) | |
315 | } | |
316 | } | |
317 | elsif ($mode eq 'line') | |
318 | { | |
319 | $w->selectionRange(0,'end') | |
320 | } | |
321 | if (@_) | |
322 | { | |
323 | my $ipos = shift; | |
324 | eval {local $SIG{__DIE__}; $w->icursor($ipos) }; | |
325 | } | |
326 | $w->idletasks; | |
327 | } | |
328 | # AutoScan -- | |
329 | # This procedure is invoked when the mouse leaves an entry window | |
330 | # with button 1 down. It scrolls the window left or right, | |
331 | # depending on where the mouse is, and reschedules itself as an | |
332 | # 'after' command so that the window continues to scroll until the | |
333 | # mouse moves back into the window or the mouse button is released. | |
334 | # | |
335 | # Arguments: | |
336 | # w - The entry window. | |
337 | # x - The x-coordinate of the mouse when it left the window. | |
338 | sub AutoScan | |
339 | { | |
340 | my $w = shift; | |
341 | my $x = shift; | |
342 | if ($x >= $w->width) | |
343 | { | |
344 | $w->xview('scroll',2,'units') | |
345 | } | |
346 | elsif ($x < 0) | |
347 | { | |
348 | $w->xview('scroll',-2,'units') | |
349 | } | |
350 | else | |
351 | { | |
352 | return; | |
353 | } | |
354 | $w->MouseSelect($x); | |
355 | $w->RepeatId($w->after(50,['AutoScan',$w,$x])) | |
356 | } | |
357 | # KeySelect | |
358 | # This procedure is invoked when stroking out selections using the | |
359 | # keyboard. It moves the cursor to a new position, then extends | |
360 | # the selection to that position. | |
361 | # | |
362 | # Arguments: | |
363 | # w - The entry window. | |
364 | # new - A new position for the insertion cursor (the cursor hasn't | |
365 | # actually been moved to this position yet). | |
366 | sub KeySelect | |
367 | { | |
368 | my $w = shift; | |
369 | my $new = shift; | |
370 | if (!$w->selectionPresent) | |
371 | { | |
372 | $w->selectionFrom('insert'); | |
373 | $w->selectionTo($new) | |
374 | } | |
375 | else | |
376 | { | |
377 | $w->selectionAdjust($new) | |
378 | } | |
379 | $w->icursor($new); | |
380 | $w->SeeInsert; | |
381 | } | |
382 | # Insert -- | |
383 | # Insert a string into an entry at the point of the insertion cursor. | |
384 | # If there is a selection in the entry, and it covers the point of the | |
385 | # insertion cursor, then delete the selection before inserting. | |
386 | # | |
387 | # Arguments: | |
388 | # w - The entry window in which to insert the string | |
389 | # s - The string to insert (usually just a single character) | |
390 | sub Insert | |
391 | { | |
392 | my $w = shift; | |
393 | my $s = shift; | |
394 | return unless (defined $s && $s ne ''); | |
395 | eval | |
396 | {local $SIG{__DIE__}; | |
397 | my $insert = $w->index('insert'); | |
398 | if ($w->index('sel.first') <= $insert && $w->index('sel.last') >= $insert) | |
399 | { | |
400 | $w->deleteSelected | |
401 | } | |
402 | }; | |
403 | $w->insert('insert',$s); | |
404 | $w->SeeInsert | |
405 | } | |
406 | # Backspace -- | |
407 | # Backspace over the character just before the insertion cursor. | |
408 | # | |
409 | # Arguments: | |
410 | # w - The entry window in which to backspace. | |
411 | sub Backspace | |
412 | { | |
413 | my $w = shift; | |
414 | if ($w->selectionPresent) | |
415 | { | |
416 | $w->deleteSelected | |
417 | } | |
418 | else | |
419 | { | |
420 | my $x = $w->index('insert')-1; | |
421 | $w->delete($x) if ($x >= 0); | |
422 | } | |
423 | } | |
424 | # SeeInsert | |
425 | # Make sure that the insertion cursor is visible in the entry window. | |
426 | # If not, adjust the view so that it is. | |
427 | # | |
428 | # Arguments: | |
429 | # w - The entry window. | |
430 | sub SeeInsert | |
431 | { | |
432 | my $w = shift; | |
433 | my $c = $w->index('insert'); | |
434 | # | |
435 | # Probably a bug in your version of tcl/tk (I've not this problem | |
436 | # when I test Entry in the widget demo for tcl/tk) | |
437 | # index('\@0') give always 0. Consequence : | |
438 | # if you make <Control-E> or <Control-F> view is adapted | |
439 | # but with <Control-A> or <Control-B> view is not adapted | |
440 | # | |
441 | my $left = $w->index('@0'); | |
442 | if ($left > $c) | |
443 | { | |
444 | $w->xview($c); | |
445 | return; | |
446 | } | |
447 | my $x = $w->width; | |
448 | while ($w->index('@' . $x) <= $c && $left < $c) | |
449 | { | |
450 | $left += 1; | |
451 | $w->xview($left) | |
452 | } | |
453 | } | |
454 | # SetCursor | |
455 | # Move the insertion cursor to a given position in an entry. Also | |
456 | # clears the selection, if there is one in the entry, and makes sure | |
457 | # that the insertion cursor is visible. | |
458 | # | |
459 | # Arguments: | |
460 | # w - The entry window. | |
461 | # pos - The desired new position for the cursor in the window. | |
462 | sub SetCursor | |
463 | { | |
464 | my $w = shift; | |
465 | my $pos = shift; | |
466 | $w->icursor($pos); | |
467 | $w->selectionClear; | |
468 | $w->SeeInsert; | |
469 | } | |
470 | # Transpose | |
471 | # This procedure implements the 'transpose' function for entry widgets. | |
472 | # It tranposes the characters on either side of the insertion cursor, | |
473 | # unless the cursor is at the end of the line. In this case it | |
474 | # transposes the two characters to the left of the cursor. In either | |
475 | # case, the cursor ends up to the right of the transposed characters. | |
476 | # | |
477 | # Arguments: | |
478 | # w - The entry window. | |
479 | sub Transpose | |
480 | { | |
481 | my $w = shift; | |
482 | my $i = $w->index('insert'); | |
483 | $i++ if ($i < $w->index('end')); | |
484 | my $first = $i-2; | |
485 | return if ($first < 0); | |
486 | my $str = $w->get; | |
487 | my $new = substr($str,$i-1,1) . substr($str,$first,1); | |
488 | $w->delete($first,$i); | |
489 | $w->insert('insert',$new); | |
490 | $w->SeeInsert; | |
491 | } | |
492 | ||
493 | sub tabFocus | |
494 | { | |
495 | my $w = shift; | |
496 | $w->selectionRange(0,'end'); | |
497 | $w->icursor('end'); | |
498 | $w->SUPER::tabFocus; | |
499 | } | |
500 | ||
501 | sub getSelected | |
502 | { | |
503 | my $w = shift; | |
504 | return undef unless $w->selectionPresent; | |
505 | my $str = $w->get; | |
506 | my $show = $w->cget('-show'); | |
507 | $str = $show x length($str) if (defined $show); | |
508 | my $s = $w->index('sel.first'); | |
509 | my $e = $w->index('sel.last'); | |
510 | return substr($str,$s,$e+1-$s); | |
511 | } | |
512 | ||
513 | 1; | |
514 | ||
515 | __END__ | |
516 | ||
517 |