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