# This file converted to perltk using the tcl2perl script and much hand-editing.
# jc 6/26/00
#
# table.tcl --
#
# version align with tkTable 2.7, jeff.hobbs@acm.org
# This file defines the default bindings for Tk table widgets
# and provides procedures that help in implementing those bindings.
#
#--------------------------------------------------------------------------
# tkPriv elements used in this file:
#
# afterId - Token returned by "after" for autoscanning.
# tablePrev - The last element to be selected or deselected
# during a selection operation.
# mouseMoved - Boolean to indicate whether mouse moved while
# the button was pressed.
# borderInfo - Boolean to know if the user clicked on a border
# borderB1 - Boolean that set whether B1 can be used for the
# interactiving resizing
#--------------------------------------------------------------------------
## Interactive cell resizing, affected by -resizeborders option
##
package Tk::TableMatrix;
use AutoLoader;
use Carp;
use strict;
use vars( '%tkPriv', '$VERSION');
$VERSION = '1.23';
use Tk qw( Ev );
use base qw(Tk::Widget);
Construct Tk::Widget 'TableMatrix';
bootstrap Tk::TableMatrix;
sub Tk_cmd { \&Tk::tablematrix };
sub Tk::Widget::ScrlTableMatrix { shift->Scrolled('TableMatrix' => @_) }
Tk::Methods("activate", "bbox", "border", "cget", "clear", "configure",
"curselection", "curvalue", "delete", "get", "rowHeight",
"hidden", "icursor", "index", "insert",
"postscript",
"reread", "scan", "see", "selection", "set",
"spans", "tag", "validate", "version", "window", "colWidth",
"xview", "yview");
use Tk::Submethods ( 'border' => [qw(mark dragto)],
'clear' => [qw(cache sizes tags all)],
'delete' => [qw(active cols rows)],
'insert' => [qw(active cols rows)],
'scan' => [qw(mark dragto)],
'selection'=> [qw(anchor clear includes set)],
'tag' => [qw(cell cget col configure delete exists
includes names row raise lower)],
'window' => [qw(cget configure delete move names)],
'xview' => [qw(moveto scroll)],
'yview' => [qw(moveto scroll)],
);
sub ClassInit
{
my ($class,$mw) = @_;
$tkPriv{borderB1} = 1; # initialize borderB1
$mw->bind($class,'<3>',
sub
{
my $w = shift;
my $Ev = $w->XEvent;
## You might want to check for cell returned if you want to
## restrict the resizing of certain cells
$w->border('mark',$Ev->x,$Ev->y);
}
);
$mw->bind($class,'<B3-Motion>',['border','dragto',Ev('x'),Ev('y')]);
$mw->bind($class,'<1>',
sub
{
my $w = shift;
my $Ev = $w->XEvent;
$w->Button1($Ev->x,$Ev->y);
}
);
$mw->bind($class,'<B1-Motion>',
sub
{
my $w = shift;
my $Ev = $w->XEvent;
$w->B1Motion($Ev->x,$Ev->y);
}
);
$mw->bind($class,'<ButtonRelease-1>',
sub
{
my $w = shift;
my $Ev = $w->XEvent;
$tkPriv{borderInfo} = "";
if ($w->exists)
{
$w->CancelRepeat;
$w->activate('@' . $Ev->x.",".$Ev->y);
}
}
);
$mw->bind($class,'<Shift-1>',
sub
{
my $w = shift;
my $Ev = $w->XEvent;
$w->BeginExtend( $w->index('@' . $Ev->x.",".$Ev->y));
}
);
$mw->bind($class,'<Control-1>',
sub
{
my $w = shift;
my $Ev = $w->XEvent;
$w->BeginToggle($w->index('@' . $Ev->x.",".$Ev->y));
}
);
$mw->bind($class,'<B1-Enter>','CancelRepeat');
$mw->bind($class,'<B1-Leave>',
sub
{
my $w = shift;
my $Ev = $w->XEvent;
if( !$tkPriv{borderInfo} ){
$tkPriv{x} = $Ev->x; $tkPriv{y} = $Ev->y;
$w->AutoScan;
}
}
);
$mw->bind($class,'<2>',
sub
{
my $w = shift;
my $Ev = $w->XEvent;
$w->scan('mark',$Ev->x,$Ev->y);
$tkPriv{x} = $Ev->x; $tkPriv{y} = $Ev->y;
$tkPriv{'mouseMoved'} = 0;
}
);
$mw->bind($class,'<B2-Motion>',
sub
{
my $w = shift;
my $Ev = $w->XEvent;
$tkPriv{'mouseMoved'} = 1 if ($Ev->x ne $tkPriv{'x'} || $Ev->y ne $tkPriv{'y'});
$w->scan('dragto',$Ev->x,$Ev->y) if ($tkPriv{'mouseMoved'});
}
);
$mw->bind($class,'<ButtonRelease-2>',
sub
{
my $w = shift;
my $Ev = $w->XEvent;
$w->Paste($w->index('@' . $Ev->x.",".$Ev->y)) unless ($tkPriv{'mouseMoved'});
}
);
ClipboardKeysyms( $mw, $class, qw/ <Copy> <Cut> <Paste> /);
ClipboardKeysyms( $mw, $class, 'Control-c', 'Control-x', 'Control-v');
############################
$mw->bind($class,'<<Table_Commit>>',
sub
{
my $w = shift;
my $Ev = $w->XEvent;
eval
{
$w->activate('active');
}
;
}
);
# Remove this if you don't want cell commit to occur on every Leave for
# the table (via mouse) or FocusOut (loss of focus by table).
$mw->eventAdd( qw[ <<Table_Commit>> <Leave> <FocusOut> ]);
$mw->bind($class,'<Shift-Up>',['ExtendSelect',-1,0]);
$mw->bind($class,'<Shift-Down>',['ExtendSelect',1,0]);
$mw->bind($class,'<Shift-Left>',['ExtendSelect',0,-1]);
$mw->bind($class,'<Shift-Right>',['ExtendSelect',0,1]);
$mw->bind($class,'<Prior>',
sub
{
my $w = shift;
my $Ev = $w->XEvent;
$w->yview('scroll',-1,'pages');
$w->activate('@0,0');
}
);
$mw->bind($class,'<Next>',
sub
{
my $w = shift;
my $Ev = $w->XEvent;
$w->yview('scroll',1,'pages');
$w->activate('@0,0');
}
);
$mw->bind($class,'<Control-Prior>',['xview','scroll',-1,'pages']);
$mw->bind($class,'<Control-Next>',['xview','scroll',1,'pages']);
$mw->bind($class,'<Home>',['see','origin']);
$mw->bind($class,'<End>',['see','end']);
$mw->bind($class,'<Control-Home>',
sub
{
my $w = shift;
my $Ev = $w->XEvent;
$w->selection('clear','all');
$w->activate('origin');
$w->selection('set','active');
$w->see('active');
}
);
$mw->bind($class,'<Control-End>',
sub
{
my $w = shift;
my $Ev = $w->XEvent;
$w->selection('clear','all');
$w->activate('end');
$w->selection('set','active');
$w->see('active');
}
);
$mw->bind($class,'<Shift-Control-Home>',['DataExtend','origin']);
$mw->bind($class,'<Shift-Control-End>',['DataExtend','end']);
$mw->bind($class,'<Select>',['BeginSelect',Ev('index','active')]);
$mw->bind($class,'<Shift-Select>',['BeginExtend',Ev('index','active')]);
$mw->bind($class,'<Control-slash>','SelectAll');
$mw->bind($class,'<Control-backslash>',
sub
{
my $w = shift;
my $Ev = $w->XEvent;
$w->selection('clear','all') if ($w->cget(-selectmode) =~ /browse/);
}
);
$mw->bind($class,'<Up>',['MoveCell',-1,0]);
$mw->bind($class,'<Down>',['MoveCell',1,0]);
$mw->bind($class,'<Left>',['MoveCell',0,-1]);
$mw->bind($class,'<Right>',['MoveCell',0,1]);
$mw->bind($class,'<KeyPress>',['TableInsert',Ev('A')]);
$mw->bind($class,'<BackSpace>',['BackSpace']);
$mw->bind($class,'<Delete>',['delete','active','insert']);
$mw->bind($class,'<Escape>','reread');
$mw->bind($class,'<Return>',['TableInsert',"\n"]);
$mw->bind($class,'<Control-Left>',
sub
{
my $w = shift;
my $Ev = $w->XEvent;
my $posn = $w->icursor;
$w->icursor($posn - 1);
}
);
$mw->bind($class,'<Control-Right>',
sub
{
my $w = shift;
my $Ev = $w->XEvent;
my $posn = $w->icursor;
$w->icursor($posn + 1);
}
);
$mw->bind($class,'<Control-e>',['icursor','end']);
$mw->bind($class,'<Control-a>',['icursor',0]);
$mw->bind($class,'<Control-k>',['delete','active','insert','end']);
$mw->bind($class,'<Control-equal>',['ChangeWidth','active',1]);
$mw->bind($class,'<Control-minus>',['ChangeWidth','active',-1]);
# Ignore all Alt, Meta, and Control keypresses unless explicitly bound.
# Otherwise, if a widget binding for one of these is defined, the
# <KeyPress> class binding will also fire and insert the character,
# which is wrong. Ditto for Tab.
$mw->bind($class,'<Alt-KeyPress>',
sub
{
my $w = shift;
my $Ev = $w->XEvent;
# nothing
}
);
$mw->bind($class,'<Meta-KeyPress>',
sub
{
my $w = shift;
my $Ev = $w->XEvent;
# nothing
}
);
$mw->bind($class,'<Control-KeyPress>',
sub
{
my $w = shift;
my $Ev = $w->XEvent;
#
}
);
$mw->bind($class,'<Any-Tab>',
sub
{
my $w = shift;
my $Ev = $w->XEvent;
#
}
);
}
# ::tk::table::GetSelection --
# This tries to obtain the default selection. On Unix, we first try
# and get a UTF8_STRING, a type supported by modern Unix apps for
# passing Unicode data safely. We fall back on the default STRING
# type otherwise. On Windows, only the STRING type is necessary.
# Arguments:
# w The widget for which the selection will be retrieved.
# Important for the -displayof property.
# sel The source of the selection (PRIMARY or CLIPBOARD)
# Results:
# Returns the selection, or an error if none could be found
#
sub GetSelection{
my $w = shift;
my $sel = shift;
$sel ||= 'PRIMARY';
my $txt;
if( $Tk::platform eq 'unix'){
eval{ $txt = $w->SelectionGet( -selection => $sel) };
if( $@){
warn("Could not find default selection\n");
return undef;
}
return $txt;
}
else{
eval{ $txt = $w->SelectionGet( -selection => $sel) };
if( $@){
warn("Could not find default selection\n");
return undef;
}
return $txt;
}
}
# ClipboardKeysyms --
# This procedure is invoked to identify the keys that correspond to
# the "copy", "cut", and "paste" functions for the clipboard.
#
# Arguments:
# copy - Name of the key (keysym name plus modifiers, if any,
# such as "Meta-y") used for the copy operation.
# cut - Name of the key used for the cut operation.
# paste - Name of the key used for the paste operation.
sub ClipboardKeysyms
{
my $mw = shift;
my $class = shift;
my $copy = shift;
my $cut = shift;
my $paste = shift;
$mw->bind($class,"<$copy>",'Copy');
$mw->bind($class,"<$cut>",'Cut');
$mw->bind($class,"<$paste>",'Paste');
}
# TableInsert --
#
# Insert into the active cell
#
# Arguments:
# w - the table widget
# s - the string to insert
# Results:
# Returns nothing
#
sub TableInsert
{
my $w = shift;
my $s = shift;
$w->insert('active','insert',$s) if ($s ne '' ) ;
}
# ::tk::table::BackSpace --
#
# BackSpace in the current cell
#
# Arguments:
# w - the table widget
# Results:
# Returns nothing
#
sub BackSpace{
my $w = shift;
my $Ev = $w->XEvent;
my $posn = $w->icursor;
$w->delete('active',$posn - 1) if( $posn > -1);
}
# Button1 --
#
# This procedure is called to handle selecting with mouse button 1.
# It will distinguish whether to start selection or mark a border.
#
# Arguments:
# w - the table widget
# x - x coord
# y - y coord
# Results:
# Returns nothing
#
sub Button1 {
my $w = shift;
my ( $x, $y ) = @_;
# borderInfo is null if the user did not click on a border
if ( $tkPriv{borderB1} == 1 ) {
$tkPriv{borderInfo} = $w->borderMark( $x, $y );
}
else {
$tkPriv{borderInfo} = "";
}
if ( ! $tkPriv{borderInfo} ) {
#
# Only do this when a border wasn't selected
#
if ( $w->exists ) {
$w->BeginSelect( $w->index( '@' . "$x,$y" ) );
$w->focus;
}
$tkPriv{x} = $x;
$tkPriv{y} = $y;
$tkPriv{mouseMoved} = 0;
}
}
# B1Motion --
#
# This procedure is called to start processing mouse motion events while
# button 1 moves while pressed. It will distinguish whether to change
# the selection or move a border.
#
# Arguments:
# w - the table widget
# x - x coord
# y - y coord
# Results:
# Returns nothing
#
sub B1Motion {
my $w = shift;
my ( $x, $y ) = @_;
# If we already had motion, or we moved more than 1 pixel,
# then we start the Motion routine
if ( $tkPriv{borderInfo} ) {
#
# If the motion is on a border, drag it and skip the rest
# of this binding.
#
$w->borderDragto( $x, $y );
}
else {
#
# If we already had motion, or we moved more than 1 pixel,
# then we start the Motion routine
#
if ( $tkPriv{mouseMoved}
|| abs( $x - $tkPriv{x} ) > 1
|| abs( $y - $tkPriv{y} ) > 1 ) {
$tkPriv{mouseMoved} = 1;
}
if ( $tkPriv{mouseMoved} ) {
$w->Motion( $w->index( '@' . "$x,$y" ) );
}
}
}
# BeginSelect --
#
# This procedure is typically invoked on button-1 presses. It begins
# the process of making a selection in the table. Its exact behavior
# depends on the selection mode currently in effect for the table;
# see the Motif documentation for details.
#
# Arguments:
# w - The table widget.
# el - The element for the selection operation (typically the
# one under the pointer). Must be in row,col form.
sub BeginSelect
{
my $w = shift;
my $el = shift;
my $r;
my $c;
my $inc;
my $el2;
return unless( scalar( ($r,$c) = split(",",$el)) ==2); # Get Rol Col or return
my $selectmode = $w->cget('-selectmode');
if ($selectmode eq 'multiple')
{
if ($w->tag('includes','title',$el))
{
## in the title area
if ($r < ($w->cget('-titlerows') + $w->cget('-roworigin')) )
{
## We're in a column header
if ($c < ( $w->cget('-titlecols') + $w->cget('-colorigin')))
{
## We're in the topleft title area
$inc = 'topleft';
$el2 = 'end';
}
else
{
$inc = $w->index('topleft','row').",$c";
$el2 = $w->index('end','row').",$c";
}
}
else
{
## We're in a row header
$inc = "$r,".$w->index('topleft','col');
$el2 = "$r,".$w->index('end','col');
}
}
else
{
$inc = $el;
$el2 = $el;
}
if ($w->selection('includes',$inc))
{
$w->selection('clear',$el,$el2);
}
else
{
$w->selection('set',$el,$el2);
}
}
elsif ($selectmode eq 'extended')
{
$w->selection('clear','all');
if ($w->tag('includes','title',$el))
{
if ($r < ($w->cget('-titlerows') + $w->cget('-roworigin')))
{
## We're in a column header
if ($c < ( $w->cget('-titlecols') + $w->cget('-colorigin')) )
{
$w->selection('set',$el,'end');
}
else
{
$w->selection('set',$el,$w->index('end','row').",$c");
}
}
else
{
## We're in a row header
$w->selection('set',$el,"$r,".$w->index('end','col'));
}
}
else
{
$w->selection('set',$el);
}
$w->selection('anchor',$el);
$tkPriv{'tablePrev'} = $el;
}
elsif ($selectmode eq 'default')
{
unless ($w->tag('includes','title',$el))
{
$w->selection('clear','all');
$w->selection('set',$el);
$tkPriv{'tablePrev'} = $el;
}
$w->selection('anchor',$el);
}
}
# Motion --
#
# This procedure is called to process mouse motion events while
# button 1 is down. It may move or extend the selection, depending
# on the table's selection mode.
#
# Arguments:
# w - The table widget.
# el - The element under the pointer (must be in row,col form).
sub Motion
{
my $w = shift;
my $el = shift;
my $r;
my $c;
my $elc;
my $elr;
unless (exists($tkPriv{'tablePrev'}))
{
$tkPriv{'tablePrev'} = $el;
return;
}
return if ($tkPriv{'tablePrev'} eq $el );
my $selectmode = $w->cget('-selectmode');
if ($selectmode eq 'browse')
{
$w->selection('clear','all');
$w->selection('set',$el);
$tkPriv{'tablePrev'} = $el;
}
elsif ($selectmode eq 'extended')
{
# avoid tables that have no anchor index yet.
my $indexAnchor;
eval{ $indexAnchor = $w->index('anchor') };
return if( $@ || !$indexAnchor);
($r,$c) = split(",",$tkPriv{tablePrev});
($elr,$elc) = split(",",$el);
if ($w->tag('includes','title',$el))
{
if ($r < ($w->cget('-titlerows') + $w->cget('-roworigin')) )
{
## We're in a column header
if ($c < ( $w->cget('-titlecols') + $w->cget('-colorigin')) )
{
## We're in the topleft title area
$w->selection('clear','anchor','end');
}
else
{
$w->selection('clear','anchor',$w->index('end','row').",$c");
}
##### perltk: Removed comma
$w->selection('set','anchor',$w->index('end','row').",$elc");
}
else
{
## We're in a row header
$w->selection('clear','anchor',"$r,".$w->index('end','col'));
$w->selection('set','anchor',"$elr,".$w->index('end','col'));
}
}
else
{
$w->selection('clear','anchor',$tkPriv{'tablePrev'});
$w->selection('set','anchor',$el);
}
$tkPriv{'tablePrev'} = $el;
}
}
# BeginExtend --
#
# This procedure is typically invoked on shift-button-1 presses. It
# begins the process of extending a selection in the table. Its
# exact behavior depends on the selection mode currently in effect
# for the table; see the Motif documentation for details.
#
# Arguments:
# w - The table widget.
# el - The element for the selection operation (typically the
# one under the pointer). Must be in numerical form.
sub BeginExtend
{
my $w = shift;
my $el = shift;
$w->Motion($el) if ($w->cget(-selectmode) eq 'extended' && $w->selectionIncludes('anchor'));
}
# BeginToggle --
#
# This procedure is typically invoked on control-button-1 presses. It
# begins the process of toggling a selection in the table. Its
# exact behavior depends on the selection mode currently in effect
# for the table; see the Motif documentation for details.
#
# Arguments:
# w - The table widget.
# el - The element for the selection operation (typically the
# one under the pointer). Must be in numerical form.
sub BeginToggle
{
my $w = shift;
my $el = shift;
my $r;
my $c;
my $end;
if ( $w->cget( -selectmode ) =~ /extended/i )
{
$tkPriv{'tablePrev'} = $el;
$w->selection('anchor',$el);
if ($w->tag('includes','title',$el))
{
# scan $el %d,%d r c
($r,$c) = split( ",",$el);
if ($r < ($w->cget('-titlerows') + $w->cget('-roworigin')) )
{
## We're in a column header
if ($c < ($w->cget('-titlecols') + $w->cget('-colorigin')))
{
## We're in the topleft title area
$end = 'end';
}
else
{
$end = $w->index('end','row');
}
}
else
{
## We're in a row header
$end = "$r,".$w->index('end','row');
}
}
else
{
## We're in a non-title cell
$end = $el;
}
if ($w->selection('includes',$end))
{
$w->selection('clear',$el,$end);
}
else
{
$w->selection('set',$el,$end);
}
}
}
# AutoScan --
# This procedure is invoked when the mouse leaves an table window
# with button 1 down. It scrolls the window up, down, left, or
# right, depending on where the mouse left the window, 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 table window.
sub AutoScan
{
my $w = shift;
my $x;
my $y;
return unless ($w->exists);
$x = $tkPriv{'x'};
$y = $tkPriv{'y'};
if ($y >= $w->SUPER::height) # we don't want our height here, we want the
# actual height of the window
{
$w->yview('scroll',1,'units');
}
elsif ($y < 0)
{
$w->yview('scroll',-1,'units');
}
elsif ($x >= $w->SUPER::width)
{
$w->xview('scroll',1,'units');
}
elsif ($x < 0)
{
$w->xview('scroll',-1,'units');
}
else
{
return;
}
$w->Motion($w->index('@' . $x.','.$y));
$tkPriv{'afterId'} = $w->after(50,[$w,'AutoScan']);
}
# MoveCell --
#
# Moves the location cursor (active element) by the specified number
# of cells and changes the selection if we're in browse or extended
# selection mode. If the new cell is "hidden", we skip to the next
# visible cell if possible, otherwise just abort.
#
# Arguments:
# w - The table widget.
# x - +1 to move down one cell, -1 to move up one cell.
# y - +1 to move right one cell, -1 to move left one cell.
sub MoveCell
{
my $w = shift;
my $x = shift;
my $y = shift;
my $c;
my $cell;
my $r;
my $true;
eval { $r = $w->index('active','row') }; return if( $@);
$c = $w->index('active','col');
# set cell [$w index [incr r $x],[incr c $y]]
$cell = $w->index(($r += $x).",".($c += $y));
while ( ($true = $w->index('active')) eq '')
{
# The cell is in some way hidden
if ($true eq $w->index('active'))
{
# The span cell wasn't the previous cell, so go to that
$cell = $true;
last;
}
if ($x > 0)
{
++ $r;
}
elsif ($x < 0)
{
$r += -1;
}
if ($y > 0)
{
++ $c;
}
elsif ($y < 0)
{
$c += -1;
}
if ($cell eq $w->index($r.",".$c))
{
$cell = $w->index("$r,$c");
}
else
{
# We couldn't find a non-hidden cell, just don't move
return;
}
}
$w->activate($cell);
$w->see('active');
if ($w->cget('-selectmode') eq 'browse')
{
$w->selection('clear','all');
$w->selection('set','active');
}
elsif ($w->cget('-selectmode') eq 'extended')
{
$w->selection('clear','all');
$w->selection('set','active');
$w->selection('anchor','active');
$tkPriv{'tablePrev'} = $w->index('active');
}
}
# ExtendSelect --
#
# Does nothing unless we're in extended selection mode; in this
# case it moves the location cursor (active element) by the specified
# number of cells, and extends the selection to that point.
#
# Arguments:
# w - The table widget.
# x - +1 to move down one cell, -1 to move up one cell.
# y - +1 to move right one cell, -1 to move left one cell.
sub ExtendSelect
{
my $w = shift;
my $x = shift;
my $y = shift;
my $c;
my $r;
#### Perltk notes: (should be 'ne' instead of 'eq' ???
return unless ( $w->cget(-selectmode) eq 'extended');
eval { $r = $w->index('active','row'); }; return if($@);
$c = $w->index('active','col');
$w->activate( ($r += $x).",".($c += $y));
$w->see('active');
$w->Motion($w->index('active'));
}
# DataExtend
#
# This procedure is called for key-presses such as Shift-KEndData.
# If the selection mode isnt multiple or extend then it does nothing.
# Otherwise it moves the active element to el and, if we're in
# extended mode, extends the selection to that point.
#
# Arguments:
# w - The table widget.
# el - An integer cell number.
sub DataExtend
{
my $w = shift;
my $el = shift;
my $mode;
$mode = $w->cget('-selectmode');
if ($mode =~ /extended/i )
{
$w->activate($el);
$w->see($el);
$w->Motion($el) if ($w->selection('includes','anchor'));
}
elsif ($mode =~ /multiple/i)
{
$w->activate($el);
$w->see($el);
}
}
# SelectAll
#
# This procedure is invoked to handle the "select all" operation.
# For single and browse mode, it just selects the active element.
# Otherwise it selects everything in the widget.
#
# Arguments:
# w - The table widget.
sub SelectAll
{
my $w = shift;
if ( $w->cget(-selectmode) =~ /^(single|browse)$/)
{
$w->selection('clear','all');
$w->selection('set','active');
$w->TableMatrixHandleType($w->index('active'));
}
else
{
$w->selection('set','origin','end');
}
}
# ChangeWidth --
# Adjust the widget of the specified cell by $a.
#
# Arguments:
# w - The table widget.
# i - cell index
# a - amount to adjust by
sub ChangeWidth
{
my $w = shift;
my $i = shift;
my $a = shift;
my $tmp;
my $width;
$tmp = $w->index($i,'col');
if (($width = $w->colWidth($tmp)) >= 0)
{
$w->colWidth($tmp,$width += $a);
}
else
{
$w->colWidth($tmp,$width += -$a);
}
}
# Copy --
# This procedure copies the selection from a table widget into the
# clipboard.
#
# Arguments:
# w - Name of a table widget.
sub Copy
{
my $w = shift;
if ($w->SelectionOwner() eq $w)
{
$w->clipboardClear;
eval
{
$w->clipboardAppend($w->GetSelection);
}
;
}
}
# Cut --
# This procedure copies the selection from a table widget into the
# clipboard, then deletes the selection (if it exists in the given
# widget).
#
# Arguments:
# w - Name of a table widget.
sub Cut
{
my $w = shift;
if ($w->SelectionOwner() eq $w)
{
$w->clipboardClear;
eval
{
$w->clipboardAppend($w->GetSelection);
$w->curselection('');# Clear whatever is selected
$w->selectionClear();
}
;
}
}
# Paste --
# This procedure pastes the contents of the clipboard to the specified
# cell (active by default) in a table widget.
#
# Arguments:
# w - Name of a table widget.
# cell - Cell to start pasting in.
sub Paste
{
my $w = shift;
my $cell = shift || ''; ## Perltk not sure if translated correctly
my $data;
if ($cell ne '')
{
eval{ $data = $w->GetSelection(); }; return if($@);
}
else
{
eval{ $data = $w->GetSelection('CLIPBOARD'); }; return if($@);
$cell = 'active';
}
$w->PasteHandler($w->index($cell),$data);
$w->focus if ($w->cget('-state') eq 'normal');
}
# PasteHandler --
# This procedure handles how data is pasted into the table widget.
# This handles data in the default table selection form.
# NOTE: this allows pasting into all cells, even those with -state disabled
#
# Arguments:
# w - Name of a table widget.
# cell - Cell to start pasting in.
sub PasteHandler
{
my $w = shift;
my $cell = shift;
my $data = shift;
#
# Don't allow pasting into the title cells
#
return if( $w->tagIncludes('title', $cell));
my $rows;
my $cols;
my $r;
my $c;
my $rsep;
my $csep;
my $row;
my $line;
my $col;
my $item;
$rows = $w->cget('-rows') - $w->cget('-roworigin');
$cols = $w->cget('-cols') - $w->cget('-colorigin');
$r = $w->index($cell,'row');
$c = $w->index($cell,'col');
$rsep = $w->cget('-rowseparator');
$csep = $w->cget('-colseparator');
## Assume separate rows are split by row separator if specified
## If you were to want multi-character row separators, you would need:
# regsub -all $rsep $data <newline> data
# set data [join $data <newline>]
my @data;
@data = split($rsep,$data) if ($rsep ne '');
$row = $r;
foreach $line (@data)
{
last if ($row > $rows);
$col = $c;
## Assume separate cols are split by col separator if specified
## Unless a -separator was specified
my @line = split($csep, $line) if ($csep ne '');
## If you were to want multi-character col separators, you would need:
# regsub -all $csep $line <newline> line
# set line [join $line <newline>]
foreach $item (@line)
{
last if ($col > $cols);
$w->set("$row,$col",$item);
++ $col;
}
++ $row;
}
}
#############################################################
## CancelRepeat
# This procedure is invoked to cancel an auto-repeat action described
# by $Tk::TableMatrix::tkPriv{afterId}. It's used by several widgets to auto-scroll
# the widget when the mouse is dragged out of the widget with a
# button pressed.
sub CancelRepeat{
my $w = shift;
my $id = delete $tkPriv{'afterId'};
$w->afterCancel($id) if($id);
}
1;
__END__