Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | # Copyright (c) 1995-1999 Nick Ing-Simmons. |
2 | # Copyright (c) 1999 Greg London. | |
3 | # All rights reserved. | |
4 | # This program is free software; you can redistribute it and/or | |
5 | # modify it under the same terms as Perl itself. | |
6 | package Tk::TextUndo; | |
7 | ||
8 | use vars qw($VERSION $DoDebug); | |
9 | $VERSION = '3.048'; # $Id: //depot/Tk8/Tk/TextUndo.pm#48 $ | |
10 | $DoDebug = 0; | |
11 | ||
12 | use Tk qw (Ev); | |
13 | use AutoLoader; | |
14 | ||
15 | use Tk::Text (); | |
16 | use base qw(Tk::Text); | |
17 | ||
18 | Construct Tk::Widget 'TextUndo'; | |
19 | ||
20 | sub ClassInit | |
21 | { | |
22 | my ($class,$mw) = @_; | |
23 | $mw->bind($class,'<<Undo>>','undo'); | |
24 | $mw->bind($class,'<<Redo>>','redo'); | |
25 | ||
26 | return $class->SUPER::ClassInit($mw); | |
27 | } | |
28 | ||
29 | ||
30 | #################################################################### | |
31 | # methods for manipulating the undo and redo stacks. | |
32 | # no one should directly access the stacks except for these methods. | |
33 | # everyone else must access the stacks through these methods. | |
34 | #################################################################### | |
35 | sub ResetUndo | |
36 | { | |
37 | my ($w) = @_; | |
38 | delete $w->{UNDO}; | |
39 | delete $w->{REDO}; | |
40 | } | |
41 | ||
42 | sub PushUndo | |
43 | { | |
44 | my $w = shift; | |
45 | $w->{UNDO} = [] unless (exists $w->{UNDO}); | |
46 | push(@{$w->{UNDO}},@_); | |
47 | } | |
48 | ||
49 | sub PushRedo | |
50 | { | |
51 | my $w = shift; | |
52 | $w->{REDO} = [] unless (exists $w->{REDO}); | |
53 | push(@{$w->{REDO}},@_); | |
54 | } | |
55 | ||
56 | sub PopUndo | |
57 | { | |
58 | my ($w) = @_; | |
59 | return pop(@{$w->{UNDO}}) if defined $w->{UNDO}; | |
60 | return undef; | |
61 | } | |
62 | ||
63 | sub PopRedo | |
64 | { | |
65 | my ($w) = @_; | |
66 | return pop(@{$w->{REDO}}) if defined $w->{REDO}; | |
67 | return undef; | |
68 | } | |
69 | ||
70 | sub ShiftRedo | |
71 | { | |
72 | my ($w) = @_; | |
73 | return shift(@{$w->{REDO}}) if defined $w->{REDO}; | |
74 | return undef; | |
75 | } | |
76 | ||
77 | sub numberChanges | |
78 | { | |
79 | my ($w) = @_; | |
80 | return 0 unless (exists $w->{'UNDO'}) and (defined($w->{'UNDO'})); | |
81 | return scalar(@{$w->{'UNDO'}}); | |
82 | } | |
83 | ||
84 | sub SizeRedo | |
85 | { | |
86 | my ($w) = @_; | |
87 | return 0 unless exists $w->{'REDO'}; | |
88 | return scalar(@{$w->{'REDO'}}); | |
89 | } | |
90 | ||
91 | sub getUndoAtIndex | |
92 | { | |
93 | my ($w,$index) = @_; | |
94 | return undef unless (exists $w->{UNDO}); | |
95 | return $w->{UNDO}[$index]; | |
96 | } | |
97 | ||
98 | sub getRedoAtIndex | |
99 | { | |
100 | my ($w,$index) = @_; | |
101 | return undef unless (exists $w->{REDO}); | |
102 | return $w->{REDO}[$index]; | |
103 | } | |
104 | ||
105 | #################################################################### | |
106 | # type "hello there" | |
107 | # hello there_ | |
108 | # hit UNDO | |
109 | # hello_ | |
110 | # type "out" | |
111 | # hello out_ | |
112 | # pressing REDO should not do anything | |
113 | # pressing UNDO should make "out" disappear. | |
114 | # pressing UNDO should make "there" reappear. | |
115 | # pressing UNDO should make "there" disappear. | |
116 | # pressing UNDO should make "hello" disappear. | |
117 | # | |
118 | # if there is anything in REDO stack and | |
119 | # the OperationMode is normal, (i.e. not in the middle of an ->undo or ->redo) | |
120 | # then before performing the current operation | |
121 | # take the REDO stack, and put it on UNDO stack | |
122 | # such that UNDO/REDO keystrokes will still make logical sense. | |
123 | # | |
124 | # call this method at the beginning of any overloaded method | |
125 | # which adds operations to the undo or redo stacks. | |
126 | # it will perform all the magic needed to handle the redo stack. | |
127 | #################################################################### | |
128 | sub CheckForRedoShuffle | |
129 | { | |
130 | my ($w) = @_; | |
131 | my $size_redo = $w->SizeRedo; | |
132 | return unless $size_redo && ($w->OperationMode eq 'normal'); | |
133 | # local $DoDebug = 1; | |
134 | ||
135 | # we are about to 'do' something new, but have something in REDO stack. | |
136 | # The REDOs may conflict with new ops, but we want to preserve them. | |
137 | # So convert them to UNDOs - effectively do them and their inverses | |
138 | # so net effect on the widget is no-change. | |
139 | ||
140 | $w->dump_array('StartShuffle'); | |
141 | ||
142 | $w->OperationMode('REDO_MAGIC'); | |
143 | $w->MarkSelectionsSavePositions; | |
144 | ||
145 | my @pvtundo; | |
146 | ||
147 | # go through REDO array from end downto 0, i.e. pseudo pop | |
148 | # then pretend we did 'redo' get inverse, and push into UNDO array | |
149 | # and 'do' the op. | |
150 | for (my $i=$size_redo-1; $i>=0 ; $i--) | |
151 | { | |
152 | my ($op,@args) = @{$w->getRedoAtIndex($i)}; | |
153 | my $op_undo = $op .'_UNDO'; | |
154 | # save the inverse of the op on the UNDO array | |
155 | # do this before the re-doing the op - after a 'delete' we cannot see | |
156 | # text we deleted! | |
157 | my $undo = $w->$op_undo(@args); | |
158 | $w->PushUndo($undo); | |
159 | # We must 'do' the operation now so if this is an insert | |
160 | # the text and tags are available for inspection in delete_UNDO, and | |
161 | # indices reflect changes. | |
162 | $w->$op(@args); | |
163 | # Save the undo that will reverse what we just did - it is | |
164 | # on the undo stack but will be tricky to find | |
165 | push(@pvtundo,$undo); | |
166 | } | |
167 | ||
168 | # Now shift each item off REDO array until empty | |
169 | # push each item onto UNDO array - this reverses the order | |
170 | # and we are not altering buffer so we cannot look in the | |
171 | # buffer to compute inverses - which is why we saved them above | |
172 | ||
173 | while ($w->SizeRedo) | |
174 | { | |
175 | my $ref = $w->ShiftRedo; | |
176 | $w->PushUndo($ref); | |
177 | } | |
178 | ||
179 | # Finally undo whatever we did to compensate for doing it | |
180 | # and get buffer back to state it was before we started. | |
181 | while (@pvtundo) | |
182 | { | |
183 | my ($op,@args) = @{pop(@pvtundo)}; | |
184 | $w->$op(@args); | |
185 | } | |
186 | ||
187 | $w->RestoreSelectionsMarkedSaved; | |
188 | $w->OperationMode('normal'); | |
189 | $w->dump_array('EndShuffle'); | |
190 | } | |
191 | ||
192 | # sets/returns undo/redo/normal operation mode | |
193 | sub OperationMode | |
194 | { | |
195 | my ($w,$mode) = @_; | |
196 | $w->{'OPERATION_MODE'} = $mode if (@_ > 1); | |
197 | $w->{'OPERATION_MODE'} = 'normal' unless exists($w->{'OPERATION_MODE'}); | |
198 | return $w->{'OPERATION_MODE'}; | |
199 | } | |
200 | ||
201 | #################################################################### | |
202 | # dump the undo and redo stacks to the screen. | |
203 | # used for debug purposes. | |
204 | sub dump_array | |
205 | { | |
206 | return unless $DoDebug; | |
207 | my ($w,$why) = @_; | |
208 | print "At $why:\n"; | |
209 | foreach my $key ('UNDO','REDO') | |
210 | { | |
211 | if (defined($w->{$key})) | |
212 | { | |
213 | print " $key array is:\n"; | |
214 | my $array = $w->{$key}; | |
215 | foreach my $ref (@$array) | |
216 | { | |
217 | my @items; | |
218 | foreach my $item (@$ref) | |
219 | { | |
220 | my $loc = $item; | |
221 | $loc =~ tr/\n/\^/; | |
222 | push(@items,$loc); | |
223 | } | |
224 | print " [",join(',',@items),"]\n"; | |
225 | } | |
226 | } | |
227 | } | |
228 | print "\n"; | |
229 | } | |
230 | ||
231 | ||
232 | ############################################################ | |
233 | ############################################################ | |
234 | # these are a group of methods used to indicate the start and end of | |
235 | # several operations that are to be undo/redo 'ed in a single step. | |
236 | # | |
237 | # in other words, "glob" a bunch of operations together. | |
238 | # | |
239 | # for example, a search and replace should be undone with a single | |
240 | # keystroke, rather than one keypress undoes the insert and another | |
241 | # undoes the delete. | |
242 | # all other methods should access the count via these methods. | |
243 | # no other method should directly access the {GLOB_COUNT} value directly | |
244 | ############################################################# | |
245 | ############################################################# | |
246 | ||
247 | sub AddOperation | |
248 | { | |
249 | my ($w,@operation) = @_; | |
250 | my $mode = $w->OperationMode; | |
251 | ||
252 | if ($mode eq 'normal') | |
253 | {$w->PushUndo([@operation]);} | |
254 | elsif ($mode eq 'undo') | |
255 | {$w->PushRedo([@operation]);} | |
256 | elsif ($mode eq 'redo') | |
257 | {$w->PushUndo([@operation]);} | |
258 | else | |
259 | {die "invalid destination '$mode', must be one of 'normal', 'undo' or 'redo'";} | |
260 | } | |
261 | ||
262 | sub addGlobStart # add it to end of undo list | |
263 | { | |
264 | my ($w, $who) = @_; | |
265 | unless (defined($who)) {$who = (caller(1))[3];} | |
266 | $w->CheckForRedoShuffle; | |
267 | $w->dump_array('Start'.$who); | |
268 | $w->AddOperation('GlobStart', $who) ; | |
269 | } | |
270 | ||
271 | sub addGlobEnd # add it to end of undo list | |
272 | { | |
273 | my ($w, $who) = @_; | |
274 | unless (defined($who)) {$who = (caller(1))[3];} | |
275 | my $topundo = $w->getUndoAtIndex(-1); | |
276 | if ($topundo->[0] eq 'GlobStart') | |
277 | { | |
278 | $w->PopUndo; | |
279 | } | |
280 | else | |
281 | { | |
282 | my $nxtundo = $w->getUndoAtIndex(-2); | |
283 | if ($nxtundo->[0] eq 'GlobStart') | |
284 | { | |
285 | $w->PopUndo; | |
286 | $w->PopUndo; | |
287 | $w->PushUndo($topundo); | |
288 | } | |
289 | else | |
290 | { | |
291 | $w->AddOperation('GlobEnd', $who); | |
292 | } | |
293 | } | |
294 | $w->dump_array('End'.$who); | |
295 | } | |
296 | ||
297 | sub GlobStart | |
298 | { | |
299 | my ($w, $who) = @_; | |
300 | unless (defined($w->{GLOB_COUNT})) {$w->{GLOB_COUNT}=0;} | |
301 | if ($w->OperationMode eq 'normal') | |
302 | { | |
303 | $w->PushUndo($w->GlobStart_UNDO($who)); | |
304 | } | |
305 | $w->{GLOB_COUNT} = $w->{GLOB_COUNT} + 1; | |
306 | } | |
307 | ||
308 | sub GlobStart_UNDO | |
309 | { | |
310 | my ($w, $who) = @_; | |
311 | $who = 'GlobEnd_UNDO' unless defined($who); | |
312 | return ['GlobEnd',$who]; | |
313 | } | |
314 | ||
315 | sub GlobEnd | |
316 | { | |
317 | my ($w, $who) = @_; | |
318 | unless (defined($w->{GLOB_COUNT})) {$w->{GLOB_COUNT}=0;} | |
319 | if ($w->OperationMode eq 'normal') | |
320 | { | |
321 | $w->PushUndo($w->GlobStart_UNDO($who)); | |
322 | } | |
323 | $w->{GLOB_COUNT} = $w->{GLOB_COUNT} - 1; | |
324 | } | |
325 | ||
326 | sub GlobEnd_UNDO | |
327 | { | |
328 | my ($w, $who) = @_; | |
329 | $who = 'GlobStart_UNDO' unless defined($who); | |
330 | return ['GlobStart',$who]; | |
331 | } | |
332 | ||
333 | sub GlobCount | |
334 | { | |
335 | my ($w,$count) = @_; | |
336 | unless ( exists($w->{'GLOB_COUNT'}) and defined($w->{'GLOB_COUNT'}) ) | |
337 | { | |
338 | $w->{'GLOB_COUNT'}=0; | |
339 | } | |
340 | if (defined($count)) | |
341 | { | |
342 | $w->{'GLOB_COUNT'}=$count; | |
343 | } | |
344 | return $w->{'GLOB_COUNT'}; | |
345 | } | |
346 | ||
347 | #################################################################### | |
348 | # two methods should be used by applications to access undo and redo | |
349 | # capability, namely, $w->undo; and $w->redo; methods. | |
350 | # these methods undo and redo the last operation, respectively. | |
351 | #################################################################### | |
352 | sub undo | |
353 | { | |
354 | my ($w) = @_; | |
355 | $w->dump_array('Start'.'undo'); | |
356 | unless ($w->numberChanges) {$w->bell; return;} # beep and return if empty | |
357 | $w->GlobCount(0); #initialize to zero | |
358 | $w->OperationMode('undo'); | |
359 | do | |
360 | { | |
361 | my ($op,@args) = @{$w->PopUndo}; # get undo operation, convert ref to array | |
362 | my $undo_op = $op .'_UNDO'; | |
363 | $w->PushRedo($w->$undo_op(@args)); # find out how to undo it | |
364 | $w->$op(@args); # do the operation | |
365 | } while($w->GlobCount and $w->numberChanges); | |
366 | $w->OperationMode('normal'); | |
367 | $w->dump_array('End'.'undo'); | |
368 | } | |
369 | ||
370 | sub redo | |
371 | { | |
372 | my ($w) = @_; | |
373 | unless ($w->SizeRedo) {$w->bell; return;} # beep and return if empty | |
374 | $w->OperationMode('redo'); | |
375 | $w->GlobCount(0); #initialize to zero | |
376 | do | |
377 | { | |
378 | my ($op,@args) = @{$w->PopRedo}; # get op from redo stack, convert to list | |
379 | my $undo_op = $op .'_UNDO'; | |
380 | $w->PushUndo($w->$undo_op(@args)); # figure out how to undo operation | |
381 | $w->$op(@args); # do the operation | |
382 | } while($w->GlobCount and $w->SizeRedo); | |
383 | $w->OperationMode('normal'); | |
384 | } | |
385 | ||
386 | ||
387 | ############################################################ | |
388 | # override low level subroutines so that they work with UNDO/REDO capability. | |
389 | # every overridden subroutine must also have a corresponding *_UNDO subroutine. | |
390 | # the *_UNDO method takes the same parameters in and returns an array reference | |
391 | # which is how to undo itself. | |
392 | # note that the *_UNDO must receive absolute indexes. | |
393 | # ->insert receives 'markname' as the starting index. | |
394 | # ->insert must convert 'markname' using $absindex=$w->index('markname') | |
395 | # and pass $absindex to ->insert_UNDO. | |
396 | ############################################################ | |
397 | ||
398 | sub insert | |
399 | { | |
400 | my $w = shift; | |
401 | $w->markSet('insert', $w->index(shift) ); | |
402 | while(@_) | |
403 | { | |
404 | my $index1 = $w->index('insert'); | |
405 | my $string = shift; | |
406 | my $taglist_ref = shift if @_; | |
407 | ||
408 | if ($w->OperationMode eq 'normal') | |
409 | { | |
410 | $w->CheckForRedoShuffle; | |
411 | $w->PushUndo($w->insert_UNDO($index1,$string,$taglist_ref)); | |
412 | } | |
413 | $w->markSet('notepos' => $index1); | |
414 | $w->SUPER::insert($index1,$string,$taglist_ref); | |
415 | $w->markSet('insert', $w->index('notepos')); | |
416 | } | |
417 | } | |
418 | ||
419 | sub insert_UNDO | |
420 | { | |
421 | my $w = shift; | |
422 | my $index = shift; | |
423 | my $string = ''; | |
424 | # This possible call: ->insert (index, string, tag, string, tag...); | |
425 | # if more than one string, keep reading strings in (discarding tags) | |
426 | # until all strings are read in and $string contains entire text inserted. | |
427 | while (@_) | |
428 | { | |
429 | $string .= shift; | |
430 | my $tags = shift if (@_); | |
431 | } | |
432 | # calculate index | |
433 | # possible things to insert: | |
434 | # carriage return | |
435 | # single character (not CR) | |
436 | # single line of characters (not ending in CR) | |
437 | # single line of characters ending with a CR | |
438 | # multi-line characters. last line does not end with CR | |
439 | # multi-line characters, last line does end with CR. | |
440 | my ($line,$col) = split(/\./,$index); | |
441 | if ($string =~ /\n(.*)$/) | |
442 | { | |
443 | $line += $string =~ tr/\n/\n/; | |
444 | $col = length($1); | |
445 | } | |
446 | else | |
447 | { | |
448 | $col += length($string); | |
449 | } | |
450 | return ['delete', $index, $line.'.'.$col]; | |
451 | } | |
452 | ||
453 | sub delete | |
454 | { | |
455 | my ($w, $start, $stop) = @_; | |
456 | unless(defined($stop)) | |
457 | { $stop = $start .'+1c'; } | |
458 | my $index1 = $w->index($start); | |
459 | my $index2 = $w->index($stop); | |
460 | if ($w->OperationMode eq 'normal') | |
461 | { | |
462 | $w->CheckForRedoShuffle; | |
463 | $w->PushUndo($w->delete_UNDO($index1,$index2)); | |
464 | } | |
465 | $w->SUPER::delete($index1,$index2); | |
466 | # why call SetCursor - it has side effects | |
467 | # which cause a whole slew if save/restore hassles ? | |
468 | $w->SetCursor($index1); | |
469 | } | |
470 | ||
471 | sub delete_UNDO | |
472 | { | |
473 | my ($w, $index1, $index2) = @_; | |
474 | my %tags; | |
475 | my @result = ( 'insert' => $index1 ); | |
476 | my $str = ''; | |
477 | ||
478 | ############################################################### | |
479 | # get tags in range and return them in a format that | |
480 | # can be inserted. | |
481 | # $text->insert('1.0', $string1, [tag1,tag2], $string2, [tag2, tag3]); | |
482 | # note, have to break tags up into sequential order | |
483 | # in reference to _all_ tags. | |
484 | ############################################################### | |
485 | ||
486 | $w->dump('-text','-tag', -command => sub { | |
487 | my ($kind,$value,$posn) = @_; | |
488 | if ($kind eq 'text') | |
489 | { | |
490 | $str .= $value; | |
491 | } | |
492 | else | |
493 | { | |
494 | push(@result,$str,[keys %tags]) if (length $str); | |
495 | $str = ''; | |
496 | if ($kind eq 'tagon') | |
497 | { | |
498 | $tags{$value} = 1; | |
499 | } | |
500 | elsif ($kind eq 'tagoff') | |
501 | { | |
502 | delete $tags{$value}; | |
503 | } | |
504 | } | |
505 | }, $index1, $index2); | |
506 | push(@result,$str,[keys %tags]) if (length $str); | |
507 | return \@result; | |
508 | } | |
509 | ||
510 | ############################################################ | |
511 | # override subroutines which are collections of low level | |
512 | # routines executed in sequence. | |
513 | # wrap a globstart and globend around the SUPER:: version of routine. | |
514 | ############################################################ | |
515 | ||
516 | sub ReplaceSelectionsWith | |
517 | { | |
518 | my $w = shift; | |
519 | $w->addGlobStart; | |
520 | $w->SUPER::ReplaceSelectionsWith(@_); | |
521 | $w->addGlobEnd; | |
522 | } | |
523 | ||
524 | sub FindAndReplaceAll | |
525 | { | |
526 | my $w = shift; | |
527 | $w->addGlobStart; | |
528 | $w->SUPER::FindAndReplaceAll(@_); | |
529 | $w->addGlobEnd; | |
530 | } | |
531 | ||
532 | sub clipboardCut | |
533 | { | |
534 | my $w = shift; | |
535 | $w->addGlobStart; | |
536 | $w->SUPER::clipboardCut(@_); | |
537 | $w->addGlobEnd; | |
538 | } | |
539 | ||
540 | sub clipboardPaste | |
541 | { | |
542 | my $w = shift; | |
543 | $w->addGlobStart; | |
544 | $w->SUPER::clipboardPaste(@_); | |
545 | $w->addGlobEnd; | |
546 | } | |
547 | ||
548 | sub clipboardColumnCut | |
549 | { | |
550 | my $w = shift; | |
551 | $w->addGlobStart; | |
552 | $w->SUPER::clipboardColumnCut(@_); | |
553 | $w->addGlobEnd; | |
554 | } | |
555 | ||
556 | sub clipboardColumnPaste | |
557 | { | |
558 | my $w = shift; | |
559 | $w->addGlobStart; | |
560 | $w->SUPER::clipboardColumnPaste(@_); | |
561 | $w->addGlobEnd; | |
562 | } | |
563 | ||
564 | # Greg: this method is more tightly coupled to the base class | |
565 | # than I would prefer, but I know of no other way to do it. | |
566 | ||
567 | sub Insert | |
568 | { | |
569 | my ($w,$char)=@_; | |
570 | return if $char eq ''; | |
571 | $w->addGlobStart; | |
572 | $w->SUPER::Insert($char); | |
573 | $w->addGlobEnd; | |
574 | } | |
575 | ||
576 | ||
577 | sub InsertKeypress | |
578 | { | |
579 | my ($w,$char)=@_; | |
580 | return if $char eq ''; | |
581 | if ($char =~ /^\S$/ and !$w->OverstrikeMode and !$w->tagRanges('sel')) | |
582 | { | |
583 | my $index = $w->index('insert'); | |
584 | my $undo_item = $w->getUndoAtIndex(-1); | |
585 | if (defined($undo_item) && | |
586 | ($undo_item->[0] eq 'delete') && | |
587 | ($undo_item->[2] == $index) | |
588 | ) | |
589 | { | |
590 | $w->SUPER::insert($index,$char); | |
591 | $undo_item->[2] = $w->index('insert'); | |
592 | return; | |
593 | } | |
594 | } | |
595 | $w->addGlobStart; | |
596 | $w->SUPER::InsertKeypress($char); | |
597 | $w->addGlobEnd; | |
598 | } | |
599 | ||
600 | ############################################################ | |
601 | sub TextUndoFileProgress | |
602 | { | |
603 | my ($w,$action,$filename,$count,$val,$total) = @_; | |
604 | return unless(defined($filename) and defined($count)); | |
605 | ||
606 | my $popup = $w->{'FILE_PROGRESS_POP_UP'}; | |
607 | unless (defined($popup)) | |
608 | { | |
609 | $w->update; | |
610 | $popup = $w->Toplevel(-title => "File Progress",-popover => $w); | |
611 | $popup->transient($w->toplevel); | |
612 | $popup->withdraw; | |
613 | $popup->resizable('no','no'); | |
614 | $popup->Label(-textvariable => \$popup->{ACTION})->pack; | |
615 | $popup->Label(-textvariable => \$popup->{FILENAME})->pack; | |
616 | $popup->Label(-textvariable => \$popup->{COUNT})->pack; | |
617 | my $f = $popup->Frame(-height => 10, -border => 2, -relief => 'sunken')->pack(-fill => 'x'); | |
618 | my $i = $f->Frame(-background => 'blue', -relief => 'raised', -border => 2); | |
619 | $w->{'FILE_PROGRESS_POP_UP'} = $popup; | |
620 | $popup->{PROGBAR} = $i; | |
621 | } | |
622 | $popup->{ACTION} = $action; | |
623 | $popup->{COUNT} = "lines: $count"; | |
624 | $popup->{FILENAME} = "Filename: $filename"; | |
625 | if (defined($val) && defined($total) && $total != 0) | |
626 | { | |
627 | $popup->{PROGBAR}->place('-x' => 0, '-y' => 0, -relheight => 1, -relwidth => $val/$total); | |
628 | } | |
629 | else | |
630 | { | |
631 | $popup->{PROGBAR}->placeForget; | |
632 | } | |
633 | ||
634 | $popup->idletasks; | |
635 | unless ($popup->viewable) | |
636 | { | |
637 | $w->idletasks; | |
638 | $w->toplevel->deiconify unless $w->viewable; | |
639 | $popup->Popup; | |
640 | } | |
641 | $popup->update; | |
642 | return $popup; | |
643 | } | |
644 | ||
645 | sub FileName | |
646 | { | |
647 | my ($w,$filename) = @_; | |
648 | if (@_ > 1) | |
649 | { | |
650 | $w->{'FILENAME'}=$filename; | |
651 | } | |
652 | return $w->{'FILENAME'}; | |
653 | } | |
654 | ||
655 | sub ConfirmDiscard | |
656 | { | |
657 | my ($w)=@_; | |
658 | if ($w->numberChanges) | |
659 | { | |
660 | my $ans = $w->messageBox(-icon => 'warning', | |
661 | -type => 'YesNoCancel', -default => 'Yes', | |
662 | -message => | |
663 | "The text has been modified without being saved. | |
664 | Save edits?"); | |
665 | return 0 if $ans eq 'Cancel'; | |
666 | return 0 if ($ans eq 'Yes' && !$w->Save); | |
667 | } | |
668 | return 1; | |
669 | } | |
670 | ||
671 | ################################################################################ | |
672 | # if the file has been modified since being saved, a pop up window will be | |
673 | # created, asking the user to confirm whether or not to exit. | |
674 | # this allows the user to return to the application and save the file. | |
675 | # the code would look something like this: | |
676 | # | |
677 | # if ($w->user_wants_to_exit) | |
678 | # {$w->ConfirmExit;} | |
679 | # | |
680 | # it is also possible to trap attempts to delete the main window. | |
681 | # this allows the ->ConfirmExit method to be called when the main window | |
682 | # is attempted to be deleted. | |
683 | # | |
684 | # $mw->protocol('WM_DELETE_WINDOW'=> | |
685 | # sub{$w->ConfirmExit;}); | |
686 | # | |
687 | # finally, it might be desirable to trap Control-C signals at the | |
688 | # application level so that ->ConfirmExit is also called. | |
689 | # | |
690 | # $SIG{INT}= sub{$w->ConfirmExit;}; | |
691 | # | |
692 | ################################################################################ | |
693 | ||
694 | sub ConfirmExit | |
695 | { | |
696 | my ($w) = @_; | |
697 | $w->toplevel->destroy if $w->ConfirmDiscard; | |
698 | } | |
699 | ||
700 | sub Save | |
701 | { | |
702 | my ($w,$filename) = @_; | |
703 | $filename = $w->FileName unless defined $filename; | |
704 | return $w->FileSaveAsPopup unless defined $filename; | |
705 | local *FILE; | |
706 | if (open(FILE,">$filename")) | |
707 | { | |
708 | my $status; | |
709 | my $count=0; | |
710 | my $index = '1.0'; | |
711 | my $progress; | |
712 | my ($lines) = $w->index('end') =~ /^(\d+)\./; | |
713 | while ($w->compare($index,'<','end')) | |
714 | { | |
715 | # my $end = $w->index("$index + 1024 chars"); | |
716 | my $end = $w->index("$index lineend +1c"); | |
717 | print FILE $w->get($index,$end); | |
718 | $index = $end; | |
719 | if (($count++%1000) == 0) | |
720 | { | |
721 | $progress = $w->TextUndoFileProgress (Saving => $filename,$count,$count,$lines); | |
722 | } | |
723 | } | |
724 | $progress->withdraw if defined $progress; | |
725 | if (close(FILE)) | |
726 | { | |
727 | $w->ResetUndo; | |
728 | $w->FileName($filename); | |
729 | return 1; | |
730 | } | |
731 | } | |
732 | else | |
733 | { | |
734 | $w->BackTrace("Cannot open $filename:$!"); | |
735 | } | |
736 | return 0; | |
737 | } | |
738 | ||
739 | sub Load | |
740 | { | |
741 | my ($w,$filename) = @_; | |
742 | $filename = $w->FileName unless (defined($filename)); | |
743 | return 0 unless defined $filename; | |
744 | local *FILE; | |
745 | if (open(FILE,"<$filename")) | |
746 | { | |
747 | $w->MainWindow->Busy; | |
748 | $w->EmptyDocument; | |
749 | my $count=1; | |
750 | my $progress; | |
751 | while (<FILE>) | |
752 | { | |
753 | $w->SUPER::insert('end',$_); | |
754 | if (($count++%1000) == 0) | |
755 | { | |
756 | $progress = $w->TextUndoFileProgress (Loading => $filename,$count,tell(FILE),-s $filename); | |
757 | } | |
758 | } | |
759 | close(FILE); | |
760 | $progress->withdraw if defined $progress; | |
761 | $w->markSet('insert' => '1.0'); | |
762 | $w->FileName($filename); | |
763 | $w->MainWindow->Unbusy; | |
764 | } | |
765 | else | |
766 | { | |
767 | $w->BackTrace("Cannot open $filename:$!"); | |
768 | } | |
769 | } | |
770 | ||
771 | sub IncludeFile | |
772 | { | |
773 | my ($w,$filename) = @_; | |
774 | unless (defined($filename)) | |
775 | {$w->BackTrace("filename not specified"); return;} | |
776 | if (open(FILE,"<$filename")) | |
777 | { | |
778 | $w->Busy; | |
779 | my $count=1; | |
780 | $w->addGlobStart; | |
781 | my $progress; | |
782 | while (<FILE>) | |
783 | { | |
784 | $w->insert('insert',$_); | |
785 | if (($count++%1000) == 0) | |
786 | { | |
787 | $progress = $w->TextUndoFileProgress(Including => $filename,$count,tell(FILE),-s $filename); | |
788 | } | |
789 | } | |
790 | $progress->withdraw if defined $progress; | |
791 | $w->addGlobEnd; | |
792 | close(FILE); | |
793 | $w->Unbusy; | |
794 | } | |
795 | else | |
796 | { | |
797 | $w->BackTrace("Cannot open $filename:$!"); | |
798 | } | |
799 | } | |
800 | ||
801 | # clear document without pushing it into UNDO array, (use SUPER::delete) | |
802 | # (using plain delete(1.0,end) on a really big document fills up the undo array) | |
803 | # and then clear the Undo and Redo stacks. | |
804 | sub EmptyDocument | |
805 | { | |
806 | my ($w) = @_; | |
807 | $w->SUPER::delete('1.0','end'); | |
808 | $w->ResetUndo; | |
809 | $w->FileName(undef); | |
810 | } | |
811 | ||
812 | sub ConfirmEmptyDocument | |
813 | { | |
814 | my ($w)=@_; | |
815 | $w->EmptyDocument if $w->ConfirmDiscard; | |
816 | } | |
817 | ||
818 | sub FileMenuItems | |
819 | { | |
820 | my ($w) = @_; | |
821 | return [ | |
822 | ["command"=>'~Open', -command => [$w => 'FileLoadPopup']], | |
823 | ["command"=>'~Save', -command => [$w => 'Save' ]], | |
824 | ["command"=>'Save ~As', -command => [$w => 'FileSaveAsPopup']], | |
825 | ["command"=>'~Include', -command => [$w => 'IncludeFilePopup']], | |
826 | ["command"=>'~Clear', -command => [$w => 'ConfirmEmptyDocument']], | |
827 | "-",@{$w->SUPER::FileMenuItems} | |
828 | ] | |
829 | } | |
830 | ||
831 | sub EditMenuItems | |
832 | { | |
833 | my ($w) = @_; | |
834 | ||
835 | return [ | |
836 | ["command"=>'Undo', -command => [$w => 'undo']], | |
837 | ["command"=>'Redo', -command => [$w => 'redo']], | |
838 | "-",@{$w->SUPER::EditMenuItems} | |
839 | ]; | |
840 | } | |
841 | ||
842 | sub CreateFileSelect | |
843 | { | |
844 | my $w = shift; | |
845 | my $k = shift; | |
846 | my $name = $w->FileName; | |
847 | my @types = (['All Files', '*']); | |
848 | my $dir = undef; | |
849 | if (defined $name) | |
850 | { | |
851 | require File::Basename; | |
852 | my $sfx; | |
853 | ($name,$dir,$sfx) = File::Basename::fileparse($name,'\..*'); | |
854 | if (defined($sfx) && length($sfx)) | |
855 | { | |
856 | unshift(@types,['Similar Files',[$sfx]]); | |
857 | $name .= $sfx; | |
858 | } | |
859 | } | |
860 | return $w->$k(-initialdir => $dir, -initialfile => $name, | |
861 | -filetypes => \@types, @_); | |
862 | } | |
863 | ||
864 | sub FileLoadPopup | |
865 | { | |
866 | my ($w)=@_; | |
867 | my $name = $w->CreateFileSelect('getOpenFile',-title => 'File Load'); | |
868 | return $w->Load($name) if defined($name) and length($name); | |
869 | return 0; | |
870 | } | |
871 | ||
872 | sub IncludeFilePopup | |
873 | { | |
874 | my ($w)=@_; | |
875 | my $name = $w->CreateFileSelect('getOpenFile',-title => 'File Include'); | |
876 | return $w->IncludeFile($name) if defined($name) and length($name); | |
877 | return 0; | |
878 | } | |
879 | ||
880 | sub FileSaveAsPopup | |
881 | { | |
882 | my ($w)=@_; | |
883 | my $name = $w->CreateFileSelect('getSaveFile',-title => 'File Save As'); | |
884 | return $w->Save($name) if defined($name) and length($name); | |
885 | return 0; | |
886 | } | |
887 | ||
888 | ||
889 | sub MarkSelectionsSavePositions | |
890 | { | |
891 | my ($w)=@_; | |
892 | $w->markSet('MarkInsertSavePosition','insert'); | |
893 | my @ranges = $w->tagRanges('sel'); | |
894 | my $i = 0; | |
895 | while (@ranges) | |
896 | { | |
897 | my ($start,$end) = splice(@ranges,0,2); | |
898 | $w->markSet( 'MarkSelectionsSavePositions_'.++$i, $start); | |
899 | $w->markSet( 'MarkSelectionsSavePositions_'.++$i, $end); | |
900 | $w->tagRemove('sel',$start,$end); | |
901 | } | |
902 | } | |
903 | ||
904 | sub RestoreSelectionsMarkedSaved | |
905 | { | |
906 | my ($w)=@_; | |
907 | my $i = 0; | |
908 | my %mark_hash; | |
909 | foreach my $mark ($w->markNames) | |
910 | { | |
911 | $mark_hash{$mark}=1; | |
912 | } | |
913 | while(1) | |
914 | { | |
915 | my $markstart = 'MarkSelectionsSavePositions_'.$i++; | |
916 | last unless(exists($mark_hash{$markstart})); | |
917 | my $indexstart = $w->index($markstart); | |
918 | my $markend = 'MarkSelectionsSavePositions_'.$i++; | |
919 | last unless(exists($mark_hash{$markend})); | |
920 | my $indexend = $w->index($markend); | |
921 | $w->tagAdd('sel',$indexstart, $indexend); | |
922 | $w->markUnset($markstart, $markend); | |
923 | } | |
924 | $w->markSet('insert','MarkInsertSavePosition'); | |
925 | } | |
926 | ||
927 | #################################################################### | |
928 | # selected lines may be discontinous sequence. | |
929 | sub SelectedLineNumbers | |
930 | { | |
931 | my ($w) = @_; | |
932 | my @ranges = $w->tagRanges('sel'); | |
933 | my @selection_list; | |
934 | while (@ranges) | |
935 | { | |
936 | my ($first) = split(/\./,shift(@ranges)); | |
937 | my ($last) = split(/\./,shift(@ranges)); | |
938 | # if previous selection ended on the same line that this selection starts, | |
939 | # then fiddle the numbers so that this line number isnt included twice. | |
940 | if (defined($selection_list[-1]) and ($first == $selection_list[-1])) | |
941 | { | |
942 | # if this selection ends on the same line its starts, then skip this sel | |
943 | next if ($first == $last); | |
944 | $first++; # count this selection starting from the next line. | |
945 | } | |
946 | push(@selection_list, $first .. $last); | |
947 | } | |
948 | return @selection_list; | |
949 | } | |
950 | ||
951 | sub insertStringAtStartOfSelectedLines | |
952 | { | |
953 | my ($w,$insert_string)=@_; | |
954 | $w->addGlobStart; | |
955 | $w->MarkSelectionsSavePositions; | |
956 | foreach my $line ($w->SelectedLineNumbers) | |
957 | { | |
958 | $w->insert($line.'.0', $insert_string); | |
959 | } | |
960 | $w->RestoreSelectionsMarkedSaved; | |
961 | $w->addGlobEnd; | |
962 | } | |
963 | ||
964 | sub deleteStringAtStartOfSelectedLines | |
965 | { | |
966 | my ($w,$insert_string)=@_; | |
967 | $w->addGlobStart; | |
968 | $w->MarkSelectionsSavePositions; | |
969 | my $length = length($insert_string); | |
970 | foreach my $line ($w->SelectedLineNumbers) | |
971 | { | |
972 | my $start = $line.'.0'; | |
973 | my $end = $line.'.'.$length; | |
974 | my $current_text = $w->get($start, $end); | |
975 | next unless ($current_text eq $insert_string); | |
976 | $w->delete($start, $end); | |
977 | } | |
978 | $w->RestoreSelectionsMarkedSaved; | |
979 | $w->addGlobEnd; | |
980 | } | |
981 | ||
982 | ||
983 | 1; | |
984 | __END__ | |
985 |