1# Copyright (c) 1995-2004 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.
6package Tk::TextUndo;
7
8use vars qw($VERSION $DoDebug);
9$VERSION = '4.015'; # $Id: //depot/Tkutf8/Tk/TextUndo.pm#15 $
10$DoDebug = 0;
11
12use Tk qw (Ev);
13use AutoLoader;
14
15use Tk::Text ();
16use base qw(Tk::Text);
17
18Construct Tk::Widget 'TextUndo';
19
20sub 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####################################################################
35sub ResetUndo
36{
37 my ($w) = @_;
38 delete $w->{UNDO};
39 delete $w->{REDO};
40}
41
42sub PushUndo
43{
44 my $w = shift;
45 $w->{UNDO} = [] unless (exists $w->{UNDO});
46 push(@{$w->{UNDO}},@_);
47}
48
49sub PushRedo
50{
51 my $w = shift;
52 $w->{REDO} = [] unless (exists $w->{REDO});
53 push(@{$w->{REDO}},@_);
54}
55
56sub PopUndo
57{
58 my ($w) = @_;
59 return pop(@{$w->{UNDO}}) if defined $w->{UNDO};
60 return undef;
61}
62
63sub PopRedo
64{
65 my ($w) = @_;
66 return pop(@{$w->{REDO}}) if defined $w->{REDO};
67 return undef;
68}
69
70sub ShiftRedo
71{
72 my ($w) = @_;
73 return shift(@{$w->{REDO}}) if defined $w->{REDO};
74 return undef;
75}
76
77sub numberChanges
78{
79 my ($w) = @_;
80 return 0 unless (exists $w->{'UNDO'}) and (defined($w->{'UNDO'}));
81 return scalar(@{$w->{'UNDO'}});
82}
83
84sub SizeRedo
85{
86 my ($w) = @_;
87 return 0 unless exists $w->{'REDO'};
88 return scalar(@{$w->{'REDO'}});
89}
90
91sub getUndoAtIndex
92{
93 my ($w,$index) = @_;
94 return undef unless (exists $w->{UNDO});
95 return $w->{UNDO}[$index];
96}
97
98sub 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####################################################################
128sub 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
193sub 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.
204sub 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
247sub 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
262sub 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
271sub 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
297sub 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
308sub GlobStart_UNDO
309{
310 my ($w, $who) = @_;
311 $who = 'GlobEnd_UNDO' unless defined($who);
312 return ['GlobEnd',$who];
313}
314
315sub 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
326sub GlobEnd_UNDO
327{
328 my ($w, $who) = @_;
329 $who = 'GlobStart_UNDO' unless defined($who);
330 return ['GlobStart',$who];
331}
332
333sub 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####################################################################
352sub 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
370sub 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
398sub 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; $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
419sub 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   shift if (@_); # discard tag
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
453sub 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
471sub 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
516sub ReplaceSelectionsWith
517{
518 my $w = shift;
519 $w->addGlobStart;
520 $w->SUPER::ReplaceSelectionsWith(@_);
521 $w->addGlobEnd;
522}
523
524sub FindAndReplaceAll
525{
526 my $w = shift;
527 $w->addGlobStart;
528 $w->SUPER::FindAndReplaceAll(@_);
529 $w->addGlobEnd;
530}
531
532sub clipboardCut
533{
534 my $w = shift;
535 $w->addGlobStart;
536 $w->SUPER::clipboardCut(@_);
537 $w->addGlobEnd;
538}
539
540sub clipboardPaste
541{
542 my $w = shift;
543 $w->addGlobStart;
544 $w->SUPER::clipboardPaste(@_);
545 $w->addGlobEnd;
546}
547
548sub clipboardColumnCut
549{
550 my $w = shift;
551 $w->addGlobStart;
552 $w->SUPER::clipboardColumnCut(@_);
553 $w->addGlobEnd;
554}
555
556sub 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
567sub Insert
568{
569 my ($w,$char)=@_;
570 return if $char eq '';
571 $w->addGlobStart;
572 $w->SUPER::Insert($char);
573 $w->addGlobEnd;
574 $w->see('insert');
575}
576
577
578sub InsertKeypress
579{
580 my ($w,$char)=@_;
581 return if $char eq '';
582 if ($char =~ /^\S$/ and !$w->OverstrikeMode and !$w->tagRanges('sel'))
583  {
584   my $index = $w->index('insert');
585   my $undo_item = $w->getUndoAtIndex(-1);
586   if (defined($undo_item) &&
587       ($undo_item->[0] eq 'delete') &&
588       ($undo_item->[2] == $index)
589      )
590    {
591     $w->SUPER::insert($index,$char);
592     $undo_item->[2] = $w->index('insert');
593     $w->see('insert');
594     return;
595    }
596  }
597 $w->addGlobStart;
598 $w->SUPER::InsertKeypress($char);
599 $w->addGlobEnd;
600}
601
602############################################################
603sub TextUndoFileProgress
604{
605 my ($w,$action,$filename,$count,$val,$total) = @_;
606 return unless(defined($filename) and defined($count));
607
608 my $popup = $w->{'FILE_PROGRESS_POP_UP'};
609 unless (defined($popup))
610  {
611   $w->update;
612   $popup = $w->Toplevel(-title => "File Progress",-popover => $w);
613   $popup->transient($w->toplevel);
614   $popup->withdraw;
615   $popup->resizable('no','no');
616   $popup->Label(-textvariable => \$popup->{ACTION})->pack;
617   $popup->Label(-textvariable => \$popup->{FILENAME})->pack;
618   $popup->Label(-textvariable => \$popup->{COUNT})->pack;
619   my $f = $popup->Frame(-height => 10, -border => 2, -relief => 'sunken')->pack(-fill => 'x');
620   my $i = $f->Frame(-background => 'blue', -relief => 'raised', -border => 2);
621   $w->{'FILE_PROGRESS_POP_UP'} = $popup;
622   $popup->{PROGBAR} = $i;
623  }
624 $popup->{ACTION}   = $action;
625 $popup->{COUNT}    = "lines: $count";
626 $popup->{FILENAME} = "Filename: $filename";
627 if (defined($val) && defined($total) && $total != 0)
628  {
629   $popup->{PROGBAR}->place('-x' => 0, '-y' => 0, -relheight => 1, -relwidth => $val/$total);
630  }
631 else
632  {
633   $popup->{PROGBAR}->placeForget;
634  }
635
636 $popup->idletasks;
637 unless ($popup->viewable)
638  {
639   $w->idletasks;
640   $w->toplevel->deiconify unless $w->viewable;
641   $popup->Popup;
642  }
643 $popup->update;
644 return $popup;
645}
646
647sub FileName
648{
649 my ($w,$filename) = @_;
650 if (@_ > 1)
651  {
652   $w->{'FILENAME'}=$filename;
653  }
654 return $w->{'FILENAME'};
655}
656
657sub PerlIO_layers
658{
659 my ($w,$layers) = @_;
660 $w->{PERLIO_LAYERS} = $layers if @_ > 1;
661 return $w->{PERLIO_LAYERS} || '' ;
662}
663
664sub ConfirmDiscard
665{
666 my ($w)=@_;
667 if ($w->numberChanges)
668  {
669   my $ans = $w->messageBox(-icon    => 'warning',
670                            -type => 'YesNoCancel', -default => 'Yes',
671                            -message =>
672"The text has been modified without being saved.
673Save edits?");
674   return 0 if $ans eq 'Cancel';
675   return 0 if ($ans eq 'Yes' && !$w->Save);
676  }
677 return 1;
678}
679
680################################################################################
681# if the file has been modified since being saved, a pop up window will be
682# created, asking the user to confirm whether or not to exit.
683# this allows the user to return to the application and save the file.
684# the code would look something like this:
685#
686# if ($w->user_wants_to_exit)
687#  {$w->ConfirmExit;}
688#
689# it is also possible to trap attempts to delete the main window.
690# this allows the ->ConfirmExit method to be called when the main window
691# is attempted to be deleted.
692#
693# $mw->protocol('WM_DELETE_WINDOW'=>
694#  sub{$w->ConfirmExit;});
695#
696# finally, it might be desirable to trap Control-C signals at the
697# application level so that ->ConfirmExit is also called.
698#
699# $SIG{INT}= sub{$w->ConfirmExit;};
700#
701################################################################################
702
703sub ConfirmExit
704{
705 my ($w) = @_;
706 $w->toplevel->destroy if $w->ConfirmDiscard;
707}
708
709sub Save
710{
711 my ($w,$filename) = @_;
712 $filename = $w->FileName unless defined $filename;
713 return $w->FileSaveAsPopup unless defined $filename;
714 my $layers = $w->PerlIO_layers;
715 if (open(my $file,">$layers",$filename))
716  {
717   my $status;
718   my $count=0;
719   my $index = '1.0';
720   my $progress;
721   my ($lines) = $w->index('end - 1 chars') =~ /^(\d+)\./;
722   while ($w->compare($index,'<','end'))
723    {
724#    my $end = $w->index("$index + 1024 chars");
725     my $end = $w->index("$index  lineend +1c");
726     print $file $w->get($index,$end);
727     $index = $end;
728     if (($count++%1000) == 0)
729      {
730       $progress = $w->TextUndoFileProgress (Saving => $filename,$count,$count,$lines);
731      }
732    }
733   $progress->withdraw if defined $progress;
734   if (close($file))
735    {
736     $w->ResetUndo;
737     $w->FileName($filename);
738     return 1;
739    }
740  }
741 else
742  {
743   $w->BackTrace("Cannot open $filename:$!");
744  }
745 return 0;
746}
747
748sub Load
749{
750 my ($w,$filename) = @_;
751 $filename = $w->FileName unless (defined($filename));
752 return 0 unless defined $filename;
753 my $layers = $w->PerlIO_layers;
754 if (open(my $file,"<$layers",$filename))
755  {
756   $w->MainWindow->Busy;
757   $w->EmptyDocument;
758   my $count=1;
759   my $progress;
760   while (<$file>)
761    {
762     $w->SUPER::insert('end',$_);
763     if (($count++%1000) == 0)
764      {
765       $progress = $w->TextUndoFileProgress (Loading => $filename,
766                         $count,tell($file),-s $filename);
767      }
768    }
769   close($file);
770   $progress->withdraw if defined $progress;
771   $w->markSet('insert' => '1.0');
772   $w->FileName($filename);
773   $w->MainWindow->Unbusy;
774  }
775 else
776  {
777   $w->BackTrace("Cannot open $filename:$!");
778  }
779}
780
781sub IncludeFile
782{
783 my ($w,$filename) = @_;
784 unless (defined($filename))
785  {$w->BackTrace("filename not specified"); return;}
786 my $layers = $w->PerlIO_layers;
787 if (open(my $file,"<$layers",$filename))
788  {
789   $w->Busy;
790   my $count=1;
791   $w->addGlobStart;
792   my $progress;
793   while (<$file>)
794    {
795     $w->insert('insert',$_);
796     if (($count++%1000) == 0)
797      {
798       $progress = $w->TextUndoFileProgress(Including => $filename,
799                        $count,tell($file),-s $filename);
800      }
801    }
802   $progress->withdraw if defined $progress;
803   $w->addGlobEnd;
804   close($file);
805   $w->Unbusy;
806  }
807 else
808  {
809   $w->BackTrace("Cannot open $filename:$!");
810  }
811}
812
813# clear document without pushing it into UNDO array, (use SUPER::delete)
814# (using plain delete(1.0,end) on a really big document fills up the undo array)
815# and then clear the Undo and Redo stacks.
816sub EmptyDocument
817{
818 my ($w) = @_;
819 $w->SUPER::delete('1.0','end');
820 $w->ResetUndo;
821 $w->FileName(undef);
822}
823
824sub ConfirmEmptyDocument
825{
826 my ($w)=@_;
827 $w->EmptyDocument if $w->ConfirmDiscard;
828}
829
830sub FileMenuItems
831{
832 my ($w) = @_;
833 return [
834   ["command"=>'~Open',    -command => [$w => 'FileLoadPopup']],
835   ["command"=>'~Save',    -command => [$w => 'Save' ]],
836   ["command"=>'Save ~As', -command => [$w => 'FileSaveAsPopup']],
837   ["command"=>'~Include', -command => [$w => 'IncludeFilePopup']],
838   ["command"=>'~Clear',   -command => [$w => 'ConfirmEmptyDocument']],
839   "-",@{$w->SUPER::FileMenuItems}
840  ]
841}
842
843sub EditMenuItems
844{
845 my ($w) = @_;
846
847 return [
848    ["command"=>'Undo', -command => [$w => 'undo']],
849    ["command"=>'Redo', -command => [$w => 'redo']],
850     "-",@{$w->SUPER::EditMenuItems}
851  ];
852}
853
854sub CreateFileSelect
855{
856 my $w = shift;
857 my $k = shift;
858 my $name = $w->FileName;
859 my @types = (['All Files', '*']);
860 my $dir   = undef;
861 if (defined $name)
862  {
863   require File::Basename;
864   my $sfx;
865   ($name,$dir,$sfx) = File::Basename::fileparse($name,'\..*');
866   #
867   # it should never happen where we have a file suffix and
868   # no file name... but fileparse() screws this up with dotfiles.
869   #
870   if (length($sfx) && !length($name)) { ($name, $sfx) = ($sfx, $name) }
871
872   if (defined($sfx) && length($sfx))
873    {
874     unshift(@types,['Similar Files',[$sfx]]);
875     $name .= $sfx;
876    }
877  }
878 return $w->$k(-initialdir  => $dir, -initialfile => $name,
879               -filetypes => \@types, @_);
880}
881
882sub FileLoadPopup
883{
884 my ($w)=@_;
885 my $name = $w->CreateFileSelect('getOpenFile',-title => 'File Load');
886 return $w->Load($name) if defined($name) and length($name);
887 return 0;
888}
889
890sub IncludeFilePopup
891{
892 my ($w)=@_;
893 my $name = $w->CreateFileSelect('getOpenFile',-title => 'File Include');
894 return $w->IncludeFile($name) if defined($name) and length($name);
895 return 0;
896}
897
898sub FileSaveAsPopup
899{
900 my ($w)=@_;
901 my $name = $w->CreateFileSelect('getSaveFile',-title => 'File Save As');
902 return $w->Save($name) if defined($name) and length($name);
903 return 0;
904}
905
906
907sub MarkSelectionsSavePositions
908{
909 my ($w)=@_;
910 $w->markSet('MarkInsertSavePosition','insert');
911 my @ranges = $w->tagRanges('sel');
912 my $i = 0;
913 while (@ranges)
914  {
915   my ($start,$end) = splice(@ranges,0,2);
916   $w->markSet( 'MarkSelectionsSavePositions_'.++$i, $start);
917   $w->markSet( 'MarkSelectionsSavePositions_'.++$i, $end);
918   $w->tagRemove('sel',$start,$end);
919  }
920}
921
922sub RestoreSelectionsMarkedSaved
923{
924 my ($w)=@_;
925 my $i = 1;
926 my %mark_hash;
927 foreach my $mark ($w->markNames)
928  {
929   $mark_hash{$mark}=1;
930  }
931 while(1)
932  {
933   my $markstart = 'MarkSelectionsSavePositions_'.$i++;
934   last unless(exists($mark_hash{$markstart}));
935   my $indexstart = $w->index($markstart);
936   my $markend = 'MarkSelectionsSavePositions_'.$i++;
937   last unless(exists($mark_hash{$markend}));
938   my $indexend = $w->index($markend);
939   $w->tagAdd('sel',$indexstart, $indexend);
940   $w->markUnset($markstart, $markend);
941  }
942 $w->markSet('insert','MarkInsertSavePosition');
943}
944
945####################################################################
946# selected lines may be discontinous sequence.
947sub GetMarkedSelectedLineNumbers
948{
949 my ($w) = @_;
950
951 my $i = 1;
952 my %mark_hash;
953 my @ranges;
954 foreach my $mark ($w->markNames)
955  {
956   $mark_hash{$mark}=1;
957  }
958
959 while(1)
960  {
961   my $markstart = 'MarkSelectionsSavePositions_'.$i++;
962   last unless(exists($mark_hash{$markstart}));
963   my $indexstart = $w->index($markstart);
964   my $markend = 'MarkSelectionsSavePositions_'.$i++;
965   last unless(exists($mark_hash{$markend}));
966   my $indexend = $w->index($markend);
967
968   push(@ranges, $indexstart, $indexend);
969  }
970
971 my @selection_list;
972 while (@ranges)
973  {
974   my ($first) = split(/\./,shift(@ranges));
975   my ($last) = split(/\./,shift(@ranges));
976   # if previous selection ended on the same line that this selection starts,
977   # then fiddle the numbers so that this line number isnt included twice.
978   if (defined($selection_list[-1]) and ($first == $selection_list[-1]))
979    {
980     # if this selection ends on the same line its starts, then skip this sel
981     next if ($first == $last);
982     $first++; # count this selection starting from the next line.
983    }
984   push(@selection_list, $first .. $last);
985  }
986 return @selection_list;
987}
988
989sub insertStringAtStartOfSelectedLines
990{
991 my ($w,$insert_string)=@_;
992 $w->addGlobStart;
993 $w->MarkSelectionsSavePositions;
994 foreach my $line ($w->GetMarkedSelectedLineNumbers)
995  {
996   $w->insert($line.'.0', $insert_string);
997  }
998 $w->RestoreSelectionsMarkedSaved;
999 $w->addGlobEnd;
1000}
1001
1002sub deleteStringAtStartOfSelectedLines
1003{
1004 my ($w,$insert_string)=@_;
1005 $w->addGlobStart;
1006 $w->MarkSelectionsSavePositions;
1007 my $length = length($insert_string);
1008 foreach my $line ($w->GetMarkedSelectedLineNumbers)
1009  {
1010   my $start = $line.'.0';
1011   my $end   = $line.'.'.$length;
1012   my $current_text = $w->get($start, $end);
1013   next unless ($current_text eq $insert_string);
1014   $w->delete($start, $end);
1015  }
1016 $w->RestoreSelectionsMarkedSaved;
1017 $w->addGlobEnd;
1018}
1019
1020
10211;
1022__END__
1023
1024