summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Tk/ColorDialog.pm
blob: 7b62eeca35606aefb446a202c9fafc4bd33b1242 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
package Tk::ColorDialog;
require Tk::Toplevel;
use base  qw(Tk::Toplevel);

use vars qw($VERSION);
$VERSION = '4.014';

Construct Tk::Widget 'ColorDialog';

sub Accept
{
 my $cw  = shift;
 $cw->withdraw;
 $cw->{'done'} = 1;
}

sub Cancel
{
 my $cw  = shift;
# $cw->configure(-color => undef);
 $cw->configure(-color => 'cancel');
 $cw->Accept;
}

sub Populate
{
 my ($cw,$args) = @_;
 $cw->SUPER::Populate($args);
 $cw->protocol('WM_DELETE_WINDOW' => [ 'Cancel' => $cw ]);
 $cw->transient($cw->Parent->toplevel);
 $cw->withdraw;
 my $sel = $cw->ColorSelect;
 my $accept = $cw->Button(-text => 'Accept', -command => ['Accept', $cw]);
 my $cancel = $cw->Button(-text => 'Cancel', -command => ['Cancel', $cw]);
 Tk::grid($sel);
 Tk::grid($accept,$cancel);
 $cw->ConfigSpecs(DEFAULT => [$sel]);
}

sub Show
{
 my $cw = shift;
 $cw->configure(@_) if @_;
 $cw->Popup();
 $cw->OnDestroy(sub { $cw->{'done'} = 0 }); # auto-cancel
 $cw->waitVariable(\$cw->{'done'});
 if (Tk::Exists($cw))
  {
   $cw->withdraw;
   $cw->cget('-color');
  }
 else
  {
   undef;
  }
}

1;