home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _a63944ab7390cd3b751df9227d41490a < prev    next >
Encoding:
Text File  |  2004-06-01  |  3.5 KB  |  131 lines
  1. package WidgetDemo;
  2.  
  3. use 5.005_03;
  4.  
  5. use vars qw($VERSION);
  6. $VERSION = sprintf '4.%03d', q$Revision: #11 $ =~ /\D(\d+)\s*$/;
  7.  
  8. use Tk 800.000;
  9. use Carp;
  10.  
  11. use Tk;
  12. use Tk::Toplevel;
  13. use strict;
  14. use base  'Tk::Toplevel';
  15. Construct Tk::Widget 'WidgetDemo';
  16.  
  17. # %WIDGDEMO is a class global that tracks all WidgetDemo composite widgets,
  18. # providing a means of destroying a previous instance of a demonstration.
  19.  
  20. my %WIDGDEMO;            # class hash of active widget demonstrations
  21.  
  22. sub Populate {
  23.     my($self, $args) = @_;
  24.  
  25.     my (%arg_defaults) = (
  26.         -name             => 'Unknown Demo Name',
  27.     -font             => 'Helvetica 12',
  28.     -text             => 'Unknown Demo Text',
  29.     -geometry_manager => 'pack',
  30.     );
  31.     my $name = $arg_defaults{-name};
  32.     $arg_defaults{-title} = "$name Demonstration",
  33.     $arg_defaults{-iconname} = $name;
  34.  
  35.     my(@margs, %ahsh, @args);
  36.     @margs = grep ! defined $args->{$_}, keys %arg_defaults;
  37.     %ahsh = %$args;
  38.     @ahsh{@margs} = @arg_defaults{@margs};
  39.     my($demo, $font, $text, $title, $iconname, $gm) =
  40.     @ahsh{-name, -font, -text, -title, -iconname, -geometry_manager};
  41.     delete $args->{-name};
  42.     delete $args->{-font};
  43.     delete $args->{-iconname};
  44.     delete $args->{-geometry_manager};
  45.  
  46.     $WIDGDEMO{$demo}->destroy if Exists($WIDGDEMO{$demo});
  47.     $WIDGDEMO{$demo} = $self;
  48.  
  49.     $self->SUPER::Populate($args);
  50.     $self->iconname($iconname);
  51.  
  52.     my(@label_attributes) = ();
  53.     if (ref($text) eq 'ARRAY') {
  54.     @label_attributes = @$text[1 .. $#{$text}];
  55.     $text = $text->[0];
  56.     }
  57.     my $msg = $self->Label(
  58.         -font       => $font,
  59.         -wraplength => '4i',
  60.         -justify    => 'left',
  61.         -text       => $text,
  62.         @label_attributes,
  63.     );
  64.  
  65.     my $demo_frame = $self->Frame;
  66.     $self->Advertise('WidgetDemo' => $demo_frame); # deprecated
  67.  
  68.     my $buttons = $self->Frame;
  69.     my $dismiss = $buttons->Button(
  70.         -text    => 'Dismiss',
  71.         -command => [$self => 'destroy'],
  72.     );
  73.     my $see = $buttons->Button(-text => 'See Code',
  74.                    -command => [\&main::see_code, $demo]);
  75.  
  76.     if ($gm eq 'pack') {
  77.     $buttons->pack(qw/-side bottom -fill x -pady 2m/);
  78.     $dismiss->pack(qw/-side left -expand 1/);
  79.     $see->pack(qw/-side left -expand 1/);
  80.     $msg->pack;
  81.     $demo_frame->pack(qw/-fill both -expand 1 -anchor n/);
  82.     } elsif ($gm eq 'grid') {
  83.     $msg->grid;
  84.     $demo_frame->grid(-sticky => "news");
  85.     $demo_frame->gridColumnconfigure(0,-weight=>1);
  86.     $demo_frame->gridRowconfigure(0,-weight=>1);
  87.     $self->gridColumnconfigure(qw/0 -weight 1/);
  88.     $self->gridRowconfigure(qw/1 -weight 1/);
  89.     $buttons->grid(qw/-pady 2m -sticky ew/);
  90.     $buttons->gridColumnconfigure(qw/0 -weight 1/);
  91.     $buttons->gridColumnconfigure(qw/1 -weight 1/);
  92.     $dismiss->grid(qw/-row 0 -column 0/);
  93.     $see->grid(qw/-row 0 -column 1/);
  94.     } else {
  95.     croak "Only pack or grid geometry management supported.";
  96.     }
  97.  
  98.     $self->Delegates('Construct' => $demo_frame);
  99.  
  100.     $self->ConfigSpecs(
  101.         -text => [qw/METHOD text Text NoText/],
  102.     );
  103.  
  104.     $self->{msg} = $msg;
  105.  
  106.     return $self;
  107.  
  108. } # end Populate
  109.  
  110. sub Top {return $_[0]->Subwidget('WidgetDemo')}    # deprecated
  111. *top = *top = \&Top;  # peacify -w
  112.  
  113. sub text {
  114.  
  115.     my ($self, $text) = @_;
  116.  
  117.     my(@label_attributes) = ();
  118.     if (ref($text) eq 'ARRAY') {
  119.     @label_attributes = @$text[1 .. $#{$text}];
  120.     $text = $text->[0];
  121.     }
  122.  
  123.     $self->{msg}->configure(
  124.         -text       => $text,
  125.         @label_attributes,
  126.     );
  127.  
  128. } # end text
  129.  
  130. 1;
  131.