view release on metacpan or  search on metacpan

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

=head2 ttkSetTheme

Set a Tile Theme
        
B<Usage:>

        $widget->ttkSetTheme($name);

=cut

sub Tcl::pTk::Widget::ttkSetTheme {
	my $self = shift;

	my $theme = shift;

	$self->interp->call( 'ttk::setTheme', $theme );

}

##################################################

=head2 ttkThemes

Get a list of Tile/ttk theme names
        
B<Usage:>

        my @themes $widget->ttkThemes;

=cut

sub Tcl::pTk::Widget::ttkThemes {
	my $self = shift;

	$self->interp->call('ttk::themes');

}

##################################################

=head2 _declareTileWidgets

Internal sub to declare the tile widgets. This is called when a mainwindow
is created, if we are using Tcl/Tk 8.5 or higher, or the Tile package for
Tcl/Tk 8.4 is present.

B<Usage:>

        _declareTileWidgets($interp);
        
        where $interp is the Tcl interp object

=cut

sub _declareTileWidgets {
	my $interp = shift;

	my @ttkwidgets = (
		qw/
		  button checkbutton combobox entry frame image label
		  label labelframe menubutton notebook panedwindow
		  progressbar radiobutton scale scrollbar separator
		  sizegrip treeview /
	);

	foreach my $ttkwidget (@ttkwidgets) {

		#print STDERR "delcareing "."ttk".ucfirst($ttkwidget).
		#                 "  ttk::$ttkwidget\n";
		$interp->Declare(
			'ttk' . ucfirst($ttkwidget),
			"ttk::$ttkwidget",
			-require => 'tile',
		);
	}

}

#
##################################################

=head2 _setupMapping

Internal method called at startup to provide mapping to the Tile methods. See the docs above on how
mapping is done.
        
B<Usage:>

        Tcl::pTk::Tile->_setupMapping($package, @mappingSpecs);

=cut

sub _setupMapping {
	my $class = shift;
	no strict 'refs';
	my $package = shift;
	while (@_) {
		my $commandBase = shift;
		my $mappedcommandBase = shift;
		my $submethods = shift;
		foreach my $submethod ( @{$submethods} ) {
			my $pfn = $package . '::' . $commandBase;
			my $methodName = $pfn . "\u$submethod";
			#print "Creating method $methodName for call ".join(" ", @$mappedcommandBase, $submethod)."\n";
			*{ $methodName } = sub {
				my $self = shift;
				$self->call( @$mappedcommandBase, $submethod, @_ );
			};
		}
	}
}

###### Special cases to get ttkTreeview methods to work ###

# Avoid using Tcl::pTk::Widget::children
sub Tcl::pTk::ttkTreeview::children {
    my $self = shift;
    $self->call($self->path, 'children', @_);
}