summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Tk/TextUndo.pm
diff options
context:
space:
mode:
authorNorbert Preining <preining@logic.at>2010-05-12 16:54:37 +0000
committerNorbert Preining <preining@logic.at>2010-05-12 16:54:37 +0000
commit661c41a09e39a182865e0b51e34cc995a0dc96e8 (patch)
tree2f79bb1406e22fdcb2587be8ffda6c0c609d7932 /Master/tlpkg/tlperl/lib/Tk/TextUndo.pm
parentb645030efc22e13c2498a1522083634ab91b2de1 (diff)
move tlperl.straw to tlperl
git-svn-id: svn://tug.org/texlive/trunk@18210 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Tk/TextUndo.pm')
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Tk/TextUndo.pm1022
1 files changed, 1022 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/Tk/TextUndo.pm b/Master/tlpkg/tlperl/lib/Tk/TextUndo.pm
new file mode 100755
index 00000000000..066e4027a3a
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/TextUndo.pm
@@ -0,0 +1,1022 @@
+# Copyright (c) 1995-2004 Nick Ing-Simmons.
+# Copyright (c) 1999 Greg London.
+# All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+package Tk::TextUndo;
+
+use vars qw($VERSION $DoDebug);
+$VERSION = '4.013'; # $Id: //depot/Tkutf8/Tk/TextUndo.pm#15 $
+$DoDebug = 0;
+
+use Tk qw (Ev);
+use AutoLoader;
+
+use Tk::Text ();
+use base qw(Tk::Text);
+
+Construct Tk::Widget 'TextUndo';
+
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+ $mw->bind($class,'<<Undo>>','undo');
+ $mw->bind($class,'<<Redo>>','redo');
+
+ return $class->SUPER::ClassInit($mw);
+}
+
+
+####################################################################
+# methods for manipulating the undo and redo stacks.
+# no one should directly access the stacks except for these methods.
+# everyone else must access the stacks through these methods.
+####################################################################
+sub ResetUndo
+{
+ my ($w) = @_;
+ delete $w->{UNDO};
+ delete $w->{REDO};
+}
+
+sub PushUndo
+{
+ my $w = shift;
+ $w->{UNDO} = [] unless (exists $w->{UNDO});
+ push(@{$w->{UNDO}},@_);
+}
+
+sub PushRedo
+{
+ my $w = shift;
+ $w->{REDO} = [] unless (exists $w->{REDO});
+ push(@{$w->{REDO}},@_);
+}
+
+sub PopUndo
+{
+ my ($w) = @_;
+ return pop(@{$w->{UNDO}}) if defined $w->{UNDO};
+ return undef;
+}
+
+sub PopRedo
+{
+ my ($w) = @_;
+ return pop(@{$w->{REDO}}) if defined $w->{REDO};
+ return undef;
+}
+
+sub ShiftRedo
+{
+ my ($w) = @_;
+ return shift(@{$w->{REDO}}) if defined $w->{REDO};
+ return undef;
+}
+
+sub numberChanges
+{
+ my ($w) = @_;
+ return 0 unless (exists $w->{'UNDO'}) and (defined($w->{'UNDO'}));
+ return scalar(@{$w->{'UNDO'}});
+}
+
+sub SizeRedo
+{
+ my ($w) = @_;
+ return 0 unless exists $w->{'REDO'};
+ return scalar(@{$w->{'REDO'}});
+}
+
+sub getUndoAtIndex
+{
+ my ($w,$index) = @_;
+ return undef unless (exists $w->{UNDO});
+ return $w->{UNDO}[$index];
+}
+
+sub getRedoAtIndex
+{
+ my ($w,$index) = @_;
+ return undef unless (exists $w->{REDO});
+ return $w->{REDO}[$index];
+}
+
+####################################################################
+# type "hello there"
+# hello there_
+# hit UNDO
+# hello_
+# type "out"
+# hello out_
+# pressing REDO should not do anything
+# pressing UNDO should make "out" disappear.
+# pressing UNDO should make "there" reappear.
+# pressing UNDO should make "there" disappear.
+# pressing UNDO should make "hello" disappear.
+#
+# if there is anything in REDO stack and
+# the OperationMode is normal, (i.e. not in the middle of an ->undo or ->redo)
+# then before performing the current operation
+# take the REDO stack, and put it on UNDO stack
+# such that UNDO/REDO keystrokes will still make logical sense.
+#
+# call this method at the beginning of any overloaded method
+# which adds operations to the undo or redo stacks.
+# it will perform all the magic needed to handle the redo stack.
+####################################################################
+sub CheckForRedoShuffle
+{
+ my ($w) = @_;
+ my $size_redo = $w->SizeRedo;
+ return unless $size_redo && ($w->OperationMode eq 'normal');
+ # local $DoDebug = 1;
+
+ # we are about to 'do' something new, but have something in REDO stack.
+ # The REDOs may conflict with new ops, but we want to preserve them.
+ # So convert them to UNDOs - effectively do them and their inverses
+ # so net effect on the widget is no-change.
+
+ $w->dump_array('StartShuffle');
+
+ $w->OperationMode('REDO_MAGIC');
+ $w->MarkSelectionsSavePositions;
+
+ my @pvtundo;
+
+ # go through REDO array from end downto 0, i.e. pseudo pop
+ # then pretend we did 'redo' get inverse, and push into UNDO array
+ # and 'do' the op.
+ for (my $i=$size_redo-1; $i>=0 ; $i--)
+ {
+ my ($op,@args) = @{$w->getRedoAtIndex($i)};
+ my $op_undo = $op .'_UNDO';
+ # save the inverse of the op on the UNDO array
+ # do this before the re-doing the op - after a 'delete' we cannot see
+ # text we deleted!
+ my $undo = $w->$op_undo(@args);
+ $w->PushUndo($undo);
+ # We must 'do' the operation now so if this is an insert
+ # the text and tags are available for inspection in delete_UNDO, and
+ # indices reflect changes.
+ $w->$op(@args);
+ # Save the undo that will reverse what we just did - it is
+ # on the undo stack but will be tricky to find
+ push(@pvtundo,$undo);
+ }
+
+ # Now shift each item off REDO array until empty
+ # push each item onto UNDO array - this reverses the order
+ # and we are not altering buffer so we cannot look in the
+ # buffer to compute inverses - which is why we saved them above
+
+ while ($w->SizeRedo)
+ {
+ my $ref = $w->ShiftRedo;
+ $w->PushUndo($ref);
+ }
+
+ # Finally undo whatever we did to compensate for doing it
+ # and get buffer back to state it was before we started.
+ while (@pvtundo)
+ {
+ my ($op,@args) = @{pop(@pvtundo)};
+ $w->$op(@args);
+ }
+
+ $w->RestoreSelectionsMarkedSaved;
+ $w->OperationMode('normal');
+ $w->dump_array('EndShuffle');
+}
+
+# sets/returns undo/redo/normal operation mode
+sub OperationMode
+{
+ my ($w,$mode) = @_;
+ $w->{'OPERATION_MODE'} = $mode if (@_ > 1);
+ $w->{'OPERATION_MODE'} = 'normal' unless exists($w->{'OPERATION_MODE'});
+ return $w->{'OPERATION_MODE'};
+}
+
+####################################################################
+# dump the undo and redo stacks to the screen.
+# used for debug purposes.
+sub dump_array
+{
+ return unless $DoDebug;
+ my ($w,$why) = @_;
+ print "At $why:\n";
+ foreach my $key ('UNDO','REDO')
+ {
+ if (defined($w->{$key}))
+ {
+ print " $key array is:\n";
+ my $array = $w->{$key};
+ foreach my $ref (@$array)
+ {
+ my @items;
+ foreach my $item (@$ref)
+ {
+ my $loc = $item;
+ $loc =~ tr/\n/\^/;
+ push(@items,$loc);
+ }
+ print " [",join(',',@items),"]\n";
+ }
+ }
+ }
+ print "\n";
+}
+
+
+############################################################
+############################################################
+# these are a group of methods used to indicate the start and end of
+# several operations that are to be undo/redo 'ed in a single step.
+#
+# in other words, "glob" a bunch of operations together.
+#
+# for example, a search and replace should be undone with a single
+# keystroke, rather than one keypress undoes the insert and another
+# undoes the delete.
+# all other methods should access the count via these methods.
+# no other method should directly access the {GLOB_COUNT} value directly
+#############################################################
+#############################################################
+
+sub AddOperation
+{
+ my ($w,@operation) = @_;
+ my $mode = $w->OperationMode;
+
+ if ($mode eq 'normal')
+ {$w->PushUndo([@operation]);}
+ elsif ($mode eq 'undo')
+ {$w->PushRedo([@operation]);}
+ elsif ($mode eq 'redo')
+ {$w->PushUndo([@operation]);}
+ else
+ {die "invalid destination '$mode', must be one of 'normal', 'undo' or 'redo'";}
+}
+
+sub addGlobStart # add it to end of undo list
+{
+ my ($w, $who) = @_;
+ unless (defined($who)) {$who = (caller(1))[3];}
+ $w->CheckForRedoShuffle;
+ $w->dump_array('Start'.$who);
+ $w->AddOperation('GlobStart', $who) ;
+}
+
+sub addGlobEnd # add it to end of undo list
+{
+ my ($w, $who) = @_;
+ unless (defined($who)) {$who = (caller(1))[3];}
+ my $topundo = $w->getUndoAtIndex(-1);
+ if ($topundo->[0] eq 'GlobStart')
+ {
+ $w->PopUndo;
+ }
+ else
+ {
+ my $nxtundo = $w->getUndoAtIndex(-2);
+ if ($nxtundo->[0] eq 'GlobStart')
+ {
+ $w->PopUndo;
+ $w->PopUndo;
+ $w->PushUndo($topundo);
+ }
+ else
+ {
+ $w->AddOperation('GlobEnd', $who);
+ }
+ }
+ $w->dump_array('End'.$who);
+}
+
+sub GlobStart
+{
+ my ($w, $who) = @_;
+ unless (defined($w->{GLOB_COUNT})) {$w->{GLOB_COUNT}=0;}
+ if ($w->OperationMode eq 'normal')
+ {
+ $w->PushUndo($w->GlobStart_UNDO($who));
+ }
+ $w->{GLOB_COUNT} = $w->{GLOB_COUNT} + 1;
+}
+
+sub GlobStart_UNDO
+{
+ my ($w, $who) = @_;
+ $who = 'GlobEnd_UNDO' unless defined($who);
+ return ['GlobEnd',$who];
+}
+
+sub GlobEnd
+{
+ my ($w, $who) = @_;
+ unless (defined($w->{GLOB_COUNT})) {$w->{GLOB_COUNT}=0;}
+ if ($w->OperationMode eq 'normal')
+ {
+ $w->PushUndo($w->GlobStart_UNDO($who));
+ }
+ $w->{GLOB_COUNT} = $w->{GLOB_COUNT} - 1;
+}
+
+sub GlobEnd_UNDO
+{
+ my ($w, $who) = @_;
+ $who = 'GlobStart_UNDO' unless defined($who);
+ return ['GlobStart',$who];
+}
+
+sub GlobCount
+{
+ my ($w,$count) = @_;
+ unless ( exists($w->{'GLOB_COUNT'}) and defined($w->{'GLOB_COUNT'}) )
+ {
+ $w->{'GLOB_COUNT'}=0;
+ }
+ if (defined($count))
+ {
+ $w->{'GLOB_COUNT'}=$count;
+ }
+ return $w->{'GLOB_COUNT'};
+}
+
+####################################################################
+# two methods should be used by applications to access undo and redo
+# capability, namely, $w->undo; and $w->redo; methods.
+# these methods undo and redo the last operation, respectively.
+####################################################################
+sub undo
+{
+ my ($w) = @_;
+ $w->dump_array('Start'.'undo');
+ unless ($w->numberChanges) {$w->bell; return;} # beep and return if empty
+ $w->GlobCount(0); #initialize to zero
+ $w->OperationMode('undo');
+ do
+ {
+ my ($op,@args) = @{$w->PopUndo}; # get undo operation, convert ref to array
+ my $undo_op = $op .'_UNDO';
+ $w->PushRedo($w->$undo_op(@args)); # find out how to undo it
+ $w->$op(@args); # do the operation
+ } while($w->GlobCount and $w->numberChanges);
+ $w->OperationMode('normal');
+ $w->dump_array('End'.'undo');
+}
+
+sub redo
+{
+ my ($w) = @_;
+ unless ($w->SizeRedo) {$w->bell; return;} # beep and return if empty
+ $w->OperationMode('redo');
+ $w->GlobCount(0); #initialize to zero
+ do
+ {
+ my ($op,@args) = @{$w->PopRedo}; # get op from redo stack, convert to list
+ my $undo_op = $op .'_UNDO';
+ $w->PushUndo($w->$undo_op(@args)); # figure out how to undo operation
+ $w->$op(@args); # do the operation
+ } while($w->GlobCount and $w->SizeRedo);
+ $w->OperationMode('normal');
+}
+
+
+############################################################
+# override low level subroutines so that they work with UNDO/REDO capability.
+# every overridden subroutine must also have a corresponding *_UNDO subroutine.
+# the *_UNDO method takes the same parameters in and returns an array reference
+# which is how to undo itself.
+# note that the *_UNDO must receive absolute indexes.
+# ->insert receives 'markname' as the starting index.
+# ->insert must convert 'markname' using $absindex=$w->index('markname')
+# and pass $absindex to ->insert_UNDO.
+############################################################
+
+sub insert
+{
+ my $w = shift;
+ $w->markSet('insert', $w->index(shift) );
+ while(@_)
+ {
+ my $index1 = $w->index('insert');
+ my $string = shift;
+ my $taglist_ref = shift if @_;
+
+ if ($w->OperationMode eq 'normal')
+ {
+ $w->CheckForRedoShuffle;
+ $w->PushUndo($w->insert_UNDO($index1,$string,$taglist_ref));
+ }
+ $w->markSet('notepos' => $index1);
+ $w->SUPER::insert($index1,$string,$taglist_ref);
+ $w->markSet('insert', $w->index('notepos'));
+ }
+}
+
+sub insert_UNDO
+{
+ my $w = shift;
+ my $index = shift;
+ my $string = '';
+ # This possible call: ->insert (index, string, tag, string, tag...);
+ # if more than one string, keep reading strings in (discarding tags)
+ # until all strings are read in and $string contains entire text inserted.
+ while (@_)
+ {
+ $string .= shift;
+ my $tags = shift if (@_);
+ }
+ # calculate index
+ # possible things to insert:
+ # carriage return
+ # single character (not CR)
+ # single line of characters (not ending in CR)
+ # single line of characters ending with a CR
+ # multi-line characters. last line does not end with CR
+ # multi-line characters, last line does end with CR.
+ my ($line,$col) = split(/\./,$index);
+ if ($string =~ /\n(.*)$/)
+ {
+ $line += $string =~ tr/\n/\n/;
+ $col = length($1);
+ }
+ else
+ {
+ $col += length($string);
+ }
+ return ['delete', $index, $line.'.'.$col];
+}
+
+sub delete
+{
+ my ($w, $start, $stop) = @_;
+ unless(defined($stop))
+ { $stop = $start .'+1c'; }
+ my $index1 = $w->index($start);
+ my $index2 = $w->index($stop);
+ if ($w->OperationMode eq 'normal')
+ {
+ $w->CheckForRedoShuffle;
+ $w->PushUndo($w->delete_UNDO($index1,$index2));
+ }
+ $w->SUPER::delete($index1,$index2);
+ # why call SetCursor - it has side effects
+ # which cause a whole slew if save/restore hassles ?
+ $w->SetCursor($index1);
+}
+
+sub delete_UNDO
+{
+ my ($w, $index1, $index2) = @_;
+ my %tags;
+ my @result = ( 'insert' => $index1 );
+ my $str = '';
+
+ ###############################################################
+ # get tags in range and return them in a format that
+ # can be inserted.
+ # $text->insert('1.0', $string1, [tag1,tag2], $string2, [tag2, tag3]);
+ # note, have to break tags up into sequential order
+ # in reference to _all_ tags.
+ ###############################################################
+
+ $w->dump('-text','-tag', -command => sub {
+ my ($kind,$value,$posn) = @_;
+ if ($kind eq 'text')
+ {
+ $str .= $value;
+ }
+ else
+ {
+ push(@result,$str,[keys %tags]) if (length $str);
+ $str = '';
+ if ($kind eq 'tagon')
+ {
+ $tags{$value} = 1;
+ }
+ elsif ($kind eq 'tagoff')
+ {
+ delete $tags{$value};
+ }
+ }
+ }, $index1, $index2);
+ push(@result,$str,[keys %tags]) if (length $str);
+ return \@result;
+}
+
+############################################################
+# override subroutines which are collections of low level
+# routines executed in sequence.
+# wrap a globstart and globend around the SUPER:: version of routine.
+############################################################
+
+sub ReplaceSelectionsWith
+{
+ my $w = shift;
+ $w->addGlobStart;
+ $w->SUPER::ReplaceSelectionsWith(@_);
+ $w->addGlobEnd;
+}
+
+sub FindAndReplaceAll
+{
+ my $w = shift;
+ $w->addGlobStart;
+ $w->SUPER::FindAndReplaceAll(@_);
+ $w->addGlobEnd;
+}
+
+sub clipboardCut
+{
+ my $w = shift;
+ $w->addGlobStart;
+ $w->SUPER::clipboardCut(@_);
+ $w->addGlobEnd;
+}
+
+sub clipboardPaste
+{
+ my $w = shift;
+ $w->addGlobStart;
+ $w->SUPER::clipboardPaste(@_);
+ $w->addGlobEnd;
+}
+
+sub clipboardColumnCut
+{
+ my $w = shift;
+ $w->addGlobStart;
+ $w->SUPER::clipboardColumnCut(@_);
+ $w->addGlobEnd;
+}
+
+sub clipboardColumnPaste
+{
+ my $w = shift;
+ $w->addGlobStart;
+ $w->SUPER::clipboardColumnPaste(@_);
+ $w->addGlobEnd;
+}
+
+# Greg: this method is more tightly coupled to the base class
+# than I would prefer, but I know of no other way to do it.
+
+sub Insert
+{
+ my ($w,$char)=@_;
+ return if $char eq '';
+ $w->addGlobStart;
+ $w->SUPER::Insert($char);
+ $w->addGlobEnd;
+ $w->see('insert');
+}
+
+
+sub InsertKeypress
+{
+ my ($w,$char)=@_;
+ return if $char eq '';
+ if ($char =~ /^\S$/ and !$w->OverstrikeMode and !$w->tagRanges('sel'))
+ {
+ my $index = $w->index('insert');
+ my $undo_item = $w->getUndoAtIndex(-1);
+ if (defined($undo_item) &&
+ ($undo_item->[0] eq 'delete') &&
+ ($undo_item->[2] == $index)
+ )
+ {
+ $w->SUPER::insert($index,$char);
+ $undo_item->[2] = $w->index('insert');
+ return;
+ }
+ }
+ $w->addGlobStart;
+ $w->SUPER::InsertKeypress($char);
+ $w->addGlobEnd;
+}
+
+############################################################
+sub TextUndoFileProgress
+{
+ my ($w,$action,$filename,$count,$val,$total) = @_;
+ return unless(defined($filename) and defined($count));
+
+ my $popup = $w->{'FILE_PROGRESS_POP_UP'};
+ unless (defined($popup))
+ {
+ $w->update;
+ $popup = $w->Toplevel(-title => "File Progress",-popover => $w);
+ $popup->transient($w->toplevel);
+ $popup->withdraw;
+ $popup->resizable('no','no');
+ $popup->Label(-textvariable => \$popup->{ACTION})->pack;
+ $popup->Label(-textvariable => \$popup->{FILENAME})->pack;
+ $popup->Label(-textvariable => \$popup->{COUNT})->pack;
+ my $f = $popup->Frame(-height => 10, -border => 2, -relief => 'sunken')->pack(-fill => 'x');
+ my $i = $f->Frame(-background => 'blue', -relief => 'raised', -border => 2);
+ $w->{'FILE_PROGRESS_POP_UP'} = $popup;
+ $popup->{PROGBAR} = $i;
+ }
+ $popup->{ACTION} = $action;
+ $popup->{COUNT} = "lines: $count";
+ $popup->{FILENAME} = "Filename: $filename";
+ if (defined($val) && defined($total) && $total != 0)
+ {
+ $popup->{PROGBAR}->place('-x' => 0, '-y' => 0, -relheight => 1, -relwidth => $val/$total);
+ }
+ else
+ {
+ $popup->{PROGBAR}->placeForget;
+ }
+
+ $popup->idletasks;
+ unless ($popup->viewable)
+ {
+ $w->idletasks;
+ $w->toplevel->deiconify unless $w->viewable;
+ $popup->Popup;
+ }
+ $popup->update;
+ return $popup;
+}
+
+sub FileName
+{
+ my ($w,$filename) = @_;
+ if (@_ > 1)
+ {
+ $w->{'FILENAME'}=$filename;
+ }
+ return $w->{'FILENAME'};
+}
+
+sub PerlIO_layers
+{
+ my ($w,$layers) = @_;
+ $w->{PERLIO_LAYERS} = $layers if @_ > 1;
+ return $w->{PERLIO_LAYERS} || '' ;
+}
+
+sub ConfirmDiscard
+{
+ my ($w)=@_;
+ if ($w->numberChanges)
+ {
+ my $ans = $w->messageBox(-icon => 'warning',
+ -type => 'YesNoCancel', -default => 'Yes',
+ -message =>
+"The text has been modified without being saved.
+Save edits?");
+ return 0 if $ans eq 'Cancel';
+ return 0 if ($ans eq 'Yes' && !$w->Save);
+ }
+ return 1;
+}
+
+################################################################################
+# if the file has been modified since being saved, a pop up window will be
+# created, asking the user to confirm whether or not to exit.
+# this allows the user to return to the application and save the file.
+# the code would look something like this:
+#
+# if ($w->user_wants_to_exit)
+# {$w->ConfirmExit;}
+#
+# it is also possible to trap attempts to delete the main window.
+# this allows the ->ConfirmExit method to be called when the main window
+# is attempted to be deleted.
+#
+# $mw->protocol('WM_DELETE_WINDOW'=>
+# sub{$w->ConfirmExit;});
+#
+# finally, it might be desirable to trap Control-C signals at the
+# application level so that ->ConfirmExit is also called.
+#
+# $SIG{INT}= sub{$w->ConfirmExit;};
+#
+################################################################################
+
+sub ConfirmExit
+{
+ my ($w) = @_;
+ $w->toplevel->destroy if $w->ConfirmDiscard;
+}
+
+sub Save
+{
+ my ($w,$filename) = @_;
+ $filename = $w->FileName unless defined $filename;
+ return $w->FileSaveAsPopup unless defined $filename;
+ my $layers = $w->PerlIO_layers;
+ if (open(my $file,">$layers",$filename))
+ {
+ my $status;
+ my $count=0;
+ my $index = '1.0';
+ my $progress;
+ my ($lines) = $w->index('end - 1 chars') =~ /^(\d+)\./;
+ while ($w->compare($index,'<','end'))
+ {
+# my $end = $w->index("$index + 1024 chars");
+ my $end = $w->index("$index lineend +1c");
+ print $file $w->get($index,$end);
+ $index = $end;
+ if (($count++%1000) == 0)
+ {
+ $progress = $w->TextUndoFileProgress (Saving => $filename,$count,$count,$lines);
+ }
+ }
+ $progress->withdraw if defined $progress;
+ if (close($file))
+ {
+ $w->ResetUndo;
+ $w->FileName($filename);
+ return 1;
+ }
+ }
+ else
+ {
+ $w->BackTrace("Cannot open $filename:$!");
+ }
+ return 0;
+}
+
+sub Load
+{
+ my ($w,$filename) = @_;
+ $filename = $w->FileName unless (defined($filename));
+ return 0 unless defined $filename;
+ my $layers = $w->PerlIO_layers;
+ if (open(my $file,"<$layers",$filename))
+ {
+ $w->MainWindow->Busy;
+ $w->EmptyDocument;
+ my $count=1;
+ my $progress;
+ while (<$file>)
+ {
+ $w->SUPER::insert('end',$_);
+ if (($count++%1000) == 0)
+ {
+ $progress = $w->TextUndoFileProgress (Loading => $filename,
+ $count,tell($file),-s $filename);
+ }
+ }
+ close($file);
+ $progress->withdraw if defined $progress;
+ $w->markSet('insert' => '1.0');
+ $w->FileName($filename);
+ $w->MainWindow->Unbusy;
+ }
+ else
+ {
+ $w->BackTrace("Cannot open $filename:$!");
+ }
+}
+
+sub IncludeFile
+{
+ my ($w,$filename) = @_;
+ unless (defined($filename))
+ {$w->BackTrace("filename not specified"); return;}
+ my $layers = $w->PerlIO_layers;
+ if (open(my $file,"<$layers",$filename))
+ {
+ $w->Busy;
+ my $count=1;
+ $w->addGlobStart;
+ my $progress;
+ while (<$file>)
+ {
+ $w->insert('insert',$_);
+ if (($count++%1000) == 0)
+ {
+ $progress = $w->TextUndoFileProgress(Including => $filename,
+ $count,tell($file),-s $filename);
+ }
+ }
+ $progress->withdraw if defined $progress;
+ $w->addGlobEnd;
+ close($file);
+ $w->Unbusy;
+ }
+ else
+ {
+ $w->BackTrace("Cannot open $filename:$!");
+ }
+}
+
+# clear document without pushing it into UNDO array, (use SUPER::delete)
+# (using plain delete(1.0,end) on a really big document fills up the undo array)
+# and then clear the Undo and Redo stacks.
+sub EmptyDocument
+{
+ my ($w) = @_;
+ $w->SUPER::delete('1.0','end');
+ $w->ResetUndo;
+ $w->FileName(undef);
+}
+
+sub ConfirmEmptyDocument
+{
+ my ($w)=@_;
+ $w->EmptyDocument if $w->ConfirmDiscard;
+}
+
+sub FileMenuItems
+{
+ my ($w) = @_;
+ return [
+ ["command"=>'~Open', -command => [$w => 'FileLoadPopup']],
+ ["command"=>'~Save', -command => [$w => 'Save' ]],
+ ["command"=>'Save ~As', -command => [$w => 'FileSaveAsPopup']],
+ ["command"=>'~Include', -command => [$w => 'IncludeFilePopup']],
+ ["command"=>'~Clear', -command => [$w => 'ConfirmEmptyDocument']],
+ "-",@{$w->SUPER::FileMenuItems}
+ ]
+}
+
+sub EditMenuItems
+{
+ my ($w) = @_;
+
+ return [
+ ["command"=>'Undo', -command => [$w => 'undo']],
+ ["command"=>'Redo', -command => [$w => 'redo']],
+ "-",@{$w->SUPER::EditMenuItems}
+ ];
+}
+
+sub CreateFileSelect
+{
+ my $w = shift;
+ my $k = shift;
+ my $name = $w->FileName;
+ my @types = (['All Files', '*']);
+ my $dir = undef;
+ if (defined $name)
+ {
+ require File::Basename;
+ my $sfx;
+ ($name,$dir,$sfx) = File::Basename::fileparse($name,'\..*');
+ #
+ # it should never happen where we have a file suffix and
+ # no file name... but fileparse() screws this up with dotfiles.
+ #
+ if (length($sfx) && !length($name)) { ($name, $sfx) = ($sfx, $name) }
+
+ if (defined($sfx) && length($sfx))
+ {
+ unshift(@types,['Similar Files',[$sfx]]);
+ $name .= $sfx;
+ }
+ }
+ return $w->$k(-initialdir => $dir, -initialfile => $name,
+ -filetypes => \@types, @_);
+}
+
+sub FileLoadPopup
+{
+ my ($w)=@_;
+ my $name = $w->CreateFileSelect('getOpenFile',-title => 'File Load');
+ return $w->Load($name) if defined($name) and length($name);
+ return 0;
+}
+
+sub IncludeFilePopup
+{
+ my ($w)=@_;
+ my $name = $w->CreateFileSelect('getOpenFile',-title => 'File Include');
+ return $w->IncludeFile($name) if defined($name) and length($name);
+ return 0;
+}
+
+sub FileSaveAsPopup
+{
+ my ($w)=@_;
+ my $name = $w->CreateFileSelect('getSaveFile',-title => 'File Save As');
+ return $w->Save($name) if defined($name) and length($name);
+ return 0;
+}
+
+
+sub MarkSelectionsSavePositions
+{
+ my ($w)=@_;
+ $w->markSet('MarkInsertSavePosition','insert');
+ my @ranges = $w->tagRanges('sel');
+ my $i = 0;
+ while (@ranges)
+ {
+ my ($start,$end) = splice(@ranges,0,2);
+ $w->markSet( 'MarkSelectionsSavePositions_'.++$i, $start);
+ $w->markSet( 'MarkSelectionsSavePositions_'.++$i, $end);
+ $w->tagRemove('sel',$start,$end);
+ }
+}
+
+sub RestoreSelectionsMarkedSaved
+{
+ my ($w)=@_;
+ my $i = 1;
+ my %mark_hash;
+ foreach my $mark ($w->markNames)
+ {
+ $mark_hash{$mark}=1;
+ }
+ while(1)
+ {
+ my $markstart = 'MarkSelectionsSavePositions_'.$i++;
+ last unless(exists($mark_hash{$markstart}));
+ my $indexstart = $w->index($markstart);
+ my $markend = 'MarkSelectionsSavePositions_'.$i++;
+ last unless(exists($mark_hash{$markend}));
+ my $indexend = $w->index($markend);
+ $w->tagAdd('sel',$indexstart, $indexend);
+ $w->markUnset($markstart, $markend);
+ }
+ $w->markSet('insert','MarkInsertSavePosition');
+}
+
+####################################################################
+# selected lines may be discontinous sequence.
+sub GetMarkedSelectedLineNumbers
+{
+ my ($w) = @_;
+
+ my $i = 1;
+ my %mark_hash;
+ my @ranges;
+ foreach my $mark ($w->markNames)
+ {
+ $mark_hash{$mark}=1;
+ }
+
+ while(1)
+ {
+ my $markstart = 'MarkSelectionsSavePositions_'.$i++;
+ last unless(exists($mark_hash{$markstart}));
+ my $indexstart = $w->index($markstart);
+ my $markend = 'MarkSelectionsSavePositions_'.$i++;
+ last unless(exists($mark_hash{$markend}));
+ my $indexend = $w->index($markend);
+
+ push(@ranges, $indexstart, $indexend);
+ }
+
+ my @selection_list;
+ while (@ranges)
+ {
+ my ($first) = split(/\./,shift(@ranges));
+ my ($last) = split(/\./,shift(@ranges));
+ # if previous selection ended on the same line that this selection starts,
+ # then fiddle the numbers so that this line number isnt included twice.
+ if (defined($selection_list[-1]) and ($first == $selection_list[-1]))
+ {
+ # if this selection ends on the same line its starts, then skip this sel
+ next if ($first == $last);
+ $first++; # count this selection starting from the next line.
+ }
+ push(@selection_list, $first .. $last);
+ }
+ return @selection_list;
+}
+
+sub insertStringAtStartOfSelectedLines
+{
+ my ($w,$insert_string)=@_;
+ $w->addGlobStart;
+ $w->MarkSelectionsSavePositions;
+ foreach my $line ($w->GetMarkedSelectedLineNumbers)
+ {
+ $w->insert($line.'.0', $insert_string);
+ }
+ $w->RestoreSelectionsMarkedSaved;
+ $w->addGlobEnd;
+}
+
+sub deleteStringAtStartOfSelectedLines
+{
+ my ($w,$insert_string)=@_;
+ $w->addGlobStart;
+ $w->MarkSelectionsSavePositions;
+ my $length = length($insert_string);
+ foreach my $line ($w->GetMarkedSelectedLineNumbers)
+ {
+ my $start = $line.'.0';
+ my $end = $line.'.'.$length;
+ my $current_text = $w->get($start, $end);
+ next unless ($current_text eq $insert_string);
+ $w->delete($start, $end);
+ }
+ $w->RestoreSelectionsMarkedSaved;
+ $w->addGlobEnd;
+}
+
+
+1;
+__END__
+