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