<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">$Tk::LabFrameFmt::VERSION = 1.0;
package Tk::LabFrameFmt;
use base qw(Tk::LabFrame);
use strict;

Construct Tk::Widget 'LabFrameFmt';

sub ClassInit {
    my ($class, $mw) = @_;
    $class-&gt;Tk::LabFrame::ClassInit($mw);
}

sub Populate {
    my ($w, $args) = @_;
    $w-&gt;Tk::LabFrame::Populate($args);
    $w-&gt;ConfigSpecs(
		    -format =&gt;       [qw/PASSIVE format Format /, "%s"],
		    -undefstring =&gt;  [qw/PASSIVE undefstring UndefString "--"/],
		    -uds =&gt;          '-undefstring',
		    -textvariable =&gt; [qw/PASSIVE textvariable TextVariable/, undef],
		    -formatcmd =&gt;    [qw/CALLBACK formatCmd FormatCmd /, \&amp;FormatCmd],
		    );
}

sub set {
    my ($w, $value) = @_;
    $w-&gt;Tk::LabFrame::Subwidget("label")-&gt;configure(-text =&gt; $w-&gt;Callback(-formatcmd, $w, $value));
}

# The Base calls this routine at the end of any re/configurations.
sub Configured {
    use Tie::Watch;
    my ($w,$args,$changed) = @_;
#    $w-&gt;Tk::LabFrame::Configured($args, $changed);
    if (exists $changed-&gt;{'-textvariable'}) {
	my $vref = $changed-&gt;{'-textvariable'};
	my $st = [ sub {
	    my($watch, $new_val) = @_;
	    my $argv = $watch-&gt;Args('-store');
	    $argv-&gt;[0]-&gt;set($new_val);
	    $watch-&gt;Store($new_val);
	}, $w];
	$w-&gt;{watch} = Tie::Watch-&gt;new(-variable =&gt; $vref, -store=&gt; $st);
	$w-&gt;OnDestroy( [sub {$_[0]-&gt;{watch}-&gt;Unwatch}, $w] );
	$w-&gt;set($$vref); # set the current value too.
    }
    return exists $w-&gt;{'Configure'};
}

sub FormatCmd {
    my ($w, $value) = @_;
    return $w-&gt;cget('-undefstring') if (!defined $value);
    return sprintf($w-&gt;cget('-format'), $value);
}
1;
__END__

=head1 NAME
Tk::LabFrameFmt - Printf style formated labels.

=head1 SYNOPSIS

S&lt;    &gt;I&lt;$lo&gt; = I&lt;$parent&gt;-E&lt;gt&gt;B&lt;LabFrameFmt&gt;(I&lt;-option&gt; =E&lt;gt&gt; I&lt;value&gt;, ... );

=head1 DESCRIPTION

This widget is a standard Lable that contains an optional format string that can be set to 
format a label's textvariable.  Additionally a specific string can be supplied do display on
undef, and a callback can be supplied for more complicated formats.

=over 4

=item B&lt;labeloptions&gt;

LabFrameFmt takes all valid options of Tk::Label;

=item B&lt;-format&gt;

A sprintf style format string that textvariable with be displayed with.

=item B&lt;-undefstring&gt;

The value to display if textvariable is 'undef'.

=item B&lt;-uds&gt;

A alias for -undefstring.

=item B&lt;-formatcmd&gt;

Specifies a callback function to do formatting.  @_ = ($value, -format, -undefstring).

=back

=head1 METHODS

None.

=head1 ADVERTISED WIDGETS

None.

=head1 EXAMPLE

I&lt;$lo&gt; = I&lt;$mw&gt;-E&lt;gt&gt;B&lt;LabFrameFmt&gt;(-format =E&lt;gt&gt; "Errors (%d)",
                                    -undefstring =E&lt;gt&gt; "none",
                                    -textvariable =E&lt;gt&gt; \$numerrors
                                    );

=head AUTHOR

rviosca@imageman.com

This program is free software; you can redistribute it and/or modify it and/ormodify it 
under the same terms as Perl itself.

=head1 SEE ALSO

L&lt;Tk::LabelFmt|Tk::LabelFmt&gt;
L&lt;Tk::LabelTimer|Tk::LabelTimer&gt;
L&lt;Tk::LabelWgs|Tk::LabelWgs&gt;

=cut
</pre></body></html>