/usr/share/doc/libgtk2-perl-doc/examples/colorsel.pl is in libgtk2-perl-doc 2:1.2499-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
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 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 | #!/usr/bin/perl -w
#
# Color Selector
#
# GtkColorSelection lets the user choose a color. GtkColorSelectionDialog is
# a prebuilt dialog containing a GtkColorSelection.
#
#
package colorsel;
use Glib qw(TRUE FALSE);
use Gtk2;
my $window = undef;
my $da;
my $color;
sub change_color_callback {
my $button = shift;
my $dialog = Gtk2::ColorSelectionDialog->new ("Changing color");
$dialog->set_transient_for ($window);
my $colorsel = $dialog->colorsel;
$colorsel->set_previous_color ($color);
$colorsel->set_current_color ($color);
$colorsel->set_has_palette (TRUE);
my $response = $dialog->run;
if ($response eq 'ok') {
$color = $colorsel->get_current_color;
$da->modify_bg ('normal', $color);
}
$dialog->destroy;
}
sub do {
if (!$window) {
$color = Gtk2::Gdk::Color->new (0, 65535, 0);
$window = Gtk2::Window->new;
$window->set_title ("Color Selection");
$window->signal_connect (destroy => sub { $window = undef });
$window->set_border_width (8);
my $vbox = Gtk2::VBox->new (FALSE, 8);
$vbox->set_border_width (8);
$window->add ($vbox);
#
# Create the color swatch area
#
my $frame = Gtk2::Frame->new;
$frame->set_shadow_type ('in');
$vbox->pack_start ($frame, TRUE, TRUE, 0);
$da = Gtk2::DrawingArea->new;
# set a minimum size
$da->set_size_request (200, 200);
# set the color
$da->modify_bg ('normal', $color);
$frame->add ($da);
my $alignment = Gtk2::Alignment->new (1.0, 0.5, 0.0, 0.0);
my $button = Gtk2::Button->new_with_mnemonic ("_Change the above color");
$alignment->add ($button);
$vbox->pack_start ($alignment, FALSE, FALSE, 0);
$button->signal_connect (clicked => \&change_color_callback);
}
if (!$window->visible) {
$window->show_all;
} else {
$window->destroy;
$window = undef;
}
return $window;
}
1;
__END__
Copyright (C) 2003 by the gtk2-perl team (see the file AUTHORS for the
full list)
This library is free software; you can redistribute it and/or modify it under
the terms of the GNU Library General Public License as published by the Free
Software Foundation; either version 2.1 of the License, or (at your option) any
later version.
This library is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
PARTICULAR PURPOSE. See the GNU Library General Public License for more
details.
You should have received a copy of the GNU Library General Public License along
with this library; if not, write to the Free Software Foundation, Inc., 59
Temple Place - Suite 330, Boston, MA 02111-1307 USA.
|