summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Tk/demos/widget_lib/WidgetDemo.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Tk/demos/widget_lib/WidgetDemo.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/demos/widget_lib/WidgetDemo.pm130
1 files changed, 130 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/Tk/demos/widget_lib/WidgetDemo.pm b/Master/tlpkg/tlperl/lib/Tk/demos/widget_lib/WidgetDemo.pm
new file mode 100644
index 00000000000..a05d1ace927
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/demos/widget_lib/WidgetDemo.pm
@@ -0,0 +1,130 @@
+package WidgetDemo;
+
+use 5.005_03;
+
+use vars qw($VERSION);
+$VERSION = '4.012'; # 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;