view release on metacpan or  search on metacpan

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

=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', @_);
}

# Ensure Perl list (not Tcl list) is returned
# https://github.com/chrstphrchvz/perl-tcl-ptk/issues/7
sub Tcl::pTk::ttkTreeview::selection {
    my $self = shift;
    $self->call($self->path, 'selection', @_);
}
sub Tcl::pTk::ttkTreeview::item {
    my $self = shift;
    $self->call($self->path, 'item', @_);
}
sub Tcl::pTk::ttkTreeview::tag {
    my $self = shift;
    $self->call($self->path, 'tag', @_);
}
sub Tcl::pTk::ttkTreeview::cellselection {
    my $self = shift;
    $self->call($self->path, 'cellselection', @_);
}

1;