summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Tk/TextUndo.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Tk/TextUndo.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/TextUndo.pm1022
1 files changed, 0 insertions, 1022 deletions
diff --git a/Master/tlpkg/tlperl/lib/Tk/TextUndo.pm b/Master/tlpkg/tlperl/lib/Tk/TextUndo.pm
deleted file mode 100644
index 066e4027a3a..00000000000
--- a/Master/tlpkg/tlperl/lib/Tk/TextUndo.pm
+++ /dev/null
@@ -1,1022 +0,0 @@
-# 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__
-