view release on metacpan or  search on metacpan

lib/Tcl/pTk/Pane.pm  view on Meta::CPAN

# Tk::Pane.pm
#

# Dummy package declaration for Scrollable Frame, to avoid warning messages
#   when we set the Tcl::pTk::Pane::ISA below
#
package Tcl::pTk::ScrollableFrame;

package Tcl::pTk::Pane;

our ($VERSION) = ('1.11');

use Tcl::pTk;
use Tcl::pTk::Widget;
use Tcl::pTk::Derived;

use Carp (qw/ croak /);

use strict;

#use base qw(Tcl::pTk::Derived Tcl::pTk::ScrollableFrame);
@Tcl::pTk::Pane::ISA = (qw/ Tcl::pTk::Derived Tcl::pTk::ScrollableFrame /);

Tcl::pTk::Widget->Construct('Pane');

# Setup binding so the scrollwheel works
sub ClassInit
{
 my ($class,$mw) = @_;
 $class->SUPER::ClassInit($mw);


 $mw->MouseWheelBind($class);
}


sub Populate {
    my( $cw, $args ) = @_;

    $cw->SUPER::Populate( $args );

    #### Setup options ###
    
    # Get native options first and turn into data to feed configSpaces
    my @nativeOptions = $cw->Tcl::pTk::Widget::configure();
    my %configSpecs;
    foreach my $optElement(@nativeOptions){
            my $name = $optElement->[0];
            my @optData = ('SELF', @$optElement[1..3]);
            
            # Change any '{}' that shows up for scrollcommands to undefs
            #   Without this, configure is called with something like "-yscrollcommand => '{}'", which
            #    causes problems
            $optData[3] = undef if( defined($optData[3]) && $optData[3] eq '{}');
            
            # Remove any options surrounded by brackets (e.g. change '{#d9d9d9}' to '#d9d9d9'). The brackets
            #  cause problems when calling tcl configure (e.g. '.window configure -background {#d9d9d9} causes problems
            if( defined($optData[3]) ){
                    $optData[3] =~ s/^\s*\{//;
                    $optData[3] =~ s/\}$//;
            }
            
            $configSpecs{$name} = [@optData];
    }
                    
    #  gridded and sticky are here to emulate the original Tk::Pane version
    #  They don't do anything in this widget
    $cw->ConfigSpecs(
        -gridded         => [qw/PASSIVE gridded gridded/, undef],
        -sticky         =>  [qw/PASSIVE sticky sticky/, undef],
        %configSpecs
    );
    
    # The frame widget of the BWidget ScrollableFrame is our default delegate
    #   for any methods
    my $frame = $cw->getframe;
    $frame = $cw->interp->declare_widget($frame, 'Tcl::pTk::Frame'); # turn path name into widget

    $cw->Advertise('frame', $frame); 
    
    $cw->Delegates('Construct' => $frame,
                   );