Perl TK 抽屉式组件

来源：互联网发布：linux 设置附加组编辑：程序博客网时间：2024/04/29 13:48
转自：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;