#!/usr/bin/perl -w
use Tk;
use Tk::widgets qw/LabEntry/;
use strict;

package MyCollapsableFrame;

use Carp;
use Tk::widgets qw/Frame/;
use vars qw/$cf_height_bias $im_Close $im_Open/;
use strict;

use base qw/Tk::Frame/;
Construct Tk::Widget 'MyCollapsableFrame';

sub ClassInit {

    # Define global variables and images for the class.

    my($class, $mw) = @_;

    $cf_height_bias = 22;

    $im_Close = $mw->Bitmap(-data => <<'END');
#define close_width 16
#define close_height 16
static unsigned char close_bits[] = {
  0x00, 0x80, 0x00, 0xc0, 0x00, 0xc0, 0x00, 0xc0, 0x00, 0xc0, 0x00, 0x
+c0,
  0xf0, 0xc7, 0xe0, 0xc3, 0xc0, 0xc1, 0x80, 0xc0, 0x00, 0xc0, 0x00, 0x
+c0,
  0x00, 0xc0, 0x00, 0xc0, 0xfe, 0xff, 0xff, 0xff, };
END

    $im_Open = $mw->Bitmap(-data => << 'END');
#define open_width 16
#define open_height 16
static unsigned char open_bits[] = {
  0x00, 0x80, 0x00, 0xc0, 0x00, 0xc0, 0x00, 0xc0, 0x40, 0xc0, 0xc0, 0x
+c0,
  0xc0, 0xc1, 0xc0, 0xc3, 0xc0, 0xc1, 0xc0, 0xc0, 0x40, 0xc0, 0x00, 0x
+c0,
  0x00, 0xc0, 0x00, 0xc0, 0xfe, 0xff, 0xff, 0xff, };
END
    
    $class->SUPER::ClassInit($mw);

} # end ClassInit

sub Populate {

    # Create an instance of a CollapsableFrame.  Instance variables ar
+e:
    #
    # {frame} = the ridged frame, which contains the open/close
    #           Label image, the id Label for the collapsable Frame,
    #           and the container Frame within which the user manages
    #           collapsable widgets.  It's ALMOST possible to forgo
    #           this extra internal frame, were it not for the -pady
    #           packer attribute we use to make the widget look pretty
+.
    # {opcl}  = the open/close image Label.
    # {ident} = the identifying Label.
    # {colf}  = the user's container Frame, advertised as "colf".

    my($self, $args) = @_;

    my $height = $args->{-height};
    croak "Tk::CollapsableFrame: -height must be >= $cf_height_bias" u
+nless
        $height >= $cf_height_bias;
    $self->SUPER::Populate($args);

    $self->{frame} = $self->Frame(
        qw/-borderwidth 2 -height 16 -relief ridge/,
    );
    $self->{frame}->pack(
        qw/-anchor center -expand 1 -fill x -pady 7 -side left/,
    );

    $self->{opcl} = $self->Label(
        qw/-borderwidth 0 -relief raised/, -text => $height,
    );
    $self->{opcl}->bind('<Button-1>' => [sub {$_[1]->toggle}, $self]);
    $self->{opcl}->place(
        qw/-x 5 -y -1 -width 21 -height 21 -anchor nw -bordermode igno
+re/,
    );

    $self->{ident} = $self->Label(qw/-anchor w -borderwidth 1/);
    $self->{ident}->place(
        qw/-x 23 -y 3  -height 12 -anchor nw -bordermode ignore/,
    );

    $self->{colf} = $self->{frame}->Frame;
    $self->{colf}->place(qw/-x 20 -y 15 -relwidth 1.0 -width -20/);
    $self->Advertise('colf' => $self->{colf});

    if (not defined $args->{-width}) {
    $args->{-width} = $self->parent->cget(-width);
    }

    $self->ConfigSpecs(
      -background  => [['SELF', 'CHILDREN'], qw/background Background/
+],
      -height      => [qw/METHOD height Height 47/],
      -image       => [$self->{opcl}, 'image', 'Image', $im_Open],
      -title       => '-text',
      -text        => [$self->{ident}, qw/text Text NoTitle/],
      -font        => [$self->{ident}, qw/font Font NoTitle/],
      -width       => [$self->{frame}, qw/width Width 250/],
    );
   
} # end Populate

sub bias {return $cf_height_bias}

# Public instance methods.

sub close {
    my($self) = @_;
    $self->{opcl}->configure(-image  => $im_Open);
    $self->{frame}->configure(-height => 16);
}

sub open  {
    my($self) = @_;
    $self->{opcl}->configure(-image  => $im_Close);
    $self->{frame}->configure(-height => $self->{opcl}->cget(-text));
}

sub state {
    my($self) = @_;
    my $i = $self->{opcl}->cget(-image);
    my $op = ($i == $im_Open) ? 'close' : 'open';
    return $op;
}

sub toggle {
    my($self) = @_;
    my $i = $self->{opcl}->cget(-image);
    my $op = ($i == $im_Open) ? 'open' : 'close';
    $self->$op();
}

# Private instance methods.

sub height {
    my($self, $h) = @_;
    $self->{opcl}->configure(-text => $h);
}

1;

package main;

my $mw = MainWindow->new;

$mw->fontCreate('big',
   -family=>'arial',
  -weight=>'bold',
  -size=>int(-18*18/14));


$mw->fontCreate('big1',
   -family=>'arial',
  -weight=>'bold',
  -size=>int(-10*10/14));



my $cf = $mw->MyCollapsableFrame(
    -background => 'lightblue',
    -height     => 110,
    -title      => 'Copy Details',
    -width      => 300,
    -font       => 'big1',
);
$cf->pack(qw/-fill x -expand 1/);

my $cf_frame = $cf->Subwidget('colf');

# Populate the CollapsableFrame with detail information.

my ($file, $from, $to, $bytes) =
    ('Makefile.PL', '/home/bug', '/tmp', '1,847');
foreach my $item (
        ['Copying',      \$file],
        ['From',         \$from],
        ['To',           \$to],
        ['Bytes Copied', \$bytes],
    ) {
    my $l = $item->[0] . ':';
    my $le = $cf_frame->LabEntry(
        -background          => 'lightgreen',
        -highlightbackground => 'blue',
        -label               => ' ' x (13 - length $l) . $l,
        -labelBackground     => 'lightgreen',
        -labelPack           => [qw/-side left -anchor w/],
        -labelFont           => '9x15bold',
        -relief              => 'flat',
        -state               => 'disabled',
        -textvariable        => $item->[1],
        -width               => 35,
        
    );
    $le->pack(qw/ -fill x -expand 1/);
}


my $button = $mw->Button(-text =>'Change Font',
       -command => sub{  
             $cf->configure(-font => 'big');
       
          })->pack();
 
MainLoop;
[download]