Tk::Multi::Toplevel - Toplevel MultiManager

 use Tk::Multi::Toplevel ;

 my $mw = MainWindow-> new ;

 my $p = $mw->MultiTop();

 # If Multi::Toplevel is the only Tk window of your application
 $mw -> withdraw ; # hide the main window
 # destroy the main window when close is called
 $p -> OnDestroy(sub{$mw->destroy});

 # add a 'bar' menu with a 'foo' button on the menu bar
 $p->menuCommand(name => 'foo', menu => 'bar', 
                 sub => sub{warn "invoked  bar->foo\n";});

 # add a menu button on the 'File' menu
 $p->add(
         'command', 
         -label => 'baz', 
         -command => sub {warn "invoked  File->baz\n";}
        );

 $widget->->menuCommand(name => 'foo', menu => 'example', 
   sub => \&a_sub);

 $widget->->menuCommand(name => 'bar', menu => 'example', 
   sub => \&a_sub);

 $widget->menuRemove(name => 'bar', menu => 'example');

############################################################
#
# $Header: /var/lib/cvs/Tk_Multi/Multi/Toplevel.pm,v 1.9 2004/10/11 14:54:00 domi Exp $
#
# $Source: /var/lib/cvs/Tk_Multi/Multi/Toplevel.pm,v $
# $Revision: 1.9 $
# $Locker:  $
# 
############################################################

package Tk::Multi::Toplevel ;

use Carp ;

use strict ;
use Tk::Multi::Any ;
require Tk::Toplevel;
require Tk::Derived;

use vars qw(@ISA $VERSION) ;
$VERSION = sprintf "%d.%03d", q$Revision: 1.9 $ =~ /(\d+)\.(\d+)/;

@ISA = qw(Tk::Derived Tk::Toplevel);

Tk::Widget->Construct('MultiTop') ;


sub Populate
  {
    my ($cw,$args) = @_ ;
    Tk::Multi::Any::normalize($cw,$args) ;

    require Tk::Multi::Manager ;
    require Tk::Multi::Frame ;
    require Tk::Multi::Text ;
    require Tk::ObjScanner ;
    
    $cw->{manager} = delete $args->{-manager} || $cw ;
    $cw->{podName} = delete $args->{-podName} ;
    $cw->{podSection} = delete $args->{-podSection} ;

    my $showDebug = sub 
      { 
        # must not create 2 scanner windows
        my $t = 'internals' ;
        unless (defined $cw->getSlave($t))
          {
            my $f = $cw -> newSlave(type => 'MultiFrame', 
                                    title => $t, 
                                    destroyable => 1);
            $f -> ObjScanner('caller' => $cw->{manager}, destroyable => 0) 
              -> pack(-expand => 1);
          }
      } ;

    # create common menu bar
    my $w_menu = $cw ->
      Frame(-relief => 'raised', -borderwidth => 2) -> pack(-fill => 'x');

    my $fmenu= $w_menu->Menubutton(-text => 'File', -underline => 0) ;
    $fmenu-> pack(-side => 'left' );

    $cw->Advertise('fileMenu' => $fmenu->menu);

    $fmenu->command
      (
       -label => 'close',  
       -command => sub{$cw->destroy;}
      );

    $fmenu->command
      (
       -label => 'show internals...',  
       -command => $showDebug 
      );

    $cw->Advertise('menubar' => $w_menu);

    # load MultiText::manager
    my $mmgr = $cw -> MultiManager 
      ( 
       'title' => 'windows' , 
       'menu' => $w_menu ,
       'help' => sub {$cw->showHelp() ;}
      ) 
        -> pack (-expand => 1, -fill => 'both');
    
    $cw->Advertise('multiMgr' => $mmgr);
    # bind dump info 
    #$self->{tk}{toplevel}->bind ('<Meta-d>', $showDebug);
    

    $cw->ConfigSpecs(
                     '-relief' => [$cw],
                     '-borderwidth' => [$cw],
                     'DEFAULT' => [$cw]
                    ) ;
    $cw->Delegates
      (
       newSlave => 'multiMgr',
       getSlave => 'multiMgr',
       hide => 'multiMgr',
       show => 'multiMgr',
       destroySlave => 'multiMgr',
       'add' => 'fileMenu',
       'delete' => 'fileMenu',
       'insert' => 'fileMenu',
       DEFAULT => $cw
      ) ;

    # needed to avoid geometry problems with packAdjuster
    #$cw->DoWhenIdle(sub{ $cw->packPropagate(0);}) ;
    $cw->SUPER::Populate($args);
  }


sub menuCommand
  {
    my $cw = shift ;
    my %args = Tk::Multi::Any::normalize($cw,@_) ;
    my $name = $args{-name};
    my $menu = $args{-menu} ;

    unless (defined $cw->Subwidget($menu))
      {
        my $mb = $cw->Subwidget('menubar') -> 
          Menubutton (-text => $menu) ;
        $mb-> pack ( -fill => 'x' , -side => 'left');
        $cw->Advertise($menu => $mb );
        
        # first fill
        $mb->command (-label => $name, -command => $args{-command}) ;
        @{$cw->{menuItems}{$menu}} = ($name);
        return ;
      }

    push @{$cw->{menuItems}{$menu}}, $name;

    my %hash;
    my $i = 1 ;
    map($hash{$_}= $i++, sort @{$cw->{menuItems}{$menu}}) ;

    my $pos = $hash{$name} == ($i-1) ? 'end' : $hash{$name} ;
    $cw->Subwidget($menu) -> menu -> insert
      (
       $pos,'command',
       -label => $name,
       -command => $args{-command}
      );
  }

sub menuRemove
  {
    my $cw = shift ;
    my %args = Tk::Multi::Any::normalize($cw,@_) ; # name , menu
    my $name = $args{-name}; # can be an array ref
    my $menu = $args{-menu};

    my %hash;
    my $i = 1;
    map($hash{$_}= $i++, sort @{$cw->{menuItems}{$menu}}) ;

    my @array = ref($name) ? @$name : ($name) ;
    foreach (@array)
      {
        my $pos = $hash{$_} == ($i-1) ? 'end' : $hash{$_} ;

        $cw->Subwidget($menu) -> menu ->delete($pos) ;
        delete $hash{$_};
        @{$cw->{menuItems}{$menu}} = keys %hash ; # ugly
      }
    
    # cleanup 
    if (scalar @{$cw->{menuItems}{$menu}} == 0)
      {
        delete $cw->{menuItems}{$menu};
        $cw->Subwidget($menu)-> destroy ;
        delete $cw->{SubWidget}{$menu}; # Tk::mega bug workaround
      }
  }

sub showHelp
  {
    my $cw = shift ;
    my %args = $cw->normalize(@_) ; 
    my $podName = $args{-pod} ;
    my $podSection = $args{-section} ;

    require Tk::Pod::Text ;
    require Tk::Pod ;
    
    my $class =  defined $podName ? $podName : 
      defined $cw->{podName} ? $cw->{podName} : ref($cw);
    my $section = defined $podSection ? $podSection :
      defined  $cw->{podSection} ? $cw->{podSection} : 'DESCRIPTION' ;

    my $podSpec = $class.'/"'.$section.'"' ;

    my $topTk = $cw->MainWindow ;

    #print "podW is ",ref($podWidget)," children ",$topTk->children,"\n";
    my ($pod)  = grep (ref($_) eq 'Tk::Pod',$topTk->children) ;
    #print "1 pod is $pod, ",ref($pod),"\n";

    unless (defined $pod) 
      {
        #print "Creating Tk::Pod\n";
        $pod = $topTk->Pod() ;
      }

    #print "2 pod is $pod, ",ref($pod),"\n";

#    $podWidget = $topTk->Pod() 
#      unless (defined $podWidget and ref($podWidget) eq 'Tk::Pod' );

    # first param is 'reuse' or 'new'.
    # Pod::Text cannot find a section befire it is displayed
    #print $podSpec,"\n";
    $pod->Subwidget('pod')->Link('reuse',undef, $podSpec)

  }

1;

__END__