diff options
Diffstat (limited to 'Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/WidgetDemo.pm')
-rwxr-xr-x | Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/WidgetDemo.pm | 130 |
1 files changed, 130 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/WidgetDemo.pm b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/WidgetDemo.pm new file mode 100755 index 00000000000..61513b657ea --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/Tk/demos/widget_lib/WidgetDemo.pm @@ -0,0 +1,130 @@ +package WidgetDemo; + +use 5.005_03; + +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', q$Revision: #11 $ =~ /\D(\d+)\s*$/; + +use Tk 800.000; +use Carp; + +use Tk; +use Tk::Toplevel; +use strict; +use base 'Tk::Toplevel'; +Construct Tk::Widget 'WidgetDemo'; + +# %WIDGDEMO is a class global that tracks all WidgetDemo composite widgets, +# providing a means of destroying a previous instance of a demonstration. + +my %WIDGDEMO; # class hash of active widget demonstrations + +sub Populate { + my($self, $args) = @_; + + my (%arg_defaults) = ( + -name => 'Unknown Demo Name', + -font => 'Helvetica 12', + -text => 'Unknown Demo Text', + -geometry_manager => 'pack', + ); + my $name = $arg_defaults{-name}; + $arg_defaults{-title} = "$name Demonstration", + $arg_defaults{-iconname} = $name; + + my(@margs, %ahsh, @args); + @margs = grep ! defined $args->{$_}, keys %arg_defaults; + %ahsh = %$args; + @ahsh{@margs} = @arg_defaults{@margs}; + my($demo, $font, $text, $title, $iconname, $gm) = + @ahsh{-name, -font, -text, -title, -iconname, -geometry_manager}; + delete $args->{-name}; + delete $args->{-font}; + delete $args->{-iconname}; + delete $args->{-geometry_manager}; + + $WIDGDEMO{$demo}->destroy if Exists($WIDGDEMO{$demo}); + $WIDGDEMO{$demo} = $self; + + $self->SUPER::Populate($args); + $self->iconname($iconname); + + my(@label_attributes) = (); + if (ref($text) eq 'ARRAY') { + @label_attributes = @$text[1 .. $#{$text}]; + $text = $text->[0]; + } + my $msg = $self->Label( + -font => $font, + -wraplength => '4i', + -justify => 'left', + -text => $text, + @label_attributes, + ); + + my $demo_frame = $self->Frame; + $self->Advertise('WidgetDemo' => $demo_frame); # deprecated + + my $buttons = $self->Frame; + my $dismiss = $buttons->Button( + -text => 'Dismiss', + -command => [$self => 'destroy'], + ); + my $see = $buttons->Button(-text => 'See Code', + -command => [\&main::see_code, $demo]); + + if ($gm eq 'pack') { + $buttons->pack(qw/-side bottom -fill x -pady 2m/); + $dismiss->pack(qw/-side left -expand 1/); + $see->pack(qw/-side left -expand 1/); + $msg->pack; + $demo_frame->pack(qw/-fill both -expand 1 -anchor n/); + } elsif ($gm eq 'grid') { + $msg->grid; + $demo_frame->grid(-sticky => "news"); + $demo_frame->gridColumnconfigure(0,-weight=>1); + $demo_frame->gridRowconfigure(0,-weight=>1); + $self->gridColumnconfigure(qw/0 -weight 1/); + $self->gridRowconfigure(qw/1 -weight 1/); + $buttons->grid(qw/-pady 2m -sticky ew/); + $buttons->gridColumnconfigure(qw/0 -weight 1/); + $buttons->gridColumnconfigure(qw/1 -weight 1/); + $dismiss->grid(qw/-row 0 -column 0/); + $see->grid(qw/-row 0 -column 1/); + } else { + croak "Only pack or grid geometry management supported."; + } + + $self->Delegates('Construct' => $demo_frame); + + $self->ConfigSpecs( + -text => [qw/METHOD text Text NoText/], + ); + + $self->{msg} = $msg; + + return $self; + +} # end Populate + +sub Top {return $_[0]->Subwidget('WidgetDemo')} # deprecated +*top = *top = \&Top; # peacify -w + +sub text { + + my ($self, $text) = @_; + + my(@label_attributes) = (); + if (ref($text) eq 'ARRAY') { + @label_attributes = @$text[1 .. $#{$text}]; + $text = $text->[0]; + } + + $self->{msg}->configure( + -text => $text, + @label_attributes, + ); + +} # end text + +1; |