You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
95 lines
1.8 KiB
95 lines
1.8 KiB
package Tk::ColorChoice; |
|
|
|
use Tk; |
|
use Tk::Font; |
|
use base 'Tk::Toplevel'; |
|
|
|
use strict; |
|
use warnings; |
|
|
|
Construct Tk::Widget 'ColorChoice'; |
|
|
|
sub ClassInit |
|
{ |
|
my ($class, $mw) = @_; |
|
$class->SUPER::ClassInit($mw); |
|
} |
|
|
|
sub Populate |
|
{ |
|
my ($self, $args) = @_; |
|
$self->SUPER::Populate($args); |
|
|
|
$self->after(10, [$self, "init"]); |
|
|
|
} |
|
package Tk::ColorChoice; |
|
|
|
use Tk; |
|
use Tk::Font; |
|
use base 'Tk::Toplevel'; |
|
|
|
use strict; |
|
use warnings; |
|
|
|
Construct Tk::Widget 'ColorChoice'; |
|
|
|
sub ClassInit |
|
{ |
|
my ($class, $mw) = @_; |
|
$class->SUPER::ClassInit($mw); |
|
} |
|
|
|
sub Populate |
|
{ |
|
my ($self, $args) = @_; |
|
$self->SUPER::Populate($args); |
|
|
|
$self->after(10, [$self, "init"]); |
|
|
|
} |
|
|
|
sub init |
|
{ |
|
my ($self) = @_; |
|
|
|
my (@colors) = qw(red pink purple blue green yellow orange red brown |
|
black white); |
|
|
|
while(@colors) |
|
{ |
|
my @currow; |
|
while(@colors and @currow < 4) |
|
{ |
|
my $color = shift @colors; |
|
push @currow, $self->Button(-background => $color, -activebackground => |
|
$color, -text => ' '); |
|
} |
|
last unless @currow; |
|
(shift @currow)->grid(@currow); |
|
} |
|
} |
|
|
|
1; |
|
sub init |
|
{ |
|
my ($self) = @_; |
|
|
|
my (@colors) = qw(red pink purple blue green yellow orange red brown |
|
black white); |
|
|
|
while(@colors) |
|
{ |
|
my @currow; |
|
while(@colors and @currow < 4) |
|
{ |
|
my $color = shift @colors; |
|
push @currow, $self->Button(-background => $color, -activebackground => |
|
$color, -text => ' '); |
|
} |
|
last unless @currow; |
|
(shift @currow)->grid(@currow); |
|
} |
|
} |
|
|
|
1;
|
|
|