home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _1fce6dce9593ea0bb42d6b98c7de73d3 < prev    next >
Text File  |  2004-06-01  |  10KB  |  453 lines
  1. package Tk::NoteBook;
  2. #
  3. # Implementation of NoteBook widget.
  4. # Derived from NoteBook.tcl in Tix 4.0
  5.  
  6. # Contributed by Rajappa Iyer <rsi@earthling.net>
  7. # Hacked by Nick for 'menu' traversal.
  8. # Restructured by Nick
  9.  
  10. use vars qw($VERSION);
  11.  
  12. $VERSION = sprintf '4.%03d', q$Revision: #9 $ =~ /\D(\d+)\s*$/;
  13. require Tk::NBFrame;
  14.  
  15. use base  qw(Tk::Derived Tk::NBFrame);
  16. Tk::Widget->Construct('NoteBook');
  17. use strict;
  18.  
  19. use Tk qw(Ev);
  20.  
  21. use Carp;
  22. require Tk::Frame;
  23.  
  24. sub TraverseToNoteBook;
  25.  
  26. sub ClassInit
  27. {
  28.  my ($class,$mw) = @_;
  29.  # class binding does not work right due to extra level of
  30.  # widget hierachy
  31.  $mw->bind($class,'<ButtonPress-1>', ['MouseDown',Ev('x'),Ev('y')]);
  32.  $mw->bind($class,'<ButtonRelease-1>', ['MouseUp',Ev('x'),Ev('y')]);
  33.  
  34.  $mw->bind($class,'<B1-Motion>', ['MouseDown',Ev('x'),Ev('y')]);
  35.  $mw->bind($class,'<Left>', ['FocusNext','prev']);
  36.  $mw->bind($class,'<Right>', ['FocusNext','next']);
  37.  
  38.  $mw->bind($class,'<Return>', 'SetFocusByKey');
  39.  $mw->bind($class,'<space>', 'SetFocusByKey');
  40.  return $class;
  41. }
  42.  
  43. sub raised
  44. {
  45.  return shift->{'topchild'};
  46. }
  47.  
  48. sub Populate
  49. {
  50.  my ($w, $args) = @_;
  51.  
  52.  $w->SUPER::Populate($args);
  53.  $w->{'pad-x1'} = undef;
  54.  $w->{'pad-x2'} = undef;
  55.  $w->{'pad-y1'} = undef;
  56.  $w->{'pad-y2'} = undef;
  57.  
  58.  $w->{'windows'} = [];
  59.  $w->{'nWindows'} = 0;
  60.  $w->{'minH'} = 1;
  61.  $w->{'minW'} = 1;
  62.  
  63.  $w->{'counter'} = 0;
  64.  $w->{'resize'} = 0;
  65.  
  66.  $w->ConfigSpecs(-ipadx => ['PASSIVE', 'ipadX', 'Pad', 0],
  67.          -ipady => ['PASSIVE', 'ipadY', 'Pad', 0],
  68.          -takefocus => ['SELF', 'takeFocus', 'TakeFocus', 0],
  69.          -dynamicgeometry => ['PASSIVE', 'dynamicGeometry', 'DynamicGeometry', 0]);
  70.  
  71.  # SetBindings
  72.  $w->bind('<Configure>','MasterGeomProc');
  73.  
  74.  $args->{-slave} = 1;
  75.  $args->{-takefocus} = 1;
  76.  $args->{-relief} = 'raised';
  77.  
  78.  $w->QueueResize;
  79. }
  80.  
  81.  
  82. #---------------------------
  83. # Public methods
  84. #---------------------------
  85.  
  86. sub page_widget
  87. {
  88.  my $w = shift;
  89.  $w->{'_pages_'} = {} unless exists $w->{'_pages_'};
  90.  my $h = $w->{'_pages_'};
  91.  if (@_)
  92.   {
  93.    my $name = shift;
  94.    if (@_)
  95.     {
  96.      my $cw = shift;
  97.      if (defined $cw)
  98.       {
  99.        $h->{$name} = $cw;
  100.       }
  101.      else
  102.       {
  103.        return delete $h->{$name};
  104.       }
  105.     }
  106.    return $h->{$name};
  107.   }
  108.  else
  109.   {
  110.    return (values %$h);
  111.   }
  112. }
  113.  
  114. sub add
  115. {
  116.  my ($w, $child, %args) = @_;
  117.  
  118.  croak("$child already exists") if defined $w->page_widget($child);
  119.  
  120.  my $f = Tk::Frame->new($w,Name => $child,-relief => 'raised');
  121.  
  122.  my $ccmd = delete $args{-createcmd};
  123.  my $rcmd = delete $args{-raisecmd};
  124.  $f->{-createcmd} = Tk::Callback->new($ccmd) if (defined $ccmd);
  125.  $f->{-raisecmd} = Tk::Callback->new($rcmd) if (defined $rcmd);
  126.  
  127.  # manage our geometry
  128.  $w->ManageGeometry($f);
  129.  # create default bindings
  130.  $f->bind('<Configure>',[$w,'ClientGeomProc','-configure', $f]);
  131.  $f->bind('<Destroy>',  [$w,'delete',$child,1]);
  132.  $w->page_widget($child,$f);
  133.  $w->{'nWindows'}++;
  134.  push(@{$w->{'windows'}}, $child);
  135.  $w->SUPER::add($child,%args);
  136.  return $f;
  137. }
  138.  
  139. sub raise
  140. {
  141.  my ($w, $child) = @_;
  142.  return unless defined $child;
  143.  if ($w->pagecget($child, -state) eq 'normal')
  144.   {
  145.    $w->activate($child);
  146.    $w->focus($child);
  147.    my $childw = $w->page_widget($child);
  148.    if ($childw)
  149.     {
  150.      if (defined $childw->{-createcmd})
  151.       {
  152.        $childw->{-createcmd}->Call($childw);
  153.        delete $childw->{-createcmd};
  154.       }
  155.      # hide the original visible window
  156.      my $oldtop = $w->{'topchild'};
  157.      if (defined($oldtop) && ($oldtop ne $child))
  158.       {
  159.        $w->page_widget($oldtop)->UnmapWindow;
  160.       }
  161.      $w->{'topchild'} = $child;
  162.      my $myW = $w->Width;
  163.      my $myH = $w->Height;
  164.  
  165.      if (!defined $w->{'pad-x1'}) {
  166.      $w->InitTabSize;
  167.      }
  168.  
  169.      my $cW = $myW - $w->{'pad-x1'} - $w->{'pad-x2'} - 2 * (defined $w->{-ipadx} ? $w->{-ipadx} : 0);
  170.      my $cH = $myH - $w->{'pad-y1'} - $w->{'pad-y2'} - 2 * (defined $w->{-ipady} ? $w->{-ipady} : 0);
  171.      my $cX = $w->{'pad-x1'} + (defined $w->{-ipadx} ? $w->{-ipadx} : 0);
  172.      my $cY = $w->{'pad-y1'} + (defined $w->{-ipady} ? $w->{-ipady} : 0);
  173.  
  174.      if ($cW > 0 && $cH > 0)
  175.       {
  176.        $childw->MoveResizeWindow($cX, $cY, $cW, $cH);
  177.        $childw->MapWindow;
  178.        $childw->raise;
  179.       }
  180.      if ((not defined $oldtop) || ($oldtop ne $child))
  181.       {
  182.        if (defined $childw->{-raisecmd})
  183.     {
  184.      $childw->{-raisecmd}->Call($childw);
  185.     }
  186.       }
  187.     }
  188.   }
  189. }
  190.  
  191. sub pageconfigure
  192. {
  193.  my ($w, $child, %args) = @_;
  194.  my $childw = $w->page_widget($child);
  195.  if (defined $childw)
  196.   {
  197.    my $ccmd = delete $args{-createcmd};
  198.    my $rcmd = delete $args{-raisecmd};
  199.    $childw->{-createcmd} = Tk::Callback->new($ccmd) if (defined $ccmd);
  200.    $childw->{-raisecmd} = Tk::Callback->new($rcmd) if (defined $rcmd);
  201.    $w->SUPER::pageconfigure($child, %args) if (keys %args);
  202.   }
  203. }
  204.  
  205. sub pages {
  206.     my ($w) = @_;
  207.     return @{$w->{'windows'}};
  208. }
  209.  
  210. sub pagecget
  211. {
  212.  my ($w, $child, $opt) = @_;
  213.  my $childw = $w->page_widget($child);
  214.  if (defined $childw)
  215.   {
  216.    return $childw->{-createcmd} if ($opt =~ /-createcmd/);
  217.    return $childw->{-raisecmd} if ($opt =~ /-raisecmd/);
  218.    return $w->SUPER::pagecget($child, $opt);
  219.   }
  220.  else
  221.   {
  222.    carp "page $child does not exist";
  223.   }
  224. }
  225.  
  226. sub delete
  227. {
  228.  my ($w, $child, $destroy) = @_;
  229.  my $childw = $w->page_widget($child,undef);
  230.  if (defined $childw)
  231.   {
  232.    $childw->bind('<Destroy>', undef);
  233.    $childw->destroy;
  234.    @{$w->{'windows'}} = grep($_ !~ /$child/, @{$w->{'windows'}});
  235.    $w->{'nWindows'}--;
  236.    $w->SUPER::delete($child);
  237.    # see if the child to be deleted was the top child
  238.    if ((defined $w->{'topchild'}) && ($w->{'topchild'} eq $child))
  239.     {
  240.      delete $w->{'topchild'};
  241.      if ( @{$w->{'windows'}})
  242.       {
  243.        $w->raise($w->{'windows'}[0]);
  244.       }
  245.     }
  246.   }
  247.  else
  248.   {
  249.    carp "page $child does not exist" unless $destroy;
  250.   }
  251. }
  252.  
  253. #---------------------------------------
  254. # Private methods
  255. #---------------------------------------
  256.  
  257. sub MouseDown {
  258.     my ($w, $x, $y) = @_;
  259.     my $name = $w->identify($x, $y);
  260.     $w->focus($name);
  261.     $w->{'down'} = $name;
  262. }
  263.  
  264. sub MouseUp {
  265.     my ($w, $x, $y) = @_;
  266.     my $name = $w->identify($x, $y);
  267.     if ((defined $name) && (defined $w->{'down'}) &&
  268.     ($name eq $w->{'down'}) &&
  269.     ($w->pagecget($name, -state) eq 'normal')) {
  270.     $w->raise($name);
  271.     } else {
  272.     $w->focus($name);
  273.     }
  274. }
  275.  
  276. sub FocusNext {
  277.     my ($w, $dir) = @_;
  278.     my $name;
  279.  
  280.     if (not defined $w->info('focus')) {
  281.     $name = $w->info('active');
  282.     $w->focus($name);
  283.     } else {
  284.     $name = $w->info('focus' . $dir);
  285.     $w->focus($name);
  286.     }
  287. }
  288.  
  289. sub SetFocusByKey {
  290.     my ($w) = @_;
  291.  
  292.     my $name = $w->info('focus');
  293.     if (defined $name) {
  294.     if ($w->pagecget($name, -state) eq 'normal') {
  295.         $w->raise($name);
  296.         $w->activate($name);
  297.     }
  298.     }
  299. }
  300.  
  301. sub NoteBookFind {
  302.     my ($w, $char) = @_;
  303.  
  304.     my $page;
  305.     foreach $page (@{$w->{'windows'}}) {
  306.     my $i = $w->pagecget($page, -underline);
  307.     my $c = substr($page, $i, 1);
  308.     if ($char =~ /$c/) {
  309.         if ($w->pagecget($page, -state) ne 'disabled') {
  310.         return $page;
  311.         }
  312.     }
  313.     }
  314.     return undef;
  315. }
  316.  
  317. # This is called by TraveseToMenu when an <Alt-Keypress> occurs
  318. # See the code in Tk.pm
  319. sub FindMenu {
  320.     my ($w, $char) = @_;
  321.  
  322.     my $page;
  323.     foreach $page (@{$w->{'windows'}}) {
  324.     my $i = $w->pagecget($page, -underline);
  325.     my $l = $w->pagecget($page, -label);
  326.     next if (not defined $l);
  327.     my $c = substr($l, $i, 1);
  328.     if ($char =~ /$c/i) {
  329.         if ($w->pagecget($page, -state) ne 'disabled') {
  330.         $w->raise($page);
  331.         return $w;
  332.         }
  333.     }
  334.     }
  335.     return undef;
  336. }
  337.  
  338.  
  339. sub MasterGeomProc
  340. {
  341.  my ($w) = @_;
  342.  if (Tk::Exists($w))
  343.   {
  344.    $w->{'resize'} = 0 unless (defined $w->{'resize'});
  345.    $w->QueueResize;
  346.   }
  347. }
  348.  
  349. sub SlaveGeometryRequest
  350. {
  351.  my $w = shift;
  352.  if (Tk::Exists($w))
  353.   {
  354.    $w->QueueResize;
  355.   }
  356. }
  357.  
  358. sub LostSlave {
  359.     my ($w, $s) = @_;
  360.     $s->UnmapWindow;
  361. }
  362.  
  363. sub ClientGeomProc
  364. {
  365.  my ($w, $flag, $client) = @_;
  366.  $w->QueueResize if (Tk::Exists($w));
  367.  if ($flag =~ /-lostslave/)
  368.   {
  369.    carp "Geometry Management Error: Another geometry manager has taken control of $client. This error is usually caused because a widget has been created in the wrong frame: it should have been created inside $client instead of $w";
  370.   }
  371. }
  372.  
  373. sub QueueResize
  374. {
  375.  my $w = shift;
  376.  $w->afterIdle(['Resize', $w]) unless ($w->{'resize'}++);
  377. }
  378.  
  379. sub Resize {
  380.  
  381.     my ($w) = @_;
  382.  
  383.     return unless Tk::Exists($w) && $w->{'nWindows'} && $w->{'resize'};
  384.  
  385.     $w->InitTabSize;
  386.  
  387.     $w->{'resize'} = 0;
  388.     my $reqW = $w->{-width} || 0;
  389.     my $reqH = $w->{-height} || 0;
  390.  
  391.     if ($reqW * $reqH == 0)
  392.      {
  393.     if ((not defined $w->{-dynamicgeometry}) ||
  394.         ($w->{-dynamicgeometry} == 0)) {
  395.         $reqW = 1;
  396.         $reqH = 1;
  397.  
  398.         my $childw;
  399.         foreach $childw ($w->page_widget)
  400.          {
  401.         my $cW = $childw->ReqWidth;
  402.         my $cH = $childw->ReqHeight;
  403.         $reqW = $cW if ($reqW < $cW);
  404.         $reqH = $cH if ($reqH < $cH);
  405.         }
  406.     } else {
  407.         if (defined $w->{'topchild'}) {
  408.         my $topw = $w->page_widget($w->{'topchild'});
  409.         $reqW = $topw->ReqWidth;
  410.         $reqH = $topw->ReqHeight;
  411.         } else {
  412.         $reqW = 1;
  413.         $reqH = 1;
  414.         }
  415.     }
  416.     $reqW += $w->{'pad-x1'} + $w->{'pad-x2'} + 2 * (defined $w->{-ipadx} ? $w->{-ipadx} : 0);
  417.     $reqH += $w->{'pad-y1'} + $w->{'pad-y2'} + 2 * (defined $w->{-ipady} ? $w->{-ipady} : 0);
  418.     $reqW = ($reqW > $w->{'minW'}) ? $reqW : $w->{'minW'};
  419.     $reqH = ($reqH > $w->{'minH'}) ? $reqH : $w->{'minH'};
  420.     }
  421.     if (($w->ReqWidth != $reqW) ||
  422.     ($w->ReqHeight != $reqH)) {
  423.     $w->{'counter'} = 0 if (not defined $w->{'counter'});
  424.     if ($w->{'counter'} < 50) {
  425.         $w->{'counter'}++;
  426.         $w->GeometryRequest($reqW, $reqH);
  427.         $w->afterIdle([$w,'Resize']);
  428.         $w->{'resize'} = 1;
  429.         return;
  430.     }
  431.     }
  432.     $w->{'counter'} = 0;
  433.     $w->raise($w->{'topchild'} || ${$w->{'windows'}}[0]);
  434.     $w->{'resize'} = 0;
  435. }
  436.  
  437. sub InitTabSize {
  438.     my ($w) = @_;
  439.     my ($tW, $tH) = $w->geometryinfo;
  440.     $w->{'pad-x1'} = 2;
  441.     $w->{'pad-x2'} = 2;
  442.     $w->{'pad-y1'} = $tH + (defined $w->{'-ipadx'} ? $w->{'-ipadx'} : 0) + 1;
  443.     $w->{'pad-y2'} = 2;
  444.     $w->{'minW'} = $tW;
  445.     $w->{'minH'} = $tH;
  446. }
  447.  
  448. 1;
  449.  
  450. __END__
  451.  
  452. =cut
  453.