tools/perl-5.8.0/lib/site_perl/5.8.0/sun4-solaris/Tk/Text.pm

# text.tcl --
#
# This file defines the default bindings for Tk text widgets.
#
# @(#) text.tcl 1.18 94/12/17 16:05:26
#
# Copyright (c) 1992-1994 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# perl/Tk version:
# Copyright (c) 1995-1999 Nick Ing-Simmons
# Copyright (c) 1999 Greg London
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
package Tk::Text;
use AutoLoader;
use Carp;
use strict;

use Text::Tabs;

use vars qw($VERSION);
$VERSION = '3.044'; # $Id: //depot/Tk8/Text/Text.pm#44 $

use Tk qw(Ev $XS_VERSION);
use base  qw(Tk::Clipboard Tk::Widget);

Construct Tk::Widget 'Text';

bootstrap Tk::Text;

sub Tk_cmd { \&Tk::text }

sub Tk::Widget::ScrlText { shift->Scrolled('Text' => @_) }

Tk::Methods('bbox','compare','debug','delete','dlineinfo','dump',
            'get','image','index','insert','mark','scan','search',
            'see','tag','window','xview','yview');

use Tk::Submethods ( 'mark'   => [qw(gravity names next previous set unset)],
                     'scan'   => [qw(mark dragto)],
                     'tag'    => [qw(add bind cget configure delete lower
                                     names nextrange prevrange raise ranges remove)],
                     'window' => [qw(cget configure create names)],
                     'image'  => [qw(cget configure create names)],
                     'xview'  => [qw(moveto scroll)],
                     'yview'  => [qw(moveto scroll)],
                     );

sub Tag;
sub Tags;

sub bindRdOnly
{

 my ($class,$mw) = @_;

 # Standard Motif bindings:
 $mw->bind($class,'<Meta-B1-Motion>','NoOp');
 $mw->bind($class,'<Meta-1>','NoOp');
 $mw->bind($class,'<Alt-KeyPress>','NoOp');
 $mw->bind($class,'<Escape>','unselectAll');

 $mw->bind($class,'<1>',['Button1',Ev('x'),Ev('y')]);
 $mw->bind($class,'<B1-Motion>','B1_Motion' ) ;
 $mw->bind($class,'<B1-Leave>','B1_Leave' ) ;
 $mw->bind($class,'<B1-Enter>','CancelRepeat');
 $mw->bind($class,'<ButtonRelease-1>','CancelRepeat');
 $mw->bind($class,'<Control-1>',['markSet','insert',Ev('@')]);

 $mw->bind($class,'<Double-1>','selectWord' ) ;
 $mw->bind($class,'<Triple-1>','selectLine' ) ;
 $mw->bind($class,'<Shift-1>','adjustSelect' ) ;
 $mw->bind($class,'<Double-Shift-1>',['SelectTo',Ev('@'),'word']);
 $mw->bind($class,'<Triple-Shift-1>',['SelectTo',Ev('@'),'line']);

 $mw->bind($class,'<Left>',['SetCursor',Ev('index','insert-1c')]);
 $mw->bind($class,'<Shift-Left>',['KeySelect',Ev('index','insert-1c')]);
 $mw->bind($class,'<Control-Left>',['SetCursor',Ev('index','insert-1c wordstart')]);
 $mw->bind($class,'<Shift-Control-Left>',['KeySelect',Ev('index','insert-1c wordstart')]);

 $mw->bind($class,'<Right>',['SetCursor',Ev('index','insert+1c')]);
 $mw->bind($class,'<Shift-Right>',['KeySelect',Ev('index','insert+1c')]);
 $mw->bind($class,'<Control-Right>',['SetCursor',Ev('index','insert+1c wordend')]);
 $mw->bind($class,'<Shift-Control-Right>',['KeySelect',Ev('index','insert wordend')]);

 $mw->bind($class,'<Up>',['SetCursor',Ev('UpDownLine',-1)]);
 $mw->bind($class,'<Shift-Up>',['KeySelect',Ev('UpDownLine',-1)]);
 $mw->bind($class,'<Control-Up>',['SetCursor',Ev('PrevPara','insert')]);
 $mw->bind($class,'<Shift-Control-Up>',['KeySelect',Ev('PrevPara','insert')]);

 $mw->bind($class,'<Down>',['SetCursor',Ev('UpDownLine',1)]);
 $mw->bind($class,'<Shift-Down>',['KeySelect',Ev('UpDownLine',1)]);
 $mw->bind($class,'<Control-Down>',['SetCursor',Ev('NextPara','insert')]);
 $mw->bind($class,'<Shift-Control-Down>',['KeySelect',Ev('NextPara','insert')]);

 $mw->bind($class,'<Home>',['SetCursor','insert linestart']);
 $mw->bind($class,'<Shift-Home>',['KeySelect','insert linestart']);
 $mw->bind($class,'<Control-Home>',['SetCursor','1.0']);
 $mw->bind($class,'<Control-Shift-Home>',['KeySelect','1.0']);

 $mw->bind($class,'<End>',['SetCursor','insert lineend']);
 $mw->bind($class,'<Shift-End>',['KeySelect','insert lineend']);
 $mw->bind($class,'<Control-End>',['SetCursor','end-1char']);
 $mw->bind($class,'<Control-Shift-End>',['KeySelect','end-1char']);

 $mw->bind($class,'<Prior>',['SetCursor',Ev('ScrollPages',-1)]);
 $mw->bind($class,'<Shift-Prior>',['KeySelect',Ev('ScrollPages',-1)]);
 $mw->bind($class,'<Control-Prior>',['xview','scroll',-1,'page']);

 $mw->bind($class,'<Next>',['SetCursor',Ev('ScrollPages',1)]);
 $mw->bind($class,'<Shift-Next>',['KeySelect',Ev('ScrollPages',1)]);
 $mw->bind($class,'<Control-Next>',['xview','scroll',1,'page']);

 $mw->bind($class,'<Shift-Tab>', 'NoOp'); # Needed only to keep <Tab> binding from triggering; does not have to actually do anything.
 $mw->bind($class,'<Control-Tab>','focusNext');
 $mw->bind($class,'<Control-Shift-Tab>','focusPrev');

 $mw->bind($class,'<Control-space>',['markSet','anchor','insert']);
 $mw->bind($class,'<Select>',['markSet','anchor','insert']);
 $mw->bind($class,'<Control-Shift-space>',['SelectTo','insert','char']);
 $mw->bind($class,'<Shift-Select>',['SelectTo','insert','char']);
 $mw->bind($class,'<Control-slash>','selectAll');
 $mw->bind($class,'<Control-backslash>','unselectAll');

 if (!$Tk::strictMotif)
  {
   $mw->bind($class,'<Control-a>',    ['SetCursor','insert linestart']);
   $mw->bind($class,'<Control-b>',    ['SetCursor','insert-1c']);
   $mw->bind($class,'<Control-e>',    ['SetCursor','insert lineend']);
   $mw->bind($class,'<Control-f>',    ['SetCursor','insert+1c']);
   $mw->bind($class,'<Meta-b>',       ['SetCursor','insert-1c wordstart']);
   $mw->bind($class,'<Meta-f>',       ['SetCursor','insert wordend']);
   $mw->bind($class,'<Meta-less>',    ['SetCursor','1.0']);
   $mw->bind($class,'<Meta-greater>', ['SetCursor','end-1c']);

   $mw->bind($class,'<Control-n>',    ['SetCursor',Ev('UpDownLine',1)]);
   $mw->bind($class,'<Control-p>',    ['SetCursor',Ev('UpDownLine',-1)]);

   $mw->bind($class,'<2>',['Button2',Ev('x'),Ev('y')]);
   $mw->bind($class,'<B2-Motion>',['Motion2',Ev('x'),Ev('y')]);
  }
 $mw->bind($class,'<Destroy>','Destroy');
 $mw->bind($class, '<3>', ['PostPopupMenu', Ev('X'), Ev('Y')]  );

 return $class;
}

sub selectAll
{
 my ($w) = @_;
 $w->tagAdd('sel','1.0','end');
}

sub unselectAll
{
 my ($w) = @_;
 $w->tagRemove('sel','1.0','end');
}

sub adjustSelect
{
 my ($w) = @_;
 my $Ev = $w->XEvent;
 $w->ResetAnchor($Ev->xy);
 $w->SelectTo($Ev->xy,'char')
}

sub selectLine
{
 my ($w) = @_;
 my $Ev = $w->XEvent;
 $w->SelectTo($Ev->xy,'line');
 Tk::catch { $w->markSet('insert','sel.first') };
}

sub selectWord
{
 my ($w) = @_;
 my $Ev = $w->XEvent;
 $w->SelectTo($Ev->xy,'word');
 Tk::catch { $w->markSet('insert','sel.first') }
}

sub ClassInit
{
 my ($class,$mw) = @_;
 $class->SUPER::ClassInit($mw);

 $class->bindRdOnly($mw);

 $mw->bind($class,'<Tab>', 'insertTab');
 $mw->bind($class,'<Control-i>', ['Insert',"\t"]);
 $mw->bind($class,'<Return>', ['Insert',"\n"]);
 $mw->bind($class,'<Delete>','Delete');
 $mw->bind($class,'<BackSpace>','Backspace');
 $mw->bind($class,'<Insert>', \&ToggleInsertMode ) ;
 $mw->bind($class,'<KeyPress>',['InsertKeypress',Ev('A')]);

 $mw->bind($class,'<F1>', 'clipboardColumnCopy');
 $mw->bind($class,'<F2>', 'clipboardColumnCut');
 $mw->bind($class,'<F3>', 'clipboardColumnPaste');

 # Additional emacs-like bindings:

 if (!$Tk::strictMotif)
  {
   $mw->bind($class,'<Control-d>',['delete','insert']);
   $mw->bind($class,'<Control-k>','deleteToEndofLine') ;
   $mw->bind($class,'<Control-o>','openLine');
   $mw->bind($class,'<Control-t>','Transpose');
   $mw->bind($class,'<Meta-d>',['delete','insert','insert wordend']);
   $mw->bind($class,'<Meta-BackSpace>',['delete','insert-1c wordstart','insert']);

   # A few additional bindings of my own.
   $mw->bind($class,'<Control-h>','deleteBefore');
   $mw->bind($class,'<ButtonRelease-2>','ButtonRelease2');
  }
 $Tk::prevPos = undef;
 return $class;
}

sub insertTab
{
 my ($w) = @_;
 $w->Insert("\t");
 $w->focus;
 $w->break
}

sub deleteToEndofLine
{
 my ($w) = @_;
 if ($w->compare('insert','==','insert lineend'))
  {
   $w->delete('insert')
  }
 else
  {
   $w->delete('insert','insert lineend')
  }
}

sub openLine
{
 my ($w) = @_;
 $w->insert('insert',"\n");
 $w->markSet('insert','insert-1c')
}

sub Button2
{
 my ($w,$x,$y) = @_;
 $w->scan('mark',$x,$y);
 $Tk::x = $x;
 $Tk::y = $y;
 $Tk::mouseMoved = 0;
}

sub Motion2
{
 my ($w,$x,$y) = @_;
 $Tk::mouseMoved = 1 if ($x != $Tk::x || $y != $Tk::y);
 $w->scan('dragto',$x,$y) if ($Tk::mouseMoved);
}

sub ButtonRelease2
{
 my ($w) = @_;
 my $Ev = $w->XEvent;
 if (!$Tk::mouseMoved)
  {
   Tk::catch { $w->insert($Ev->xy,$w->SelectionGet) }
  }
}

sub InsertSelection
{
 my ($w) = @_;
 Tk::catch { $w->Insert($w->SelectionGet) }
}

sub Backspace
{
 my ($w) = @_;
 my $sel = Tk::catch { $w->tag('nextrange','sel','1.0','end') };
 if (defined $sel)
  {
   $w->delete('sel.first','sel.last');
   return;
  }
 $w->deleteBefore;
}

sub deleteBefore
{
 my ($w) = @_;
 if ($w->compare('insert','!=','1.0'))
  {
   $w->delete('insert-1c');
   $w->see('insert')
  }
}

sub Delete
{
 my ($w) = @_;
 my $sel = Tk::catch { $w->tag('nextrange','sel','1.0','end') };
 if (defined $sel)
  {
   $w->delete('sel.first','sel.last')
  }
 else
  {
   $w->delete('insert');
   $w->see('insert')
  }
}

# Button1 --
# This procedure is invoked to handle button-1 presses in text
# widgets. It moves the insertion cursor, sets the selection anchor,
# and claims the input focus.
#
# Arguments:
# w - The text window in which the button was pressed.
# x - The x-coordinate of the button press.
# y - The x-coordinate of the button press.
sub Button1
{
 my ($w,$x,$y) = @_;
 $Tk::selectMode = 'char';
 $Tk::mouseMoved = 0;
 $w->SetCursor('@'.$x.','.$y);
 $w->markSet('anchor','insert');
 $w->focus() if ($w->cget('-state') eq 'normal');
}

sub B1_Motion
{
 my ($w) = @_;
 return unless defined $Tk::mouseMoved;
 my $Ev = $w->XEvent;
 $Tk::x = $Ev->x;
 $Tk::y = $Ev->y;
 $w->SelectTo($Ev->xy)
}

sub B1_Leave
{
 my ($w) = @_;
 my $Ev = $w->XEvent;
 $Tk::x = $Ev->x;
 $Tk::y = $Ev->y;
 $w->AutoScan;
}

# SelectTo --
# This procedure is invoked to extend the selection, typically when
# dragging it with the mouse. Depending on the selection mode (character,
# word, line) it selects in different-sized units. This procedure
# ignores mouse motions initially until the mouse has moved from
# one character to another or until there have been multiple clicks.
#
# Arguments:
# w - The text window in which the button was pressed.
# index - Index of character at which the mouse button was pressed.
sub SelectTo
{
 my ($w, $index, $mode)= @_;
 $Tk::selectMode = $mode if defined ($mode);
 my $cur = $w->index($index);
 my $anchor = Tk::catch { $w->index('anchor') };
 if (!defined $anchor)
  {
   $w->markSet('anchor',$anchor = $cur);
   $Tk::mouseMoved = 0;
  }
 elsif ($w->compare($cur,'!=',$anchor))
  {
   $Tk::mouseMoved = 1;
  }
 $Tk::selectMode = 'char' unless (defined $Tk::selectMode);
 $mode = $Tk::selectMode;
 my ($first,$last);
 if ($mode eq 'char')
  {
   if ($w->compare($cur,'<','anchor'))
    {
     $first = $cur;
     $last = 'anchor';
    }
   else
    {
     $first = 'anchor';
     $last = $cur
    }
  }
 elsif ($mode eq 'word')
  {
   if ($w->compare($cur,'<','anchor'))
    {
     $first = $w->index("$cur wordstart");
     $last = $w->index('anchor - 1c wordend')
    }
   else
    {
     $first = $w->index('anchor wordstart');
     $last = $w->index("$cur wordend")
    }
  }
 elsif ($mode eq 'line')
  {
   if ($w->compare($cur,'<','anchor'))
    {
     $first = $w->index("$cur linestart");
     $last = $w->index('anchor - 1c lineend + 1c')
    }
   else
    {
     $first = $w->index('anchor linestart');
     $last = $w->index("$cur lineend + 1c")
    }
  }
 if ($Tk::mouseMoved || $Tk::selectMode ne 'char')
  {
   $w->tagRemove('sel','1.0',$first);
   $w->tagAdd('sel',$first,$last);
   $w->tagRemove('sel',$last,'end');
   $w->idletasks;
  }
}
# AutoScan --
# This procedure is invoked when the mouse leaves a text window
# with button 1 down. It scrolls the window up, down, left, or right,
# depending on where the mouse is (this information was saved in
# tkPriv(x) and tkPriv(y)), and reschedules itself as an 'after'
# command so that the window continues to scroll until the mouse
# moves back into the window or the mouse button is released.
#
# Arguments:
# w - The text window.
sub AutoScan
{
 my ($w) = @_;
 if ($Tk::y >= $w->height)
  {
   $w->yview('scroll',2,'units')
  }
 elsif ($Tk::y < 0)
  {
   $w->yview('scroll',-2,'units')
  }
 elsif ($Tk::x >= $w->width)
  {
   $w->xview('scroll',2,'units')
  }
 elsif ($Tk::x < 0)
  {
   $w->xview('scroll',-2,'units')
  }
 else
  {
   return;
  }
 $w->SelectTo('@' . $Tk::x . ','. $Tk::y);
 $w->RepeatId($w->after(50,['AutoScan',$w]));
}
# SetCursor
# Move the insertion cursor to a given position in a text. Also
# clears the selection, if there is one in the text, and makes sure
# that the insertion cursor is visible.
#
# Arguments:
# w - The text window.
# pos - The desired new position for the cursor in the window.
sub SetCursor
{
 my ($w,$pos) = @_;
 $pos = 'end - 1 chars' if $w->compare($pos,'==','end');
 $w->markSet('insert',$pos);
 $w->unselectAll;
 $w->see('insert')
}
# KeySelect
# This procedure is invoked when stroking out selections using the
# keyboard. It moves the cursor to a new position, then extends
# the selection to that position.
#
# Arguments:
# w - The text window.
# new - A new position for the insertion cursor (the cursor has not
# actually been moved to this position yet).
sub KeySelect
{
 my ($w,$new) = @_;
 my ($first,$last);
 if (!defined $w->tag('ranges','sel'))
  {
   # No selection yet
   $w->markSet('anchor','insert');
   if ($w->compare($new,'<','insert'))
    {
     $w->tagAdd('sel',$new,'insert')
    }
   else
    {
     $w->tagAdd('sel','insert',$new)
    }
  }
 else
  {
   # Selection exists
   if ($w->compare($new,'<','anchor'))
    {
     $first = $new;
     $last = 'anchor'
    }
   else
    {
     $first = 'anchor';
     $last = $new
    }
   $w->tagRemove('sel','1.0',$first);
   $w->tagAdd('sel',$first,$last);
   $w->tagRemove('sel',$last,'end')
  }
 $w->markSet('insert',$new);
 $w->see('insert');
 $w->idletasks;
}
# ResetAnchor --
# Set the selection anchor to whichever end is farthest from the
# index argument. One special trick: if the selection has two or
# fewer characters, just leave the anchor where it is. In this
# case it does not matter which point gets chosen for the anchor,
# and for the things like Shift-Left and Shift-Right this produces
# better behavior when the cursor moves back and forth across the
# anchor.
#
# Arguments:
# w - The text widget.
# index - Position at which mouse button was pressed, which determines
# which end of selection should be used as anchor point.
sub ResetAnchor
{
 my ($w,$index) = @_;
 if (!defined $w->tag('ranges','sel'))
  {
   $w->markSet('anchor',$index);
   return;
  }
 my $a = $w->index($index);
 my $b = $w->index('sel.first');
 my $c = $w->index('sel.last');
 if ($w->compare($a,'<',$b))
  {
   $w->markSet('anchor','sel.last');
   return;
  }
 if ($w->compare($a,'>',$c))
  {
   $w->markSet('anchor','sel.first');
   return;
  }
 my ($lineA,$chA) = split(/\./,$a);
 my ($lineB,$chB) = split(/\./,$b);
 my ($lineC,$chC) = split(/\./,$c);
 if ($lineB < $lineC+2)
  {
   my $total = length($w->get($b,$c));
   if ($total <= 2)
    {
     return;
    }
   if (length($w->get($b,$a)) < $total/2)
    {
     $w->markSet('anchor','sel.last')
    }
   else
    {
     $w->markSet('anchor','sel.first')
    }
   return;
  }
 if ($lineA-$lineB < $lineC-$lineA)
  {
   $w->markSet('anchor','sel.last')
  }
 else
  {
   $w->markSet('anchor','sel.first')
  }
}

########################################################################
sub markExists
{
 my ($w, $markname)=@_;
 my $mark_exists=0;
 my @markNames_list = $w->markNames;
 foreach my $mark (@markNames_list)
  { if ($markname eq $mark) {$mark_exists=1;last;} }
 return $mark_exists;
}

########################################################################
sub OverstrikeMode
{
 my ($w,$mode) = @_;

 $w->{'OVERSTRIKE_MODE'} =0 unless exists($w->{'OVERSTRIKE_MODE'});

 $w->{'OVERSTRIKE_MODE'}=$mode if (@_ > 1);

 return $w->{'OVERSTRIKE_MODE'};
}

########################################################################
# pressed the <Insert> key, just above 'Del' key.
# this toggles between insert mode and overstrike mode.
sub ToggleInsertMode
{
 my ($w)=@_;
 $w->OverstrikeMode(!$w->OverstrikeMode);
}

########################################################################
sub InsertKeypress
{
 my ($w,$char)=@_;
 if ($w->OverstrikeMode)
  {
   my $current=$w->get('insert');
   $w->delete('insert') unless($current eq "\n");
  }
 $w->Insert($char);
}

########################################################################
sub GotoLineNumber
{
 my ($w,$line_number) = @_;
 $line_number=~ s/^\s+|\s+$//g;
 return if $line_number =~ m/\D/;
 my ($last_line,$junk)  = split(/\./, $w->index('end'));
 if ($line_number > $last_line) {$line_number = $last_line; }
 $w->{'LAST_GOTO_LINE'} = $line_number;
 $w->markSet('insert', $line_number.'.0');
 $w->see('insert');
}

########################################################################
sub GotoLineNumberPopUp
{
 my ($w)=@_;
 my $popup = $w->{'GOTO_LINE_NUMBER_POPUP'};

 unless (defined($w->{'LAST_GOTO_LINE'}))
  {
   my ($line,$col) =  split(/\./, $w->index('insert'));
   $w->{'LAST_GOTO_LINE'} = $line;
  }

 ## if anything is selected when bring up the pop-up, put it in entry window.
 my $selected;
 eval { $selected = $w->SelectionGet(-selection => "PRIMARY"); };
 unless ($@)
  {
   if (defined($selected) and length($selected))
    {
     unless ($selected =~ /\D/)
      {
       $w->{'LAST_GOTO_LINE'} = $selected;
      }
    }
  }
 unless (defined($popup))
  {
   require Tk::DialogBox;
   $popup = $w->DialogBox(-buttons => [qw[Ok Cancel]],-title => "Goto Line Number", -popover => $w,
                          -command => sub { $w->GotoLineNumber($w->{'LAST_GOTO_LINE'}) if $_[0] eq 'Ok'});
   $w->{'GOTO_LINE_NUMBER_POPUP'}=$popup;
   $popup->resizable('no','no');
   my $frame = $popup->Frame->pack(-fill => 'x');
   $frame->Label(text=>'Enter line number: ')->pack(-side => 'left');
   my $entry = $frame->Entry(-background=>'white',width=>25,
                             -textvariable => \$w->{'LAST_GOTO_LINE'})->pack(-side =>'left',-fill => 'x');
   $popup->Advertise(entry => $entry);
  }
 $popup->Popup;
 $popup->Subwidget('entry')->focus;
 $popup->Wait;
}

########################################################################

sub getSelected
{
 shift->GetTextTaggedWith('sel');
}

sub deleteSelected
{
 shift->DeleteTextTaggedWith('sel');
}

sub GetTextTaggedWith
{
 my ($w,$tag) = @_;

 my @ranges = $w->tagRanges($tag);
 my $range_total = @ranges;
 my $return_text='';

 # if nothing selected, then ignore
 if ($range_total == 0) {return $return_text;}

 # for every range-pair, get selected text
 while(@ranges)
  {
  my $first = shift(@ranges);
  my $last = shift(@ranges);
  my $text = $w->get($first , $last);
  if(defined($text))
   {$return_text = $return_text . $text;}
  # if there is more tagged text, separate with an end of line  character
  if(@ranges)
   {$return_text = $return_text . "\n";}
  }
 return $return_text;
}

########################################################################
sub DeleteTextTaggedWith
{
 my ($w,$tag) = @_;
 my @ranges = $w->tagRanges($tag);
 my $range_total = @ranges;

 # if nothing tagged with that tag, then ignore
 if ($range_total == 0) {return;}

 # insert marks where selections are located
 # marks will move with text even as text is inserted and deleted
 # in a previous selection.
 for (my $i=0; $i<$range_total; $i++)
  { $w->markSet('mark_tag_'.$i => $ranges[$i]); }

 # for every selected mark pair, insert new text and delete old text
 for (my $i=0; $i<$range_total; $i=$i+2)
  {
  my $first = $w->index('mark_tag_'.$i);
  my $last = $w->index('mark_tag_'.($i+1));

  my $text = $w->delete($first , $last);
  }

 # delete the marks
 for (my $i=0; $i<$range_total; $i++)
  { $w->markUnset('mark_tag_'.$i); }
}


########################################################################
sub FindAll
{
 my ($w,$mode, $case, $pattern ) = @_;
 ### 'sel' tags accumulate, need to remove any previous existing
 $w->unselectAll;

 my $match_length=0;
 my $start_index;
 my $end_index = '1.0';

 while(defined($end_index))
  {
  if ($case eq '-nocase')
   {
   $start_index = $w->search(
    $mode,
    $case,
    -count => \$match_length,
    "--",
    $pattern ,
    $end_index,
    'end');
   }
  else
   {
   $start_index = $w->search(
    $mode,
    -count => \$match_length,
    "--",
    $pattern ,
    $end_index,
    'end');
   }

  unless(defined($start_index) && $start_index) {last;}

  my ($line,$col) = split(/\./, $start_index);
  $col = $col + $match_length;
  $end_index = $line.'.'.$col;
  $w->tagAdd('sel', $start_index, $end_index);
  }
}

########################################################################
# get current selected text and search for the next occurrence
sub FindSelectionNext
{
 my ($w) = @_;
 my $selected;
 eval {$selected = $w->SelectionGet(-selection => "PRIMARY"); };
 return if($@);
 return unless (defined($selected) and length($selected));

 $w->FindNext('-forward', '-exact', '-case', $selected);
}

########################################################################
# get current selected text and search for the previous occurrence
sub FindSelectionPrevious
{
 my ($w) = @_;
 my $selected;
 eval {$selected = $w->SelectionGet(-selection => "PRIMARY"); };
 return if($@);
 return unless (defined($selected) and length($selected));

 $w->FindNext('-backward', '-exact', '-case', $selected);
}


########################################################################
sub FindNext
{
 my ($w,$direction, $mode, $case, $pattern ) = @_;

 ## if searching forward, start search at end of selected block
 ## if backward, start search from start of selected block.
 ## dont want search to find currently selected text.
 ## tag 'sel' may not be defined, use eval loop to trap error
 eval {
  if ($direction eq '-forward')
   {
   $w->markSet('insert', 'sel.last');
   $w->markSet('current', 'sel.last');
   }
  else
   {
   $w->markSet('insert', 'sel.first');
   $w->markSet('current', 'sel.first');
   }
 };

 my $saved_index=$w->index('insert');

 # remove any previous existing tags
 $w->unselectAll;

 my $match_length=0;
 my $start_index;

 if ($case eq '-nocase')
  {
  $start_index = $w->search(
   $direction,
   $mode,
   $case,
   -count => \$match_length,
   "--",
   $pattern ,
   'insert');
  }
 else
  {
  $start_index = $w->search(
   $direction,
   $mode,
   -count => \$match_length,
   "--",
   $pattern ,
   'insert');
  }

 unless(defined($start_index)) { return 0; }
 if(length($start_index) == 0) { return 0; }

 my ($line,$col) = split(/\./, $start_index);
 $col = $col + $match_length;
 my $end_index = $line.'.'.$col;
 $w->tagAdd('sel', $start_index, $end_index);

 $w->see($start_index);

 if ($direction eq '-forward')
  {
  $w->markSet('insert', $end_index);
  $w->markSet('current', $end_index);
  }
 else
  {
  $w->markSet('insert', $start_index);
  $w->markSet('current', $start_index);
  }

 my $compared_index = $w->index('insert');

 my $ret_val;
 if ($compared_index eq $saved_index)
  {$ret_val=0;}
 else
  {$ret_val=1;}
 return $ret_val;
}

########################################################################
sub FindAndReplaceAll
{
 my ($w,$mode, $case, $find, $replace ) = @_;
 $w->markSet('insert', '1.0');
 $w->unselectAll;
 while($w->FindNext('-forward', $mode, $case, $find))
  {
  $w->ReplaceSelectionsWith($replace);
  }
}

########################################################################
sub ReplaceSelectionsWith
{
 my ($w,$new_text ) = @_;

 my @ranges = $w->tagRanges('sel');
 my $range_total = @ranges;

 # if nothing selected, then ignore
 if ($range_total == 0) {return};

 # insert marks where selections are located
 # marks will move with text even as text is inserted and deleted
 # in a previous selection.
 for (my $i=0; $i<$range_total; $i++)
  {$w->markSet('mark_sel_'.$i => $ranges[$i]); }

 # for every selected mark pair, insert new text and delete old text
 my ($first, $last);
 for (my $i=0; $i<$range_total; $i=$i+2)
  {
  $first = $w->index('mark_sel_'.$i);
  $last = $w->index('mark_sel_'.($i+1));

  ##########################################################################
  # eventually, want to be able to get selected text,
  # support regular expression matching, determine replace_text
  # $replace_text = $selected_text=~m/$new_text/  (or whatever would work)
  # will have to pass in mode and case flags.
  # this would allow a regular expression search and replace to be performed
  # example, look for "line (\d+):" and replace with "$1 >" or similar
  ##########################################################################

  $w->insert($last, $new_text);
  $w->delete($first, $last);

  }
 ############################################################
 # set the insert cursor to the end of the last insertion mark
 $w->markSet('insert',$w->index('mark_sel_'.($range_total-1)));

 # delete the marks
 for (my $i=0; $i<$range_total; $i++)
  { $w->markUnset('mark_sel_'.$i); }
}
########################################################################
sub FindAndReplacePopUp
{
 my ($w)=@_;
 $w->findandreplacepopup(0);
}

########################################################################
sub FindPopUp
{
 my ($w)=@_;
 $w->findandreplacepopup(1);
}

########################################################################

sub findandreplacepopup
{
 my ($w,$find_only)=@_;

 my $pop = $w->Toplevel;
 if ($find_only)
  { $pop->title("Find"); }
 else
  { $pop->title("Find and/or Replace"); }
 my $frame =  $pop->Frame->pack(-anchor=>'nw');

 $frame->Label(text=>"Direction:")
  ->grid(-row=> 1, -column=>1, -padx=> 20, -sticky => 'nw');
 my $direction = '-forward';
 $frame->Radiobutton(
  variable => \$direction,
  text => '-forward',value => '-forward' )
  ->grid(-row=> 2, -column=>1, -padx=> 20, -sticky => 'nw');
 $frame->Radiobutton(
  variable => \$direction,
  text => '-backward',value => '-backward' )
  ->grid(-row=> 3, -column=>1, -padx=> 20, -sticky => 'nw');

 $frame->Label(text=>"Mode:")
  ->grid(-row=> 1, -column=>2, -padx=> 20, -sticky => 'nw');
 my $mode = '-exact';
 $frame->Radiobutton(
  variable => \$mode, text => '-exact',value => '-exact' )
  ->grid(-row=> 2, -column=>2, -padx=> 20, -sticky => 'nw');
 $frame->Radiobutton(
  variable => \$mode, text => '-regexp',value => '-regexp' )
  ->grid(-row=> 3, -column=>2, -padx=> 20, -sticky => 'nw');

 $frame->Label(text=>"Case:")
  ->grid(-row=> 1, -column=>3, -padx=> 20, -sticky => 'nw');
 my $case = '-case';
 $frame->Radiobutton(
  variable => \$case, text => '-case',value => '-case' )
  ->grid(-row=> 2, -column=>3, -padx=> 20, -sticky => 'nw');
 $frame->Radiobutton(
  variable => \$case, text => '-nocase',value => '-nocase' )
  ->grid(-row=> 3, -column=>3, -padx=> 20, -sticky => 'nw');

 ######################################################
 my $find_entry = $pop->Entry(width=>25);

 my $button_find = $pop->Button(text=>'Find',
  command => sub {$w->FindNext ($direction,$mode,$case,$find_entry->get()),} )
  -> pack(-anchor=>'nw');

 $find_entry -> pack(-anchor=>'nw', '-expand' => 'yes' , -fill => 'x'); # autosizing

 ######  if any $w text is selected, put it in the find entry
 ######  could be more than one text block selected, get first selection
 my @ranges = $w->tagRanges('sel');
 if (@ranges)
  {
  my $first = shift(@ranges);
  my $last = shift(@ranges);

  # limit to one line
  my ($first_line, $first_col) = split(/\./,$first);
  my ($last_line, $last_col) = split(/\./,$last);
  unless($first_line == $last_line)
   {$last = $first. ' lineend';}

  $find_entry->insert('insert', $w->get($first , $last));
  }
 else
  {
  my $selected;
  eval {$selected=$w->SelectionGet(-selection => "PRIMARY"); };
  if($@) {}
  elsif (defined($selected))
   {$find_entry->insert('insert', $selected);}
  }

 my ($replace_entry,$button_replace,$button_replace_all);
 unless ($find_only)
  {
  ######################################################
  $replace_entry = $pop->Entry(width=>25);
  ######################################################
  $button_replace = $pop->Button(text=>'Replace',
   command => sub {$w->ReplaceSelectionsWith($replace_entry->get());} )
   -> pack(-anchor=>'nw');

  $replace_entry -> pack(-anchor=>'nw', '-expand' => 'yes' , -fill => 'x');
  }

 ######################################################
 $pop->Label(text=>" ")->pack();
 ######################################################
 unless ($find_only)
  {
  $button_replace_all = $pop->Button(text=>'Replace All',
   command => sub {$w->FindAndReplaceAll
    ($mode,$case,$find_entry->get(),$replace_entry->get());} )
   ->pack(-side => 'left');
  }

 my $button_find_all = $pop->Button(text=>'Find All',
  command => sub {$w->FindAll($mode,$case,$find_entry->get());} )
  ->pack(-side => 'left');

  my $button_cancel = $pop->Button(text=>'Cancel',
  command => sub {$pop->destroy()} )
  ->pack(-side => 'left');

 $pop->resizable('yes','no');
 return $pop;
}

# paste clipboard into current location
sub clipboardPaste
{
 my ($w) = @_;
 local $@;
 Tk::catch { $w->Insert($w->clipboardGet) };
}

########################################################################
# Insert --
# Insert a string into a text at the point of the insertion cursor.
# If there is a selection in the text, and it covers the point of the
# insertion cursor, then delete the selection before inserting.
#
# Arguments:
# w - The text window in which to insert the string
# string - The string to insert (usually just a single character)
sub Insert
{
 my ($w,$string) = @_;
 return unless (defined $string && $string ne '');
 #figure out if cursor is inside a selection
 my @ranges = $w->tagRanges('sel');
 if (@ranges)
  {
   while (@ranges)
    {
     my ($first,$last) = splice(@ranges,0,2);
     if ($w->compare($first,'<=','insert') && $w->compare($last,'>=','insert'))
      {
       $w->ReplaceSelectionsWith($string);
       return;
      }
    }
  }
 # paste it at the current cursor location
 $w->insert('insert',$string);
 $w->see('insert');
}

# UpDownLine --
# Returns the index of the character one line above or below the
# insertion cursor. There are two tricky things here. First,
# we want to maintain the original column across repeated operations,
# even though some lines that will get passed through do not have
# enough characters to cover the original column. Second, do not
# try to scroll past the beginning or end of the text.
#
# Arguments:
# w - The text window in which the cursor is to move.
# n - The number of lines to move: -1 for up one line,
# +1 for down one line.
sub UpDownLine_old
{
 my ($w,$n) = @_;
 my $i = $w->index('insert');
 my ($line,$char) = split(/\./,$i);
 if (!defined($Tk::prevPos) || $Tk::prevPos ne $i)
  {
   $Tk::char = $char
  }
 my $new = $w->index($line+$n . '.' . $Tk::char);
 if ($w->compare($new,'==','end') || $w->compare($new,'==','insert linestart'))
  {
   $new = $i
  }
 $Tk::prevPos = $new;
 return $new;
}

sub UpDownLine
{
 my ($w,$n) = @_;
 my $i = $w->index('insert');
 my ($line,$char) = split(/\./,$i);
 my $string = $w->get($line.'.0', $i);

 $string = expand($string);
 $char=length($string);
 $line += $n;

 $string = $w->get($line.'.0', $line.'.0 lineend');
 $string = expand($string);
 $string = substr($string, 0, $char);

 $string = unexpand($string);
 $char = length($string);

 my $new = $w->index($line . '.' . $char);
 if ($w->compare($new,'==','end') || $w->compare($new,'==','insert linestart'))
  {
   $new = $i
  }
 $Tk::prevPos = $new;
 $Tk::char = $char;
 return $new;
}


# PrevPara --
# Returns the index of the beginning of the paragraph just before a given
# position in the text (the beginning of a paragraph is the first non-blank
# character after a blank line).
#
# Arguments:
# w - The text window in which the cursor is to move.
# pos - Position at which to start search.
sub PrevPara
{
 my ($w,$pos) = @_;
 $pos = $w->index("$pos linestart");
 while (1)
  {
   if ($w->get("$pos - 1 line") eq "\n" && $w->get($pos) ne "\n" || $pos eq '1.0' )
    {
     my $string = $w->get($pos,"$pos lineend");
     if ($string =~ /^(\s)+/)
      {
       my $off = length($1);
       $pos = $w->index("$pos + $off chars")
      }
     if ($w->compare($pos,'!=','insert') || $pos eq '1.0')
      {
       return $pos;
      }
    }
   $pos = $w->index("$pos - 1 line")
  }
}
# NextPara --
# Returns the index of the beginning of the paragraph just after a given
# position in the text (the beginning of a paragraph is the first non-blank
# character after a blank line).
#
# Arguments:
# w - The text window in which the cursor is to move.
# start - Position at which to start search.
sub NextPara
{
 my ($w,$start) = @_;
 my $pos = $w->index("$start linestart + 1 line");
 while ($w->get($pos) ne "\n")
  {
   if ($w->compare($pos,'==','end'))
    {
     return $w->index('end - 1c');
    }
   $pos = $w->index("$pos + 1 line")
  }
 while ($w->get($pos) eq "\n" )
  {
   $pos = $w->index("$pos + 1 line");
   if ($w->compare($pos,'==','end'))
    {
     return $w->index('end - 1c');
    }
  }
 my $string = $w->get($pos,"$pos lineend");
 if ($string =~ /^(\s+)/)
  {
   my $off = length($1);
   return $w->index("$pos + $off chars");
  }
 return $pos;
}
# ScrollPages --
# This is a utility procedure used in bindings for moving up and down
# pages and possibly extending the selection along the way. It scrolls
# the view in the widget by the number of pages, and it returns the
# index of the character that is at the same position in the new view
# as the insertion cursor used to be in the old view.
#
# Arguments:
# w - The text window in which the cursor is to move.
# count - Number of pages forward to scroll; may be negative
# to scroll backwards.
sub ScrollPages
{
 my ($w,$count) = @_;
 my @bbox = $w->bbox('insert');
 $w->yview('scroll',$count,'pages');
 if (!@bbox)
  {
   return $w->index('@' . int($w->height/2) . ',' . 0);
  }
 my $x = int($bbox[0]+$bbox[2]/2);
 my $y = int($bbox[1]+$bbox[3]/2);
 return $w->index('@' . $x . ',' . $y);
}

sub Contents
{
 my $w = shift;
 if (@_)
  {
   $w->delete('1.0','end');
   $w->insert('end',shift) while (@_);
  }
 else
  {
   return $w->get('1.0','end');
  }
}

sub Destroy
{
 my ($w) = @_;
 delete $w->{_Tags_};
}

sub Transpose
{
 my ($w) = @_;
 my $pos = 'insert';
 $pos = $w->index("$pos + 1 char") if ($w->compare($pos,'!=',"$pos lineend"));
 return if ($w->compare("$pos - 1 char",'==','1.0'));
 my $new = $w->get("$pos - 1 char").$w->get("$pos - 2 char");
 $w->delete("$pos - 2 char",$pos);
 $w->insert('insert',$new);
 $w->see('insert');
}

sub Tag
{
 my $w = shift;
 my $name = shift;
 Carp::confess('No args') unless (ref $w and defined $name);
 $w->{_Tags_} = {} unless (exists $w->{_Tags_});
 unless (exists $w->{_Tags_}{$name})
  {
   require Tk::Text::Tag;
   $w->{_Tags_}{$name} = 'Tk::Text::Tag'->new($w,$name);
  }
 $w->{_Tags_}{$name}->configure(@_) if (@_);
 return $w->{_Tags_}{$name};
}

sub Tags
{
 my ($w,$name) = @_;
 my @result = ();
 foreach $name ($w->tagNames(@_))
  {
   push(@result,$w->Tag($name));
  }
 return @result;
}

sub TIEHANDLE
{
 my ($class,$obj) = @_;
 return $obj;
}

sub PRINT
{
 my $w = shift;
 # Find out whether 'end' is displayed at the moment
 # Retrieve the position of the bottom of the window as
 # a fraction of the entire contents of the Text widget
 my $yview = ($w->yview)[1];

 # If $yview is 1.0 this means that 'end' is visible in the window
 my $update = 0;
 $update = 1 if $yview == 1.0;

 # Loop over all input strings
 while (@_)
  {
   $w->insert('end',shift);
  }
  # Move the window to see the end of the text if required
  $w->see('end') if $update;
}

sub PRINTF
{
 my $w = shift;
 $w->PRINT(sprintf(shift,@_));
}

sub WhatLineNumberPopUp
{
 my ($w)=@_;
 my ($line,$col) = split(/\./,$w->index('insert'));
 $w->messageBox(-type => 'Ok', -title => "What Line Number",
                -message => "The cursor is on line $line (column is $col)");
}

sub MenuLabels
{
 return qw[~File ~Edit ~Search ~View];
}

sub SearchMenuItems
{
 my ($w) = @_;
 return [
    ['command'=>'~Find',          -command => [$w => 'FindPopUp']],
    ['command'=>'Find ~Next',     -command => [$w => 'FindSelectionNext']],
    ['command'=>'Find ~Previous', -command => [$w => 'FindSelectionPrevious']],
    ['command'=>'~Replace',       -command => [$w => 'FindAndReplacePopUp']]
   ];
}

sub EditMenuItems
{
 my ($w) = @_;
 my @items = ();
 foreach my $op ($w->clipEvents)
  {
   push(@items,['command' => "~$op", -command => [ $w => "clipboard$op"]]);
  }
 push(@items,
    '-',
    ['command'=>'Select All', -command   => [$w => 'selectAll']],
    ['command'=>'Unselect All', -command => [$w => 'unselectAll']],
  );
 return \@items;
}

sub ViewMenuItems
{
 my ($w) = @_;
 my $v;
 tie $v,'Tk::Configure',$w,'-wrap';
 return  [
    ['command'=>'Goto ~Line...', -command => [$w => 'GotoLineNumberPopUp']],
    ['command'=>'~Which Line?',  -command =>  [$w => 'WhatLineNumberPopUp']],
    ['cascade'=> 'Wrap', -tearoff => 0, -menuitems => [
      [radiobutton => 'Word', -variable => \$v, -value => 'word'],
      [radiobutton => 'Character', -variable => \$v, -value => 'char'],
      [radiobutton => 'None', -variable => \$v, -value => 'none'],
    ]],
  ];
}

########################################################################
sub clipboardColumnCopy
{
 my ($w) = @_;
 $w->Column_Copy_or_Cut(0);
}

sub clipboardColumnCut
{
 my ($w) = @_;
 $w->Column_Copy_or_Cut(1);
}

########################################################################
sub Column_Copy_or_Cut
{
 my ($w, $cut) = @_;
 my @ranges = $w->tagRanges('sel');
 my $range_total = @ranges;
 # this only makes sense if there is one selected block
 unless ($range_total==2)
  {
  $w->bell;
  return;
  }

 my $selection_start_index = shift(@ranges);
 my $selection_end_index = shift(@ranges);

 my ($start_line, $start_column) = split(/\./, $selection_start_index);
 my ($end_line,   $end_column)   = split(/\./, $selection_end_index);

 # correct indices for tabs
 my $string;
 $string = $w->get($start_line.'.0', $start_line.'.0 lineend');
 $string = substr($string, 0, $start_column);
 $string = expand($string);
 my $tab_start_column = length($string);

 $string = $w->get($end_line.'.0', $end_line.'.0 lineend');
 $string = substr($string, 0, $end_column);
 $string = expand($string);
 my $tab_end_column = length($string);

 my $length = $tab_end_column - $tab_start_column;

 $selection_start_index = $start_line . '.' . $tab_start_column;
 $selection_end_index   = $end_line   . '.' . $tab_end_column;

 # clear the clipboard
 $w->clipboardClear;
 my ($clipstring, $startstring, $endstring);
 my $padded_string = ' 'x$tab_end_column;
 for(my $line = $start_line; $line <= $end_line; $line++)
  {
  $string = $w->get($line.'.0', $line.'.0 lineend');
  $string = expand($string) . $padded_string;
  $clipstring = substr($string, $tab_start_column, $length);
  #$clipstring = unexpand($clipstring);
  $w->clipboardAppend($clipstring."\n");

  if ($cut)
   {
   $startstring = substr($string, 0, $tab_start_column);
   $startstring = unexpand($startstring);
   $start_column = length($startstring);

   $endstring = substr($string, 0, $tab_end_column );
   $endstring = unexpand($endstring);
   $end_column = length($endstring);

   $w->delete($line.'.'.$start_column,  $line.'.'.$end_column);
   }
  }
}

########################################################################

sub clipboardColumnPaste
{
 my ($w) = @_;
 my @ranges = $w->tagRanges('sel');
 my $range_total = @ranges;
 if ($range_total)
  {
  warn " there cannot be any selections during clipboardColumnPaste. \n";
  $w->bell;
  return;
  }

 my $clipboard_text;
 eval
  {
  $clipboard_text = $w->SelectionGet(-selection => "CLIPBOARD");
  };

 return unless (defined($clipboard_text));
 return unless (length($clipboard_text));
 my $string;

 my $current_index = $w->index('insert');
 my ($current_line, $current_column) = split(/\./,$current_index);
 $string = $w->get($current_line.'.0', $current_line.'.'.$current_column);
 $string = expand($string);
 $current_column = length($string);

 my @clipboard_lines = split(/\n/,$clipboard_text);
 my $length;
 my $end_index;
 my ($delete_start_column, $delete_end_column, $insert_column_index);
 foreach my $line (@clipboard_lines)
  {
  if ($w->OverstrikeMode)
   {
   #figure out start and end indexes to delete, compensating for tabs.
   $string = $w->get($current_line.'.0', $current_line.'.0 lineend');
   $string = expand($string);
   $string = substr($string, 0, $current_column);
   $string = unexpand($string);
   $delete_start_column = length($string);

   $string = $w->get($current_line.'.0', $current_line.'.0 lineend');
   $string = expand($string);
   $string = substr($string, 0, $current_column + length($line));
   chomp($string);  # dont delete a "\n" on end of line.
   $string = unexpand($string);
   $delete_end_column = length($string);


   $w->delete(
              $current_line.'.'.$delete_start_column ,
              $current_line.'.'.$delete_end_column
             );
   }

  $string = $w->get($current_line.'.0', $current_line.'.0 lineend');
  $string = expand($string);
  $string = substr($string, 0, $current_column);
  $string = unexpand($string);
  $insert_column_index = length($string);

  $w->insert($current_line.'.'.$insert_column_index, unexpand($line));
  $current_line++;
  }

}

# Backward compatibility
sub GetMenu
{
 carp((caller(0))[3]." is deprecated") if $^W;
 shift->menu
}

1;
__END__