home *** CD-ROM | disk | FTP | other *** search
/ CD Actual Thematic 7: Programming / CDAT7.iso / Share / Editores / Perl5 / perl / lib / site / Tk / HList.pm < prev    next >
Encoding:
Perl POD Document  |  1997-08-10  |  10.5 KB  |  580 lines
  1. package Tk::HList; 
  2. use Tk qw(Ev);
  3.  
  4. @ISA = qw(Tk::Widget);
  5.  
  6. Construct Tk::Widget 'HList';
  7. sub Tk::Widget::ScrlHList { shift->Scrolled('HList'=>@_) }
  8.  
  9. bootstrap Tk::HList $Tk::VERSION; 
  10.  
  11. sub Tk_cmd { \&Tk::hlist }
  12.  
  13. sub CreateArgs
  14. {
  15.  my ($package,$parent,$args) = @_;
  16.  my @result = $package->SUPER::CreateArgs($parent,$args);
  17.  my $columns = delete $args->{-columns};                     
  18.  push(@result, '-columns' => $columns) if (defined $columns);
  19.  return @result;
  20. }
  21.  
  22. EnterMethods Tk::HList __FILE__,qw(add addchild anchor column
  23.                                    delete dragsite dropsite entrycget
  24.                                    entryconfigure geometryinfo indicator hide item info
  25.                                    nearest see select selection show xview yview);
  26.  
  27. use Tk::Submethods ( 'delete' => [qw(all entry offsprings siblings)],
  28.                      'header' => [qw(configure cget create delete exists size)],
  29.                      'indicator' => [qw(configure cget create delete exists size)],
  30.                      'info' => [qw(anchor bbox children data dragsite
  31.                                    dropsite exists hidden item next parent prev)],
  32.                      'item' => [qw(configure cget create delete exists)],
  33.                      'selection' => [qw(clear get includes set)],
  34.                      'anchor' => [qw(clear set)],
  35.                    );
  36.  
  37.  
  38. sub ClassInit
  39. {
  40.  my ($class,$mw) = @_;
  41.  
  42.  $mw->bind($class,'<ButtonPress-1>',[ 'Button1' ] );
  43.  $mw->bind($class,'<Shift-ButtonPress-1>',[ 'ShiftButton1' ] );
  44.  $mw->bind($class,'<Control-ButtonRelease-1>', sub {} );
  45.  $mw->bind($class,'<ButtonRelease-1>',
  46.         sub
  47.          {
  48.           my $w = shift;
  49.           my $Ev = $w->XEvent;
  50.           $w->CancelRepeat
  51.               if($w->cget('-selectmode') ne "dragdrop");
  52.           $w->ButtonRelease1($Ev);
  53.          });
  54.  $mw->bind($class,'<B1-Motion>',[ 'Button1Motion' ] );
  55.  $mw->bind($class,'<B1-Leave>',[ 'AutoScan' ] );
  56.  
  57.  $mw->bind($class,'<Double-ButtonPress-1>',['Double1']);
  58.  
  59.  $mw->bind($class,'<Control-B1-Motion>', sub {} );
  60.  $mw->bind($class,'<Control-ButtonPress-1>',['CtrlButton1']);
  61.  $mw->bind($class,'<Control-Double-ButtonPress-1>',['CtrlButton1']);
  62.  
  63.  $mw->bind($class,'<B1-Enter>',
  64.         sub
  65.          {
  66.           my $w = shift;
  67.           my $Ev = $w->XEvent;
  68.           $w->CancelRepeat
  69.               if($w->cget('-selectmode') ne "dragdrop");
  70.          });
  71.  
  72.  $mw->bind($class,'<Up>',['UpDown', 'prev']);
  73.  $mw->bind($class,'<Down>',['UpDown', 'next']);
  74.  
  75.  $mw->bind($class,'<Shift-Up>',['ShiftUpDown', 'prev']);
  76.  $mw->bind($class,'<Shift-Down>',['ShiftUpDown', 'next']);
  77.  
  78.  $mw->bind($class,'<Left>', ['LeftRight', 'left']);
  79.  $mw->bind($class,'<Right>',['LeftRight', 'right']);
  80.  
  81.  $mw->bind($class,'<Prior>', sub {shift->yview('scroll', -1, 'pages') } );
  82.  $mw->bind($class,'<Next>',  sub {shift->yview('scroll',  1, 'pages') } );
  83.  
  84.  $mw->bind($class,'<Return>', ['KeyboardActivate']);
  85.  $mw->bind($class,'<space>',  ['KeyboardBrowse']);
  86.  $mw->bind($class,'<Home>',   ['KeyboardHome']);
  87.  
  88.  return $class;
  89. }
  90.  
  91. sub Button1
  92. {
  93.  my $w = shift;
  94.  my $Ev = $w->XEvent;
  95.  
  96.  delete $w->{'shiftanchor'}; 
  97.  
  98.  $w->focus()
  99.     if($w->cget("-takefocus"));
  100.  
  101.  my $mode = $w->cget("-selectmode");
  102.  
  103.  if ($mode eq "dragdrop")
  104.   {
  105.    # $w->Send_WaitDrag($Ev->y);
  106.    return;
  107.   }
  108.  
  109.  my $ent = $w->GetNearest($Ev->y);
  110.  
  111.  return unless( $ent );
  112.  
  113.  my @info = $w->info('item',$Ev->x, $Ev->y);
  114.  
  115.  if (defined($info[1]) && $info[1] eq 'indicator')
  116.   {
  117.    $w->Callback(-indicatorcmd => $ent);
  118.   }
  119.  else
  120.   {
  121.    my $browse = 0;
  122.      
  123.    if($mode eq "single")
  124.     {
  125.      $w->anchor('set', $ent);
  126.     }
  127.    elsif($mode eq "browse")
  128.     {
  129.      $w->anchor('set', $ent);
  130.      $w->select('clear' );
  131.      $w->select('set', $ent);
  132.      $browse = 1;
  133.     }
  134.    elsif($mode eq "multiple")
  135.     {
  136.      $w->select('clear');
  137.      $w->anchor('set', $ent);
  138.      $w->select('set', $ent);
  139.      $browse = 1;
  140.     }
  141.    elsif($mode eq "extended")
  142.     {
  143.      $w->anchor('set', $ent);
  144.      $w->select('clear');
  145.      $w->select('set', $ent);
  146.      $browse = 1;
  147.     }
  148.      
  149.    if ($browse)
  150.     {
  151.      $w->Callback(-browsecmd => $ent);
  152.     }
  153.   }
  154. }
  155.  
  156. sub ShiftButton1
  157. {
  158.  my $w = shift;
  159.  my $Ev = $w->XEvent;
  160.  
  161.  my $to = $w->GetNearest($Ev->y);
  162.  
  163.  delete $w->{'shiftanchor'}; 
  164.  
  165.  return unless($to);
  166.  
  167.  my $mode = $w->cget('-selectmode');
  168.  
  169.  if($mode eq "extended")
  170.   {
  171.    my $from = $w->info('anchor');
  172.    if($from)
  173.     {
  174.      $w->select('clear');
  175.      $w->select('set', $from, $to);
  176.     }
  177.    else
  178.     {
  179.      $w->anchor('set', $to);
  180.      $w->select('clear');
  181.      $w->select('set', $to);
  182.     }
  183.   }
  184. }
  185.  
  186. sub GetNearest
  187. {
  188.  my ($w,$y) = @_;
  189.  my $ent = $w->nearest($y);
  190.  if (defined $ent)
  191.   {
  192.    my $state = $w->entrycget($ent, '-state');
  193.    return $ent if (!defined($state) || $state ne 'disabled');
  194.   }
  195.  return undef;
  196. }
  197.  
  198. sub ButtonRelease1
  199. {
  200.  my ($w, $Ev) = @_;
  201.  
  202.  delete $w->{'shiftanchor'}; 
  203.  
  204.  my $mode = $w->cget('-selectmode');
  205.  
  206.  if($mode eq "dragdrop")
  207.   {
  208. #   $w->Send_DoneDrag();
  209.    return;
  210.   }
  211.  
  212.  my ($x, $y) = ($Ev->x, $Ev->y);
  213.  my $ent = $w->GetNearest($y);
  214.  
  215.  return unless($ent);
  216.  
  217.  if($x < 0 || $y < 0 || $x > $w->width || $y > $w->height)
  218.   {
  219.    $w->select('clear');
  220.  
  221.    return if($mode eq "single" || $mode eq "browse")
  222.  
  223.   }
  224.  else
  225.   {
  226.    if($mode eq "single" || $mode eq "browse")
  227.     {
  228.      $w->anchor('set', $ent);
  229.      $w->select('clear');
  230.      $w->select('set', $ent);
  231.  
  232.     }
  233.    elsif($mode eq "multiple")
  234.     {
  235.      $w->select('set', $ent);
  236.     }
  237.    elsif($mode eq "extended")
  238.     {
  239.      $w->select('set', $ent);
  240.     }
  241.   }
  242.  
  243.  $w->Callback(-browsecmd =>$ent);
  244. }
  245.  
  246. sub Button1Motion
  247. {
  248.  my $w = shift;
  249.  my $Ev = $w->XEvent;
  250.  
  251.  delete $w->{'shiftanchor'}; 
  252.  
  253.  my $mode = $w->cget('-selectmode');
  254.  
  255.  if ($mode eq "dragdrop")
  256.   {
  257. #   $w->Send_StartDrag();
  258.    return;
  259.   }
  260.  
  261.  my $ent = $w->GetNearest($Ev->y);
  262.  
  263.  return unless($ent);
  264.  
  265.  if($mode eq "single")
  266.   {
  267.    $w->anchor('set', $ent);
  268.   }
  269.  elsif($mode eq "multiple" || $mode eq "extended")
  270.   {
  271.    my $from = $w->info('anchor');
  272.    if($from)
  273.     {
  274.      $w->select('clear');
  275.      $w->select('set', $from, $ent);
  276.     }
  277.    else
  278.     {
  279.      $w->anchor('set', $ent);
  280.      $w->select('clear');
  281.      $w->select('set', $ent);
  282.     }
  283.   }
  284.  
  285.  if($mode ne "single")
  286.   {
  287.    $w->Callback(-browsecmd =>$ent);
  288.   }
  289. }
  290.  
  291. sub Double1
  292. {
  293.  my $w = shift;
  294.  my $Ev = $w->XEvent;
  295.  
  296.  delete $w->{'shiftanchor'}; 
  297.  
  298.  my $ent = $w->GetNearest($Ev->y);
  299.  
  300.  return unless($ent);
  301.  
  302.  $w->anchor('set', $ent)
  303.     unless($w->info('anchor'));
  304.  
  305.  $w->select('set', $ent);
  306.  $w->Callback(-command => $ent);
  307. }
  308.  
  309. sub CtrlButton1
  310. {
  311.  my $w = shift;
  312.  my $Ev = $w->XEvent;
  313.  
  314.  delete $w->{'shiftanchor'}; 
  315.  
  316.  my $ent = $w->GetNearest($Ev->y);
  317.  
  318.  return unless( $ent );
  319.  
  320.  my $mode = $w->cget('-selectmode');
  321.  
  322.  if($mode eq "extended")
  323.   {
  324.    $w->anchor('set', $ent) unless( $w->info('anchor') );
  325.  
  326.    if($w->select('includes', $ent))
  327.     {
  328.      $w->select('clear', $ent);
  329.     }
  330.    else
  331.     {
  332.      $w->select('set', $ent);
  333.     }
  334.    $w->Callback(-browsecmd =>$ent);
  335.   }
  336. }
  337.  
  338. sub UpDown
  339. {
  340.  my $w = shift;
  341.  my $spec = shift;
  342.  
  343.  my $done = 0;
  344.  my $anchor = $w->info('anchor');
  345.  
  346.  delete $w->{'shiftanchor'}; 
  347.  
  348.  unless( $anchor )
  349.   {
  350.    $anchor = ($w->info('children'))[0] || "";
  351.  
  352.    return unless( $anchor );
  353.  
  354.    if($w->entrycget($anchor, '-state') ne "disabled")
  355.     {
  356.      # That's a good anchor
  357.      $done = 1;
  358.     }
  359.    else
  360.     {
  361.      # We search for the first non-disabled entry (downward)
  362.      $spec = 'next';
  363.     }
  364.   }
  365.  
  366.  my $ent = $anchor;
  367.  
  368.  # Find the prev/next non-disabled entry
  369.  #
  370.  while(!$done)
  371.   {
  372.    $ent = $w->info($spec, $ent);
  373.    last unless( $ent );
  374.    next if( $w->entrycget($ent, '-state') eq "disabled" );
  375.    next if( $w->info('hidden', $ent) );
  376.    last;
  377.   }
  378.  
  379.  unless( $ent )
  380.   {
  381.    $w->yview('scroll', $spec eq 'prev' ? -1 : 1, 'unit');
  382.    return;
  383.   }
  384.  
  385.  $w->anchor('set', $ent);
  386.  $w->see($ent);
  387.  
  388.  if($w->cget('-selectmode') ne "single")
  389.   {
  390.    $w->select('clear');
  391.    $w->selection('set', $ent);
  392.    $w->Callback(-browsecmd =>$ent);
  393.   }
  394. }
  395.  
  396. sub ShiftUpDown
  397. {
  398.  my $w = shift;
  399.  my $spec = shift;
  400.  
  401.  my $mode = $w->cget('-selectmode');
  402.  
  403.  return $w->UpDown($spec)
  404.    if($mode eq "single" || $mode eq "browse");
  405.  
  406.  my $anchor = $w->info('anchor');
  407.  
  408.  return $w->UpDown($spec) unless( $anchor );
  409.  
  410.  my $done = 0;
  411.  
  412.  $w->{'shiftanchor'} = $anchor unless( $w->{'shiftanchor'} ); 
  413.  
  414.  my $ent = $w->{'shiftanchor'};
  415.  
  416.  while( !$done )
  417.   {
  418.    $ent = $w->info($spec, $ent);
  419.    last unless( $ent );
  420.    next if( $w->entrycget($ent, '-state') eq "disabled" );
  421.    next if( $w->info('hidden', $ent) );
  422.    last;
  423.   }
  424.  
  425.  unless( $ent )
  426.   {
  427.    $w->yview('scroll', $spec eq 'prev' ? -1 : 1, 'unit');
  428.    return;
  429.   }
  430.  
  431.  $w->select('clear');
  432.  $w->selection('set', $anchor, $ent);
  433.  $w->see($ent);
  434.  
  435.  $w->{'shiftanchor'} = $ent; 
  436.  
  437.  $w->Callback(-browsecmd =>$ent);
  438. }
  439.  
  440. sub LeftRight
  441. {
  442.  my $w = shift;
  443.  my $spec = shift;
  444.  
  445.  delete $w->{'shiftanchor'}; 
  446.  
  447.  my $anchor = $w->info('anchor');
  448.  
  449.  unless($anchor)
  450.   {
  451.    $anchor = ($w->info('children'))[0] || "";
  452.   }
  453.  
  454.  my $done = 0;
  455.  my $ent = $anchor;
  456.  
  457.  while(!$done)
  458.   {
  459.    my $e = $ent;
  460.  
  461.    if($spec eq "left")
  462.     {
  463.      $ent = $w->info('parent', $e);
  464.  
  465.      $ent = $w->info('prev', $e)
  466.        unless($ent && $w->entrycget($ent, '-state') ne "disabled")
  467.     }
  468.    else
  469.     {
  470.      $ent = ($w->info('children', $e))[0];
  471.  
  472.      $ent = $w->info('next', $e)
  473.        unless($ent && $w->entrycget($ent, '-state') ne "disabled")
  474.     }
  475.  
  476.    last unless( $ent );
  477.    last if($w->entrycget($ent, '-state') ne "disabled");
  478.   }
  479.  
  480.  unless( $ent )
  481.   {
  482.    $w->xview('scroll', $spec eq "left" ? -1 : 1, 'unit');
  483.    return;
  484.   }
  485.  
  486.  $w->anchor('set', $ent);
  487.  $w->see($ent);
  488.  
  489.  if($w->cget('-selectmode') ne "single")
  490.   {
  491.    $w->select('clear');
  492.    $w->selection('set', $ent);
  493.  
  494.    $w->Callback(-browsecmd =>$ent);
  495.   }
  496. }
  497.  
  498. sub KeyboardActivate
  499. {
  500.  my $w = shift;
  501.  
  502.  my $anchor = $w->info('anchor');
  503.  
  504.  return unless( $anchor );
  505.  
  506.  if($w->cget('-selectmode'))
  507.   {
  508.    $w->select('clear');
  509.    $w->select('set', $anchor);
  510.   }
  511.  $w->Callback(-command => $anchor);
  512. }
  513.  
  514. sub KeyboardBrowse
  515. {
  516.  my $w = shift;
  517.  
  518.  my $anchor = $w->info('anchor');
  519.  
  520.  return unless( $anchor );
  521.  
  522.  if ($w->indicatorExists($anchor))
  523.   {
  524.    $w->Callback(-indicatorcmd => $anchor);
  525.   }
  526.  
  527.  if($w->cget('-selectmode'))
  528.   {
  529.    $w->select('clear');
  530.    $w->select('set', $anchor);
  531.   }
  532.  $w->Callback(-browsecmd =>$anchor);
  533. }
  534.  
  535. sub AutoScan
  536. {
  537.  my $w = shift;
  538.  
  539.  return if($w->cget('-selectmode') eq "dragdrop");
  540.  
  541.  my $Ev = $w->XEvent;
  542.  my $y = $Ev->y;
  543.  my $x = $Ev->x;
  544.  
  545.  if($y >= $w->height)
  546.   {
  547.    $w->yview('scroll', 1, 'units');
  548.   }
  549.  elsif($y < 0)
  550.   {
  551.    $w->yview('scroll', -1, 'units');
  552.   }
  553.  elsif($x >= $w->width)
  554.   {
  555.    $w->xview('scroll', 2, 'units');
  556.   }
  557.  elsif($x < 0)
  558.   {
  559.    $w->xview('scroll', -2, 'units');
  560.   }
  561.  else
  562.   {
  563.    return;
  564.   }
  565.  $w->RepeatId($w->after(50,"AutoScan",$w));
  566.  $w->Button1Motion;
  567. }
  568.  
  569. sub children
  570. {
  571.  # Tix has core-tk window(s) which are not a widget(s)
  572.  # the generic code returns these as an "undef"
  573.  my $w = shift;
  574.  my @info = grep(defined($_),$w->winfo('children'));
  575.  @info;
  576. }
  577.  
  578. 1;
  579.  
  580.