home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / TableMatrix.pm < prev    next >
Encoding:
Perl POD Document  |  2002-12-06  |  26.1 KB  |  1,167 lines
  1. # This file converted to perltk using the tcl2perl script and much hand-editing.
  2. #   jc 6/26/00
  3. #
  4. # table.tcl --
  5. #
  6. # version align with tkTable 2.7, jeff.hobbs@acm.org
  7. # This file defines the default bindings for Tk table widgets
  8. # and provides procedures that help in implementing those bindings.
  9. #
  10. #--------------------------------------------------------------------------
  11. # tkPriv elements used in this file:
  12. #
  13. # afterId -        Token returned by "after" for autoscanning.
  14. # tablePrev -        The last element to be selected or deselected
  15. #            during a selection operation.
  16. # mouseMoved -        Boolean to indicate whether mouse moved while
  17. #            the button was pressed.
  18. # borderInfo -        Boolean to know if the user clicked on a border
  19. # borderB1 -        Boolean that set whether B1 can be used for the
  20. #            interactiving resizing
  21. #--------------------------------------------------------------------------
  22. ## Interactive cell resizing, affected by -resizeborders option
  23. ##
  24. package Tk::TableMatrix;
  25.  
  26. use AutoLoader;
  27. use Carp;
  28. use strict;
  29. use vars( '%tkPriv', '$VERSION');
  30.  
  31. $VERSION = '1.01';
  32.  
  33. use Tk qw( Ev );
  34.  
  35. use base qw(Tk::Widget);
  36.  
  37. Construct Tk::Widget 'TableMatrix';
  38.  
  39. bootstrap Tk::TableMatrix;
  40.  
  41. sub Tk_cmd { \&Tk::tablematrix };
  42.  
  43. sub Tk::Widget::ScrlTableMatrix { shift->Scrolled('TableMatrix' => @_) }
  44.  
  45. Tk::Methods("activate", "bbox", "border", "cget", "clear", "configure",
  46.     "curselection", "curvalue", "delete", "get", "rowHeight",
  47.     "hidden", "icursor", "index", "insert",
  48.     "postscript",
  49.     "reread", "scan", "see", "selection", "set",
  50.     "spans", "tag", "validate", "version", "window", "colWidth",
  51.     "xview", "yview");
  52.     
  53. use Tk::Submethods ( 'border'   => [qw(mark dragto)],
  54.              'clear'    => [qw(cache sizes tags all)],
  55.              'delete'   => [qw(active cols rows)],
  56.              'insert'   => [qw(active cols rows)],
  57.              'scan'     => [qw(mark dragto)],
  58.              'selection'=> [qw(anchor clear includes set)],
  59.              'tag'      => [qw(cell cget col configure delete exists
  60.                      includes names row raise lower)],
  61.              'window'   => [qw(cget configure delete move names)],
  62.              'xview'  => [qw(moveto scroll)],
  63.              'yview'  => [qw(moveto scroll)],
  64.             );
  65.  
  66.  
  67.  
  68. sub ClassInit
  69. {
  70.  my ($class,$mw) = @_;
  71.  
  72. $tkPriv{borderB1} = 1; # initialize borderB1
  73.  
  74. $mw->bind($class,'<3>',
  75.   sub
  76.    {
  77.     my $w = shift;
  78.     my $Ev = $w->XEvent;
  79.     ## You might want to check for cell returned if you want to
  80.     ## restrict the resizing of certain cells
  81.     $w->border('mark',$Ev->x,$Ev->y);
  82.    }
  83.  );
  84.  
  85.  
  86.  $mw->bind($class,'<B3-Motion>',['border','dragto',Ev('x'),Ev('y')]);
  87.  $mw->bind($class,'<1>',
  88.   sub
  89.    {
  90.     my $w = shift;
  91.     my $Ev = $w->XEvent;
  92.     $w->Button1($Ev->x,$Ev->y);
  93.    }
  94.  );
  95.  $mw->bind($class,'<B1-Motion>',
  96.   sub
  97.    {
  98.     my $w = shift;
  99.     my $Ev = $w->XEvent;
  100.     $w->B1Motion($Ev->x,$Ev->y);
  101.     
  102.    }
  103.  );
  104.  $mw->bind($class,'<ButtonRelease-1>',
  105.   sub
  106.    {
  107.     my $w = shift;
  108.     my $Ev = $w->XEvent;
  109.     $tkPriv{borderInfo} = "";
  110.     if ($w->exists)
  111.      {
  112.       $w->CancelRepeat;
  113.       $w->activate('@' . $Ev->x.",".$Ev->y);
  114.      }
  115.    }
  116.  );
  117.  $mw->bind($class,'<Shift-1>',
  118.   sub
  119.    {
  120.     my $w = shift;
  121.     my $Ev = $w->XEvent;
  122.     $w->BeginExtend( $w->index('@' . $Ev->x.",".$Ev->y));
  123.    }
  124.  );
  125.  
  126.  
  127.  $mw->bind($class,'<Control-1>',  
  128.   sub
  129.    {
  130.     my $w = shift;
  131.     my $Ev = $w->XEvent;
  132.     $w->BeginToggle($w->index('@' . $Ev->x.",".$Ev->y));
  133.    }
  134.  );
  135.  $mw->bind($class,'<B1-Enter>','CancelRepeat');
  136.  $mw->bind($class,'<B1-Leave>',
  137.   sub
  138.    {
  139.     my $w = shift;
  140.     my $Ev = $w->XEvent;
  141.     if( !$tkPriv{borderInfo} ){ 
  142.         $tkPriv{x} = $Ev->x; $tkPriv{y} = $Ev->y;
  143.         $w->AutoScan;
  144.     }
  145.    }
  146.  );
  147.  $mw->bind($class,'<2>',
  148.   sub
  149.    {
  150.     my $w = shift;
  151.     my $Ev = $w->XEvent;
  152.     $w->scan('mark',$Ev->x,$Ev->y);
  153.     $tkPriv{x} = $Ev->x; $tkPriv{y} = $Ev->y;
  154.     $tkPriv{'mouseMoved'} = 0;
  155.    }
  156.  );
  157.  $mw->bind($class,'<B2-Motion>',
  158.   sub
  159.    {
  160.     my $w = shift;
  161.     my $Ev = $w->XEvent;
  162.     $tkPriv{'mouseMoved'} = 1 if ($Ev->x ne $tkPriv{'x'} || $Ev->y ne $tkPriv{'y'});
  163.     $w->scan('dragto',$Ev->x,$Ev->y) if ($tkPriv{'mouseMoved'});
  164.    }
  165.  );
  166.  $mw->bind($class,'<ButtonRelease-2>',
  167.   sub
  168.    {
  169.     my $w = shift;
  170.     my $Ev = $w->XEvent;
  171.     $w->Paste($w->index('@' . $Ev->x.",".$Ev->y)) unless ($tkPriv{'mouseMoved'});
  172.    }
  173.  );
  174.  
  175.  
  176.  
  177.   ClipboardKeysyms( $mw, $class, qw/ <Copy> <Cut> <Paste> /);
  178.   ClipboardKeysyms( $mw, $class, 'Control-c', 'Control-x', 'Control-v');
  179.  
  180. ############################
  181.  
  182.  
  183.  $mw->bind($class,'<<Table_Commit>>',
  184.   sub
  185.    {
  186.     my $w = shift;
  187.     my $Ev = $w->XEvent;
  188.     eval
  189.      {
  190.       $w->activate('active');
  191.      }
  192.     ;
  193.    }
  194.  );
  195.  
  196. # Remove this if you don't want cell commit to occur on every Leave for
  197. # the table (via mouse) or FocusOut (loss of focus by table).
  198. $mw->eventAdd( qw[ <<Table_Commit>> <Leave> <FocusOut> ]);
  199.  
  200.  $mw->bind($class,'<Shift-Up>',['ExtendSelect',-1,0]);
  201.  $mw->bind($class,'<Shift-Down>',['ExtendSelect',1,0]);
  202.  $mw->bind($class,'<Shift-Left>',['ExtendSelect',0,-1]);
  203.  $mw->bind($class,'<Shift-Right>',['ExtendSelect',0,1]);
  204.  $mw->bind($class,'<Prior>',
  205.   sub
  206.    {
  207.     my $w = shift;
  208.     my $Ev = $w->XEvent;
  209.     $w->yview('scroll',-1,'pages');
  210.     $w->activate('@0,0');
  211.    }
  212.  );
  213.  $mw->bind($class,'<Next>',
  214.   sub
  215.    {
  216.     my $w = shift;
  217.     my $Ev = $w->XEvent;
  218.     $w->yview('scroll',1,'pages');
  219.     $w->activate('@0,0');
  220.    }
  221.  );
  222.  $mw->bind($class,'<Control-Prior>',['xview','scroll',-1,'pages']);
  223.  $mw->bind($class,'<Control-Next>',['xview','scroll',1,'pages']);
  224.  $mw->bind($class,'<Home>',['see','origin']);
  225.  $mw->bind($class,'<End>',['see','end']);
  226.  $mw->bind($class,'<Control-Home>',
  227.   sub
  228.    {
  229.     my $w = shift;
  230.     my $Ev = $w->XEvent;
  231.     $w->selection('clear','all');
  232.     $w->activate('origin');
  233.     $w->selection('set','active');
  234.     $w->see('active');
  235.    }
  236.  );
  237.  $mw->bind($class,'<Control-End>',
  238.   sub
  239.    {
  240.     my $w = shift;
  241.     my $Ev = $w->XEvent;
  242.     $w->selection('clear','all');
  243.     $w->activate('end');
  244.     $w->selection('set','active');
  245.     $w->see('active');
  246.    }
  247.  );
  248.  $mw->bind($class,'<Shift-Control-Home>',['DataExtend','origin']);
  249.  $mw->bind($class,'<Shift-Control-End>',['DataExtend','end']);
  250.  $mw->bind($class,'<Select>',['BeginSelect',Ev('index','active')]);
  251.  $mw->bind($class,'<Shift-Select>',['BeginExtend',Ev('index','active')]);
  252.  $mw->bind($class,'<Control-slash>','SelectAll');
  253.  $mw->bind($class,'<Control-backslash>',
  254.   sub
  255.    {
  256.     my $w = shift;
  257.     my $Ev = $w->XEvent;
  258.     $w->selection('clear','all') if ($w->cget(-selectmode) =~ /browse/);
  259.    }
  260.  );
  261.  $mw->bind($class,'<Up>',['MoveCell',-1,0]);
  262.  $mw->bind($class,'<Down>',['MoveCell',1,0]);
  263.  $mw->bind($class,'<Left>',['MoveCell',0,-1]);
  264.  $mw->bind($class,'<Right>',['MoveCell',0,1]);
  265.  $mw->bind($class,'<KeyPress>',['TableInsert',Ev('A')]);
  266.  
  267.  $mw->bind($class,'<BackSpace>',['BackSpace']);
  268.  
  269.  $mw->bind($class,'<Delete>',['delete','active','insert']);
  270.  $mw->bind($class,'<Escape>','reread');
  271.  $mw->bind($class,'<Return>',['TableInsert',"\n"]);
  272.  $mw->bind($class,'<Control-Left>',
  273.    sub
  274.    {
  275.     my $w = shift;
  276.     my $Ev = $w->XEvent;
  277.     my $posn = $w->icursor;
  278.     $w->icursor($posn - 1);
  279.    }
  280.  );
  281.  
  282.  $mw->bind($class,'<Control-Right>',
  283.     sub
  284.    {
  285.     my $w = shift;
  286.     my $Ev = $w->XEvent;
  287.     my $posn = $w->icursor;
  288.     $w->icursor($posn + 1);
  289.    }
  290.  );
  291.  
  292.  $mw->bind($class,'<Control-e>',['icursor','end']);
  293.  $mw->bind($class,'<Control-a>',['icursor',0]);
  294.  $mw->bind($class,'<Control-k>',['delete','active','insert','end']);
  295.  $mw->bind($class,'<Control-equal>',['ChangeWidth','active',1]);
  296.  $mw->bind($class,'<Control-minus>',['ChangeWidth','active',-1]);
  297.  
  298. # Ignore all Alt, Meta, and Control keypresses unless explicitly bound.
  299. # Otherwise, if a widget binding for one of these is defined, the
  300. # <KeyPress> class binding will also fire and insert the character,
  301. # which is wrong.  Ditto for Tab.
  302.  
  303.  
  304.  $mw->bind($class,'<Alt-KeyPress>',
  305.   sub
  306.    {
  307.     my $w = shift;
  308.     my $Ev = $w->XEvent;
  309.     # nothing
  310.    }
  311.  );
  312.  $mw->bind($class,'<Meta-KeyPress>',
  313.   sub
  314.    {
  315.     my $w = shift;
  316.     my $Ev = $w->XEvent;
  317.     # nothing
  318.  
  319.    }
  320.  );
  321.  $mw->bind($class,'<Control-KeyPress>',
  322.   sub
  323.    {
  324.     my $w = shift;
  325.     my $Ev = $w->XEvent;
  326.     #
  327.    }
  328.  );
  329.  $mw->bind($class,'<Any-Tab>',
  330.   sub
  331.    {
  332.     my $w = shift;
  333.     my $Ev = $w->XEvent;
  334.     #
  335.    }
  336.  );
  337.  
  338.  
  339.  
  340. }
  341.  
  342.  
  343.  
  344. # ::tk::table::GetSelection --
  345. #   This tries to obtain the default selection.  On Unix, we first try
  346. #   and get a UTF8_STRING, a type supported by modern Unix apps for
  347. #   passing Unicode data safely.  We fall back on the default STRING
  348. #   type otherwise.  On Windows, only the STRING type is necessary.
  349. # Arguments:
  350. #   w    The widget for which the selection will be retrieved.
  351. #    Important for the -displayof property.
  352. #   sel    The source of the selection (PRIMARY or CLIPBOARD)
  353. # Results:
  354. #   Returns the selection, or an error if none could be found
  355. #
  356. sub GetSelection{
  357.  
  358.     my $w = shift;
  359.     my $sel = shift;
  360.     $sel ||= 'PRIMARY';
  361.     
  362.     my $txt;
  363.     if( $Tk::platform eq 'unix'){
  364.         eval{ $txt = $w->SelectionGet( -selection =>  $sel) };
  365.  
  366.         if( $@){
  367.             warn("Could not find default selection\n");
  368.             return undef;
  369.         }
  370.             
  371.         return $txt;
  372.  
  373.     }
  374.     else{
  375.     
  376.         eval{ $txt = $w->SelectionGet( -selection => $sel) };
  377.  
  378.         if( $@){
  379.             warn("Could not find default selection\n");
  380.             return undef;
  381.         }
  382.  
  383.         return $txt;
  384.         
  385.     }
  386. }
  387.         
  388.  
  389.  
  390. # ClipboardKeysyms --
  391. # This procedure is invoked to identify the keys that correspond to
  392. # the "copy", "cut", and "paste" functions for the clipboard.
  393. #
  394. # Arguments:
  395. # copy -    Name of the key (keysym name plus modifiers, if any,
  396. #        such as "Meta-y") used for the copy operation.
  397. # cut -        Name of the key used for the cut operation.
  398. # paste -    Name of the key used for the paste operation.
  399.  
  400. sub ClipboardKeysyms
  401. {
  402.  my $mw = shift;
  403.  my $class = shift;
  404.  my $copy = shift;
  405.  my $cut = shift;
  406.  my $paste = shift;
  407.  $mw->bind($class,"<$copy>",'Copy');
  408.  $mw->bind($class,"<$cut>",'Cut');
  409.  $mw->bind($class,"<$paste>",'Paste');
  410.  
  411. }
  412. # TableInsert --
  413. #
  414. #   Insert into the active cell
  415. #
  416. # Arguments:
  417. #   w    - the table widget
  418. #   s    - the string to insert
  419. # Results:
  420. #   Returns nothing
  421. #
  422.  
  423. sub TableInsert
  424. {
  425.  my $w = shift;
  426.  my $s = shift;
  427.  $w->insert('active','insert',$s) if ($s ne '' ) ;
  428. }
  429. # ::tk::table::BackSpace --
  430. #
  431. #   BackSpace in the current cell
  432. #
  433. # Arguments:
  434. #   w    - the table widget
  435. # Results:
  436. #   Returns nothing
  437. #
  438. sub BackSpace{
  439.     
  440.     my $w = shift;
  441.     my $Ev = $w->XEvent;
  442.     my $posn = $w->icursor;
  443.     $w->delete('active',$posn - 1) if( $posn > -1);
  444. }
  445.  
  446. # Button1 --
  447. #
  448. # This procedure is called to handle selecting with mouse button 1.
  449. # It will distinguish whether to start selection or mark a border.
  450. #
  451. # Arguments:
  452. #   w    - the table widget
  453. #   x    - x coord
  454. #   y    - y coord
  455. # Results:
  456. #   Returns nothing
  457. #
  458. sub Button1 {
  459.  
  460.     my $w = shift;
  461.     my ( $x, $y ) = @_;
  462.  
  463.     # borderInfo is null if the user did not click on a border
  464.     if ( $tkPriv{borderB1} == 1 ) {
  465.         $tkPriv{borderInfo} = $w->borderMark( $x, $y );
  466.     }
  467.     else {
  468.         $tkPriv{borderInfo} = "";
  469.     }
  470.  
  471.     if ( ! $tkPriv{borderInfo} ) {
  472.  
  473.         #
  474.         # Only do this when a border wasn't selected
  475.         #
  476.         if ( $w->exists ) {
  477.             $w->BeginSelect( $w->index( '@' . "$x,$y" ) );
  478.             $w->focus;
  479.         }
  480.         $tkPriv{x}          = $x;
  481.         $tkPriv{y}          = $y;
  482.         $tkPriv{mouseMoved} = 0;
  483.     }
  484. }
  485.  
  486. # B1Motion --
  487. #
  488. # This procedure is called to start processing mouse motion events while
  489. # button 1 moves while pressed.  It will distinguish whether to change
  490. # the selection or move a border.
  491. #
  492. # Arguments:
  493. #   w    - the table widget
  494. #   x    - x coord
  495. #   y    - y coord
  496. # Results:
  497. #   Returns nothing
  498. #
  499. sub B1Motion {
  500.  
  501.     my $w = shift;
  502.  
  503.     my ( $x, $y ) = @_;
  504.  
  505.     # If we already had motion, or we moved more than 1 pixel,
  506.     # then we start the Motion routine
  507.  
  508.     if ( $tkPriv{borderInfo}  ) {
  509.  
  510.         #
  511.         # If the motion is on a border, drag it and skip the rest
  512.         # of this binding.
  513.         #
  514.         $w->borderDragto( $x, $y );
  515.  
  516.     }
  517.     else {
  518.  
  519.         #
  520.         # If we already had motion, or we moved more than 1 pixel,
  521.         # then we start the Motion routine
  522.         #
  523.         if ( $tkPriv{mouseMoved}
  524.               || abs( $x - $tkPriv{x} ) > 1
  525.               || abs( $y - $tkPriv{y} ) > 1 ) {
  526.  
  527.             $tkPriv{mouseMoved} = 1;
  528.         }
  529.         if ( $tkPriv{mouseMoved} ) {
  530.             $w->Motion( $w->index( '@' . "$x,$y" ) );
  531.         }
  532.     }
  533. }
  534. # BeginSelect --
  535. #
  536. # This procedure is typically invoked on button-1 presses. It begins
  537. # the process of making a selection in the table. Its exact behavior
  538. # depends on the selection mode currently in effect for the table;
  539. # see the Motif documentation for details.
  540. #
  541. # Arguments:
  542. # w    - The table widget.
  543. # el    - The element for the selection operation (typically the
  544. #    one under the pointer).  Must be in row,col form.
  545.  
  546. sub BeginSelect
  547. {
  548.  my $w = shift;
  549.  my $el = shift;
  550.  my $r;
  551.  my $c;
  552.  my $inc;
  553.  my $el2;
  554.  return unless( scalar( ($r,$c) = split(",",$el)) ==2); # Get Rol Col or return
  555.  my $selectmode = $w->cget('-selectmode');
  556.  if ($selectmode eq 'multiple')
  557.   {
  558.    if ($w->tag('includes','title',$el))
  559.     {
  560.      ## in the title area
  561.      if ($r < ($w->cget('-titlerows') + $w->cget('-roworigin')) )
  562.       {
  563.        ## We're in a column header
  564.        if ($c < ( $w->cget('-titlecols') + $w->cget('-colorigin')))
  565.         {
  566.          ## We're in the topleft title area
  567.          $inc = 'topleft';
  568.          $el2 = 'end';
  569.         }
  570.        else
  571.         {
  572.          $inc = $w->index('topleft','row').",$c";
  573.          $el2 = $w->index('end','row').",$c";
  574.         }
  575.       }
  576.      else
  577.       {
  578.        ## We're in a row header
  579.        $inc = "$r,".$w->index('topleft','col');
  580.        $el2 = "$r,".$w->index('end','col');
  581.       }
  582.     }
  583.    else
  584.     {
  585.      $inc = $el;
  586.      $el2 = $el;
  587.     }
  588.    if ($w->selection('includes',$inc))
  589.     {
  590.      $w->selection('clear',$el,$el2);
  591.     }
  592.    else
  593.     {
  594.      $w->selection('set',$el,$el2);
  595.     }
  596.   }
  597.  elsif ($selectmode eq 'extended')
  598.   {
  599.    $w->selection('clear','all');
  600.    if ($w->tag('includes','title',$el))
  601.     {
  602.      if ($r < ($w->cget('-titlerows') + $w->cget('-roworigin')))
  603.       {
  604.        ## We're in a column header
  605.        if ($c < ( $w->cget('-titlecols') + $w->cget('-colorigin')) )
  606.         {
  607.          $w->selection('set',$el,'end');
  608.         }
  609.        else
  610.         {
  611.          $w->selection('set',$el,$w->index('end','row').",$c");
  612.         }
  613.       }
  614.      else
  615.       {
  616.        ## We're in a row header
  617.        $w->selection('set',$el,"$r,".$w->index('end','col'));
  618.       }
  619.     }
  620.    else
  621.     {
  622.      $w->selection('set',$el);
  623.     }
  624.    $w->selection('anchor',$el);
  625.    $tkPriv{'tablePrev'} = $el;
  626.   }
  627.  elsif ($selectmode eq 'default')
  628.   {
  629.    unless ($w->tag('includes','title',$el))
  630.     {
  631.      $w->selection('clear','all');
  632.      $w->selection('set',$el);
  633.      $tkPriv{'tablePrev'} = $el;
  634.     }
  635.    $w->selection('anchor',$el);
  636.   }
  637. }
  638. # Motion --
  639. #
  640. # This procedure is called to process mouse motion events while
  641. # button 1 is down. It may move or extend the selection, depending
  642. # on the table's selection mode.
  643. #
  644. # Arguments:
  645. # w    - The table widget.
  646. # el    - The element under the pointer (must be in row,col form).
  647.  
  648. sub Motion
  649. {
  650.  my $w = shift;
  651.  my $el = shift;
  652.  my $r;
  653.  my $c;
  654.  my $elc;
  655.  my $elr;
  656.  unless (exists($tkPriv{'tablePrev'}))
  657.   {
  658.    $tkPriv{'tablePrev'} = $el;
  659.    return;
  660.   }
  661.  return if ($tkPriv{'tablePrev'} eq $el );
  662.  my $selectmode = $w->cget('-selectmode');
  663.  if ($selectmode eq 'browse')
  664.   {
  665.    $w->selection('clear','all');
  666.    $w->selection('set',$el);
  667.    $tkPriv{'tablePrev'} = $el;
  668.   }
  669.  elsif ($selectmode eq 'extended')
  670.   {
  671.    # avoid tables that have no anchor index yet.
  672.    my $indexAnchor;
  673.    eval{ $indexAnchor = $w->index('anchor') };
  674.    return if( $@ || !$indexAnchor);
  675.  
  676.    ($r,$c) = split(",",$tkPriv{tablePrev});
  677.    ($elr,$elc) = split(",",$el);
  678.  
  679.    if ($w->tag('includes','title',$el))
  680.     {
  681.      if ($r < ($w->cget('-titlerows') + $w->cget('-roworigin')) )
  682.       {
  683.        ## We're in a column header
  684.        if ($c < ( $w->cget('-titlecols') + $w->cget('-colorigin')) )
  685.         {
  686.          ## We're in the topleft title area
  687.          $w->selection('clear','anchor','end');
  688.         }
  689.        else
  690.         {
  691.          $w->selection('clear','anchor',$w->index('end','row').",$c");
  692.         }
  693.        ##### perltk: Removed comma
  694.        $w->selection('set','anchor',$w->index('end','row').",$elc");
  695.       }
  696.      else
  697.       {
  698.        ## We're in a row header
  699.        $w->selection('clear','anchor',"$r,".$w->index('end','col'));
  700.        $w->selection('set','anchor',"$elr,".$w->index('end','col'));
  701.       }
  702.     }
  703.    else
  704.     {
  705.      $w->selection('clear','anchor',$tkPriv{'tablePrev'});
  706.      $w->selection('set','anchor',$el);
  707.     }
  708.    $tkPriv{'tablePrev'} = $el;
  709.   }
  710. }
  711. # BeginExtend --
  712. #
  713. # This procedure is typically invoked on shift-button-1 presses. It
  714. # begins the process of extending a selection in the table. Its
  715. # exact behavior depends on the selection mode currently in effect
  716. # for the table; see the Motif documentation for details.
  717. #
  718. # Arguments:
  719. # w - The table widget.
  720. # el - The element for the selection operation (typically the
  721. # one under the pointer). Must be in numerical form.
  722.  
  723. sub BeginExtend
  724. {
  725.  my $w = shift;
  726.  my $el = shift;
  727.  $w->Motion($el) if ($w->cget(-selectmode) eq 'extended' && $w->selectionIncludes('anchor'));
  728. }
  729. # BeginToggle --
  730. #
  731. # This procedure is typically invoked on control-button-1 presses. It
  732. # begins the process of toggling a selection in the table. Its
  733. # exact behavior depends on the selection mode currently in effect
  734. # for the table; see the Motif documentation for details.
  735. #
  736. # Arguments:
  737. # w - The table widget.
  738. # el - The element for the selection operation (typically the
  739. # one under the pointer). Must be in numerical form.
  740.  
  741. sub BeginToggle
  742. {
  743.  my $w = shift;
  744.  my $el = shift;
  745.  my $r;
  746.  my $c;
  747.  my $end;
  748.  if ( $w->cget( -selectmode ) =~ /extended/i )
  749.   {
  750.    $tkPriv{'tablePrev'} = $el;
  751.    $w->selection('anchor',$el);
  752.    if ($w->tag('includes','title',$el))
  753.     {
  754.      # scan $el %d,%d r c
  755.      ($r,$c) = split( ",",$el);
  756.      if ($r < ($w->cget('-titlerows') + $w->cget('-roworigin')) )
  757.       {
  758.        ## We're in a column header
  759.        if ($c < ($w->cget('-titlecols') + $w->cget('-colorigin')))
  760.         {
  761.          ## We're in the topleft title area
  762.          $end = 'end';
  763.         }
  764.        else
  765.         {
  766.          $end = $w->index('end','row');
  767.         }
  768.       }
  769.      else
  770.       {
  771.        ## We're in a row header
  772.        $end = "$r,".$w->index('end','row');
  773.       }
  774.     }
  775.    else
  776.     {
  777.      ## We're in a non-title cell
  778.      $end = $el;
  779.     }
  780.    if ($w->selection('includes',$end))
  781.     {
  782.      $w->selection('clear',$el,$end);
  783.     }
  784.    else
  785.     {
  786.      $w->selection('set',$el,$end);
  787.     }
  788.   }
  789. }
  790. # AutoScan --
  791. # This procedure is invoked when the mouse leaves an table window
  792. # with button 1 down. It scrolls the window up, down, left, or
  793. # right, depending on where the mouse left the window, and reschedules
  794. # itself as an "after" command so that the window continues to scroll until
  795. # the mouse moves back into the window or the mouse button is released.
  796. #
  797. # Arguments:
  798. # w - The table window.
  799.  
  800. sub AutoScan
  801. {
  802.  my $w = shift;
  803.  my $x;
  804.  my $y;
  805.  
  806.  return unless ($w->exists);
  807.  $x = $tkPriv{'x'};
  808.  $y = $tkPriv{'y'};
  809.  
  810.  if ($y >= $w->SUPER::height) # we don't want our height here, we want the 
  811.                  # actual height of the window
  812.   {
  813.    $w->yview('scroll',1,'units');
  814.   }
  815.  elsif ($y < 0)
  816.   {
  817.    $w->yview('scroll',-1,'units');
  818.   }
  819.  elsif ($x >= $w->SUPER::width)
  820.   {
  821.    $w->xview('scroll',1,'units');
  822.   }
  823.  elsif ($x < 0)
  824.   {
  825.    $w->xview('scroll',-1,'units');
  826.   }
  827.  else
  828.   {
  829.    return;
  830.   }
  831.  $w->Motion($w->index('@' . $x.','.$y));
  832.  $tkPriv{'afterId'} = $w->after(50,[$w,'AutoScan']);
  833. }
  834. # MoveCell --
  835. #
  836. # Moves the location cursor (active element) by the specified number
  837. # of cells and changes the selection if we're in browse or extended
  838. # selection mode.  If the new cell is "hidden", we skip to the next
  839. # visible cell if possible, otherwise just abort.
  840. #
  841. # Arguments:
  842. # w - The table widget.
  843. # x - +1 to move down one cell, -1 to move up one cell.
  844. # y - +1 to move right one cell, -1 to move left one cell.
  845.  
  846. sub MoveCell
  847. {
  848.  
  849.  
  850.  my $w = shift;
  851.  my $x = shift;
  852.  my $y = shift;
  853.  my $c;
  854.  my $cell;
  855.  my $r;
  856.  my $true;
  857.  eval { $r = $w->index('active','row') }; return if( $@);
  858.  
  859.  $c = $w->index('active','col');
  860.  # set cell [$w index [incr r $x],[incr c $y]]
  861.  $cell = $w->index(($r += $x).",".($c += $y));
  862.  while ( ($true = $w->index('active')) eq '')
  863.   {
  864.    # The cell is in some way hidden
  865.    if ($true eq $w->index('active'))
  866.     {
  867.      # The span cell wasn't the previous cell, so go to that
  868.      $cell = $true;
  869.      last;
  870.     }
  871.    if ($x > 0)
  872.     {
  873.      ++ $r;
  874.     }
  875.    elsif ($x < 0)
  876.     {
  877.      $r += -1;
  878.     }
  879.    if ($y > 0)
  880.     {
  881.      ++ $c;
  882.     }
  883.    elsif ($y < 0)
  884.     {
  885.      $c += -1;
  886.     }
  887.    if ($cell eq $w->index($r.",".$c))
  888.     {
  889.      $cell = $w->index("$r,$c");
  890.     }
  891.    else
  892.     {
  893.      # We couldn't find a non-hidden cell, just don't move
  894.      return;
  895.     }
  896.   }
  897.  $w->activate($cell);
  898.  $w->see('active');
  899.  if ($w->cget('-selectmode') eq 'browse')
  900.   {
  901.    $w->selection('clear','all');
  902.    $w->selection('set','active');
  903.   }
  904.  elsif ($w->cget('-selectmode') eq 'extended')
  905.   {
  906.    $w->selection('clear','all');
  907.    $w->selection('set','active');
  908.    $w->selection('anchor','active');
  909.    $tkPriv{'tablePrev'} = $w->index('active');
  910.   }
  911. }
  912. # ExtendSelect --
  913. #
  914. # Does nothing unless we're in extended selection mode; in this
  915. # case it moves the location cursor (active element) by the specified
  916. # number of cells, and extends the selection to that point.
  917. #
  918. # Arguments:
  919. # w - The table widget.
  920. # x - +1 to move down one cell, -1 to move up one cell.
  921. # y - +1 to move right one cell, -1 to move left one cell.
  922.  
  923. sub ExtendSelect
  924. {
  925.  my $w = shift;
  926.  my $x = shift;
  927.  my $y = shift;
  928.  my $c;
  929.  my $r;
  930.  #### Perltk notes: (should be 'ne' instead of 'eq' ???
  931.  return unless (  $w->cget(-selectmode) eq 'extended');
  932.  eval { $r = $w->index('active','row'); }; return if($@);
  933.  $c = $w->index('active','col');
  934.  $w->activate( ($r += $x).",".($c += $y));
  935.  $w->see('active');
  936.  $w->Motion($w->index('active'));
  937. }
  938. # DataExtend
  939. #
  940. # This procedure is called for key-presses such as Shift-KEndData.
  941. # If the selection mode isnt multiple or extend then it does nothing.
  942. # Otherwise it moves the active element to el and, if we're in
  943. # extended mode, extends the selection to that point.
  944. #
  945. # Arguments:
  946. # w - The table widget.
  947. # el - An integer cell number.
  948.  
  949. sub DataExtend
  950. {
  951.  my $w = shift;
  952.  my $el = shift;
  953.  my $mode;
  954.  $mode = $w->cget('-selectmode');
  955.  if ($mode =~ /extended/i )
  956.   {
  957.    $w->activate($el);
  958.    $w->see($el);
  959.    $w->Motion($el) if ($w->selection('includes','anchor'));
  960.   }
  961.  elsif ($mode =~ /multiple/i)
  962.   {
  963.    $w->activate($el);
  964.    $w->see($el);
  965.   }
  966. }
  967. # SelectAll
  968. #
  969. # This procedure is invoked to handle the "select all" operation.
  970. # For single and browse mode, it just selects the active element.
  971. # Otherwise it selects everything in the widget.
  972. #
  973. # Arguments:
  974. # w - The table widget.
  975.  
  976. sub SelectAll
  977. {
  978.  my $w = shift;
  979.  if ( $w->cget(-selectmode) =~ /^(single|browse)$/)
  980.   {
  981.    $w->selection('clear','all');
  982.    $w->selection('set','active');
  983.    $w->TableMatrixHandleType($w->index('active'));
  984.   }
  985.  else
  986.   {
  987.    $w->selection('set','origin','end');
  988.   }
  989. }
  990. # ChangeWidth --
  991. # Adjust the widget of the specified cell by $a.
  992. #
  993. # Arguments:
  994. # w - The table widget.
  995. # i - cell index
  996. # a - amount to adjust by
  997.  
  998. sub ChangeWidth
  999. {
  1000.  my $w = shift;
  1001.  my $i = shift;
  1002.  my $a = shift;
  1003.  my $tmp;
  1004.  my $width;
  1005.  $tmp = $w->index($i,'col');
  1006.  if (($width = $w->colWidth($tmp)) >= 0)
  1007.   {
  1008.    $w->colWidth($tmp,$width += $a);
  1009.   }
  1010.  else
  1011.   {
  1012.    $w->colWidth($tmp,$width += -$a);
  1013.   }
  1014. }
  1015. # Copy --
  1016. # This procedure copies the selection from a table widget into the
  1017. # clipboard.
  1018. #
  1019. # Arguments:
  1020. # w -        Name of a table widget.
  1021.  
  1022. sub Copy
  1023. {
  1024.  my $w = shift;
  1025.  if ($w->SelectionOwner() eq $w)
  1026.   {
  1027.    $w->clipboardClear;
  1028.    eval
  1029.     {
  1030.      $w->clipboardAppend($w->GetSelection);
  1031.     }
  1032.    ;
  1033.   }
  1034. }
  1035. # Cut --
  1036. # This procedure copies the selection from a table widget into the
  1037. # clipboard, then deletes the selection (if it exists in the given
  1038. # widget).
  1039. #
  1040. # Arguments:
  1041. # w -        Name of a table widget.
  1042.  
  1043. sub Cut
  1044. {
  1045.  my $w = shift;
  1046.  if ($w->SelectionOwner() eq $w)
  1047.   {
  1048.    $w->clipboardClear;
  1049.    eval
  1050.     {
  1051.      $w->clipboardAppend($w->GetSelection);
  1052.      $w->curselection('');# Clear whatever is selected
  1053.      $w->selectionClear();
  1054.     }
  1055.    ;
  1056.   }
  1057. }
  1058. # Paste --
  1059. # This procedure pastes the contents of the clipboard to the specified
  1060. # cell (active by default) in a table widget.
  1061. #
  1062. # Arguments:
  1063. # w -        Name of a table widget.
  1064. # cell -    Cell to start pasting in.
  1065.  
  1066. sub Paste
  1067. {
  1068.  my $w = shift;
  1069.  my $cell = shift || ''; ## Perltk not sure if translated correctly
  1070.  my $data;
  1071.  if ($cell ne '')
  1072.   {
  1073.    eval{ $data = $w->GetSelection(); }; return if($@);
  1074.   }
  1075.  else
  1076.   {
  1077.    eval{ $data = $w->GetSelection('CLIPBOARD'); }; return if($@);
  1078.    $cell = 'active';
  1079.   }
  1080.  $w->PasteHandler($w->index($cell),$data);
  1081.  $w->focus if ($w->cget('-state') eq 'normal');
  1082. }
  1083. # PasteHandler --
  1084. # This procedure handles how data is pasted into the table widget.
  1085. # This handles data in the default table selection form.
  1086. # NOTE: this allows pasting into all cells, even those with -state disabled
  1087. #
  1088. # Arguments:
  1089. # w -        Name of a table widget.
  1090. # cell -    Cell to start pasting in.
  1091.  
  1092. sub PasteHandler
  1093. {
  1094.  
  1095.  my $w = shift;
  1096.  my $cell = shift;
  1097.  my $data = shift;
  1098.  #
  1099.  # Don't allow pasting into the title cells
  1100.  #
  1101.  return if( $w->tagIncludes('title', $cell));
  1102.  my $rows;
  1103.  my $cols;
  1104.  my $r;
  1105.  my $c;
  1106.  my $rsep;
  1107.  my $csep;
  1108.  my $row;
  1109.  my $line;
  1110.  my $col;
  1111.  my $item;
  1112.  $rows = $w->cget('-rows') - $w->cget('-roworigin');
  1113.  $cols = $w->cget('-cols') - $w->cget('-colorigin');
  1114.  $r = $w->index($cell,'row');
  1115.  $c = $w->index($cell,'col');
  1116.  $rsep = $w->cget('-rowseparator');
  1117.  $csep = $w->cget('-colseparator');
  1118.  ## Assume separate rows are split by row separator if specified
  1119.  ## If you were to want multi-character row separators, you would need:
  1120.  # regsub -all $rsep $data <newline> data
  1121.  # set data [join $data <newline>]
  1122.  my @data;
  1123.  @data = split($rsep,$data) if ($rsep ne ''); 
  1124.  $row = $r;
  1125.  foreach $line (@data)
  1126.   {
  1127.    last if ($row > $rows);
  1128.    $col = $c;
  1129.    ## Assume separate cols are split by col separator if specified
  1130.    ## Unless a -separator was specified
  1131.    my @line = split($csep, $line) if ($csep ne ''); 
  1132.    ## If you were to want multi-character col separators, you would need:
  1133.    # regsub -all $csep $line <newline> line
  1134.    # set line [join $line <newline>]
  1135.    foreach $item (@line)
  1136.     {
  1137.      last if ($col > $cols);
  1138.      $w->set("$row,$col",$item);
  1139.      ++ $col;
  1140.     }
  1141.    ++ $row;
  1142.   }
  1143. }
  1144.  
  1145.  
  1146. #############################################################
  1147. ##  CancelRepeat
  1148. # This procedure is invoked to cancel an auto-repeat action described
  1149. # by $Tk::TableMatrix::tkPriv{afterId}.  It's used by several widgets to auto-scroll
  1150. # the widget when the mouse is dragged out of the widget with a
  1151. # button pressed.
  1152.  
  1153.  
  1154. sub CancelRepeat{
  1155.     my $w = shift;
  1156.      
  1157.     my $id = delete $tkPriv{'afterId'}; 
  1158.     $w->afterCancel($id) if($id);
  1159.          
  1160. }
  1161.  
  1162.  
  1163.  
  1164. 1;
  1165.  
  1166. __END__
  1167.