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",
            -relief      => 'sunken',
            -borderwidth => 1,
            -bg          => "white",
            -fg          => "black",
            -command     => sub { exit; },
    )->pack(qw/-side bottom -fill x -padx 1 -pady 2 /);

    MainLoop;