my $label = $frame->Label('Name' => 'title',
-text => 'Tk Names Tutorial');
my $dialog = $top->DialogBox(-title => 'Generated Names',
-buttons => [ 'OK' ]);
my $page = $notebook->add('Bill', -label => 'Billing');
####
my $title = $frame->direct_descendant('title');
my $button = $dialog->direct_descendant('bottom.button');
my $bill = $notebook->direct_descendant('Bill');
####
my $title = $top->descendant('*title');
my $mnuTerms = $notebook->descendant('*Bill*terms');
####
print join("\n", $notebook->list_descendant_names()), "\n";
print $mnuTerms->full_name(), "\n";
####
# Save this code to a file called MyTkUtils.pm.
# Then from your main script, add "use MyTkUtils".
package Tk::Widget;
use strict;
sub full_name {
my($w) = @_;
my @name = ( );
while (ref $w) {
unshift @name, $w->name;
$w = $w->parent;
}
join('.', @name);
}
sub direct_descendant {
my ($w, $path) = @_;
return unless ($w && defined $path);
my @path = split(/[,.]/, $path);
my @children = $w->children;
if (@path) {
while (@children) {
my $child = pop @children;
if ($child->name eq $path[0]) {
shift @path;
return $child if (!@path);
$w = $child;
@children = $w->children;
}
}
}
}
sub _r_list_descendant_names {
my ($w, $w_name, $separator, $descendants) = @_;
foreach my $child ($w->children) {
my $child_name = $w_name . $separator . $child->name;
push @{$descendants}, $child_name;
_r_list_descendant_names($child, $child_name, $separator, $descendants);
}
}
sub list_descendant_names {
my ($w, $separator) = @_;
$separator ||= '.';
my @descendants = ( );
foreach my $child ($w->children) {
my $child_name = $child->name;
push @descendants, $child_name;
_r_list_descendant_names($child, $child_name, $separator, \@descendants);
}
@descendants;
}
sub descendant {
my ($w, $path) = @_;
my @names = ( );
$path =~ s|\.|,|g;
if ($path =~ m|\*|) {
$path =~ s|\*+|,(\\w+,)*|g;
$path =~ s|-|_|g;
$path =~ s|,+|,|g;
$path =~ s|^,||;
$path =~ s|,$||;
@names = grep(/^$path$/, list_descendant_names($w, ','));
}
else {
$path =~ s|-|_|g;
$path =~ s|,+|,|g;
$path =~ s|^,||;
$path =~ s|,$||;
@names = ( $path );
}
if (!wantarray) {
return direct_descendant($w, $names[0]);
}
else {
my @widgets = ( );
foreach (@names) {
my $widget = direct_descendant($w, $_);
push @widgets, $widget if (ref $widget);
}
return @widgets;
}
}
sub ancestor {
my ($w, $name) = @_;
while (ref $w) {
return $w if ($w->name eq $name);
$w = $w->parent;
}
}
1;