ShowColorsets - missing attachment.

[Scott Smedley]

#!/usr/bin/perl -w

# $Id$

use strict;
use lib `fvwm-perllib dir`;
use FVWM::Module::Tk;
use FVWM::Module::Toolkit qw(X11::Protocol Tk Tk::LabFrame);

use constant FIELDS => qw(fg bg hilite shadow fgsh pixmap);

my $main = new MainWindow();
my $x = X11::Protocol->new($main->screen());
$x->event_handler('queue');

my $module = new FVWM::Module::Tk($main, Name => 'ShowColorsets', Debug => 2);
my $tracker = $module->track('Colorsets');

sub nColorsets ()
{
        # Colorsets should be numbered sequentially starting from zero, 
otherwise
        # this logic won't work.
        return scalar(keys(%{$tracker->{data}}));
}

my $nC = $main->Label()->pack(-side => 'top');
my $f = $main->Frame()->pack(-side => 'top');
my $l = $f->Label()->pack(-side => 'left');
my %global;
foreach (FIELDS)
{
        my $lf = $f->LabFrame(-label => $_,
                                                  -labelside => 
'acrosstop')->pack(-side => 'left');
        $global{colorset}{$_}{frame} = $lf->Frame(-width => 64, -height => 
64)->pack();
        $global{colorset}{$_}{frameId} = 
hex($global{colorset}{$_}{frame}->id());
        my $type = ($_ eq 'pixmap' ? 'background_pixmap' : 'background_pixel');
        $global{colorset}{$_}{type} = $type;
}

sub showNColorsets ()
{
        $nC->configure(-text => "There are " . nColorsets() . " Colorsets.");
}
showNColorsets();

sub showColorset ($)
{
        my ($n) = @_;

        $global{showCS} = $n;
        my $pConfig = $tracker->data($n);
        $module->debug("showColorset($n): " . join(", ", map("$_ = 
$pConfig->{$_}", keys(%{$pConfig}))));
        $l->configure(-text => "Colorset $n:");
        foreach (FIELDS)
        {
                redraw($global{colorset}{$_}{frameId}, $_, $n);
        }
}

$tracker->observe("main", sub {
        my ($module, $tracker, $z, $nn, $p) = @_;
        showColorset($nn) if ($nn == $global{showCS});
        showNColorsets();
});


my @p = (-side => 'left', -expand => 1, -fill => 'x');
$main->Button(-text => '<', -command => sub { showColorset(($global{showCS} - 
1) % nColorsets()); })->pack(@p);
$main->Button(-text => '>', -command => sub { showColorset(($global{showCS} + 
1) % nColorsets()); })->pack(@p);
$main->Button(-text => 'Refresh', -command => sub { 
showColorset($global{showCS}); })->pack(@p);
$main->Button(-text => 'Quit', -command => sub{exit})->pack(@p);

sub redraw ($$$)
{
        my ($winId, $field, $n) = @_;
        $global{colorset}{$field}{frame}->configure(-bg => $f->cget(-bg));
        $x->ChangeWindowAttributes($winId, $global{colorset}{$field}{type} => 
$tracker->data($n)->{$field});
        $x->req('ClearArea', $winId, (0, 0), 200, 200, 0);
}

sub eventHandler
{
        my (%event) = @_;

        # $module->debug("Got a $event{name} event for window $event{window}.");
        # print("Got a $event{name} event: " . join(", ", map("$_ = 
$event{$_}", keys(%event))) . "\n");
        if ($event{name} eq 'ConfigureNotify' ||
                $event{name} eq 'Expose')
        {
                foreach (FIELDS)
                {
                        if ($global{colorset}{$_}{frameId} == $event{window})
                        {
                                redraw($event{window}, $_, $global{showCS});
                                last;
                        }
                }
        }
}

sub XSync ()
{
    $x->req('InternAtom', "WM_NAME", 0);
}

sub callback
{
        XSync();
        while (1)
    {
        my %event = $x->dequeue_event();
        last if (!exists($event{name}));
        eventHandler(%event);
    }
}
$main->repeat(200, \&callback);

sub initialise ()
{
        $module->debug("Running initialise().");
        $main->waitVisibility();
        foreach (FIELDS)
        {
                $x->ChangeWindowAttributes($global{colorset}{$_}{frameId},
                        event_mask => $x->pack_event_mask('Exposure', 
'StructureNotify'));
        }
        showColorset(0);
}
$main->after(1, \&initialise);

$module->eventLoop();