Perl TK 抽屉式组件

转自：http://bbs.chinaunix.net/thread-3591026-1-1.html


    #!perl -w
    use Tk;
    $mw = MainWindow->new;
    $mw->title( 'Tk' );

    $FRAME_L  = $mw->Frame->pack(qw/-side left -fill both/);
    $WIDGET_F = $FRAME_L->Labelframe()->pack(qw/-side top -fill both -expand 1/);

    my %section = (
            A        => [1,2,3],B        => [4,5,6],C        => [7,8,9],);
    my (@frames,@button);
    for my $sect_name (sort keys %section) {
            my $b;
            my $f = $WIDGET_F->Frame(
                    -bg          => 'green',-relief      => 'sunken',-borderwidth => 1
            );
            $b = $WIDGET_F->Radiobutton(
                    -text        => $sect_name,-indicatoron => 0,-value       => $sect_name,-width                 => 25,-bg                         => '#af1a3c6a6872',-fg                         => 'white',-command => sub {
                            $_->packForget for @frames;
                            $f->pack(
                                    -after => $b,qw/-side top -fill both -expand 1 -padx 1 -pady 1/
                            );
            }
            )->pack(qw/-fill x -side top -padx 1 -pady 1/);
           
            for my $par_tmp (@{ $section{$sect_name} }) {
                    $f->Button(
                            -text    => "$par_tmp",-relief  => 'ridge',-bg      => '#8189ce14cf5b',-fg      => 'black',)->pack(qw/-side top -fill x -padx 4  /);
            }

            push @frames,$f;
            push @button,$b;
    }

    $FRAME_L->Button(
            -text        => "CLOSE",-borderwidth => 1,-bg          => "white",-fg          => "black",-command     => sub { exit; },)->pack(qw/-side bottom -fill x -padx 1 -pady 2 /);

    MainLoop;