1#!/usr/bin/perl 2 3=pod 4 5GdkPixbuf is a client-side image data object; in C you just deal with 24-bit 6RGB or 32-bit RGBA image data, but in Perl such things are a little difficult. 7 8This code shows how to find pixels within a GdkPixbuf, as well as how to 9create new GdkCursors. 10 11 -- muppet, 3 March 04 12 13=cut 14 15use strict; 16use warnings; 17use Glib qw(FALSE TRUE); 18use Gtk2 -init; 19 20die "Usage: $0 imagefile\n" unless @ARGV; 21my $pixbuf = Gtk2::Gdk::Pixbuf->new_from_file ($ARGV[0]); 22# grab this now, so we only keep one copy of it. 23my $pixels = $pixbuf->get_pixels; 24 25# create a bunch of widgets... 26my $window = Gtk2::Window->new; 27my $hbox = Gtk2::HBox->new; 28my $ebox = Gtk2::EventBox->new; 29my $align = Gtk2::Alignment->new (0.5, 0.5, 0.0, 0.0); 30my $image = Gtk2::Image->new_from_pixbuf ($pixbuf); 31my $frame = Gtk2::Frame->new ('Color'); 32my $vbox = Gtk2::VBox->new; 33my $label = Gtk2::Label->new; 34my $darea = Gtk2::DrawingArea->new; 35 36# lay 'em out... 37$window->add ($hbox); 38$ebox->add ($image); 39$align->add ($ebox); 40$hbox->add ($align); 41$hbox->pack_start ($frame, FALSE, FALSE, 0); 42$frame->add ($vbox); 43$vbox->pack_start ($label, FALSE, FALSE, 0); 44$vbox->pack_start ($darea, FALSE, FALSE, 0); 45 46# hook 'em up... 47$window->set_title ("Color Snooper"); 48$window->show_all; 49$window->signal_connect (delete_event => sub {Gtk2->main_quit;}); 50 51$darea->set_size_request (64, 64); 52 53$ebox->window->set_cursor (create_cursor()); 54$ebox->add_events (['pointer-motion-mask', 'pointer-motion-hint-mask']); 55$ebox->signal_connect (motion_notify_event => sub { 56 my ($widget, $event) = @_; 57 # this is so we keep getting pointer events. 58 $widget->window->get_pointer; 59 # the Gtk2::Image is a no-window widget; translate its coords. 60 # it should be packed tightly in the event box, thanks to the 61 # alignment, but this is for paranoia's sake. 62 my ($x, $y) = $widget->translate_coordinates ($image, 63 $event->x, $event->y); 64 65 # the image data is packed RGB or RGBA data. if we can calculate 66 # the location of our pixel-of-interest, then we can use substr 67 # and unpack to get to its values. 68 my ($r, $g, $b, $a) = 69 unpack "C*", 70 substr $pixels, 71 $pixbuf->get_rowstride * $y 72 + $pixbuf->get_n_channels * $x, 73 $pixbuf->get_n_channels; 74 $label->set_text ("x,y: ".$event->x.", ".$event->y."\n" 75 ."R: $r\n" 76 ."G: $g\n" 77 ."B: $b" 78 .($pixbuf->get_has_alpha ? "\nA: $a" : "")); 79 80 # GdkColors use 16-bit color values, but GdkPixbufs use 8-bit. 81 # note the bitshifts to account for that. 82 my $color = Gtk2::Gdk::Color->new ($r << 8, $g << 8, $b << 8); 83 84 $darea->modify_bg ('normal', $color); 85 $darea->queue_draw; 86}); 87 88 89# and go. 90Gtk2->main; 91 92 93sub create_cursor { 94 # these icons borrowed from the gimp. 95 use constant width => 32; 96 use constant height => 32; 97 use constant x_hot => 13; # the tip of the dropper, coords 98 use constant y_hot => 30; # picked out by hand. 99 my $dropper_small_bits = pack 'C*', 100 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 101 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 102 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 103 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 104 0x00, 0x00, 0x00, 0x1c, 0x00, 0x00, 0x00, 0x22, 0x00, 0x00, 0x00, 0x41, 105 0x00, 0x00, 0xc0, 0xa1, 0x00, 0x00, 0x20, 0xbc, 0x00, 0x00, 0x40, 0xbb, 106 0x00, 0x00, 0x80, 0x44, 0x00, 0x00, 0x40, 0x34, 0x00, 0x00, 0x20, 0x13, 107 0x00, 0x00, 0x90, 0x15, 0x00, 0x00, 0xc8, 0x00, 0x00, 0x00, 0x64, 0x00, 108 0x00, 0x00, 0x32, 0x00, 0x00, 0x00, 0x19, 0x00, 0x00, 0x80, 0x0c, 0x00, 109 0x00, 0x40, 0x06, 0x00, 0x00, 0x40, 0x03, 0x00, 0x00, 0xe0, 0x01, 0x00, 110 0x00, 0x20, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00; 111 my $dropper_small_mask_bits = pack 'C*', 112 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 113 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 114 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 115 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 116 0x00, 0x00, 0x00, 0x1c, 0x00, 0x00, 0x00, 0x3e, 0x00, 0x00, 0x00, 0x7f, 117 0x00, 0x00, 0xc0, 0xff, 0x00, 0x00, 0xe0, 0xff, 0x00, 0x00, 0xc0, 0xff, 118 0x00, 0x00, 0xc0, 0x7f, 0x00, 0x00, 0xe0, 0x3f, 0x00, 0x00, 0xf0, 0x1f, 119 0x00, 0x00, 0xf8, 0x1f, 0x00, 0x00, 0xfc, 0x01, 0x00, 0x00, 0xfe, 0x00, 120 0x00, 0x00, 0x7f, 0x00, 0x00, 0x80, 0x3f, 0x00, 0x00, 0xc0, 0x1f, 0x00, 121 0x00, 0xe0, 0x0f, 0x00, 0x00, 0xe0, 0x07, 0x00, 0x00, 0xf0, 0x03, 0x00, 122 0x00, 0xe0, 0x01, 0x00, 0x00, 0x40, 0x00, 0x00; 123 124 my $icon = Gtk2::Gdk::Bitmap->create_from_data 125 (undef, $dropper_small_bits, width, height); 126 my $mask = Gtk2::Gdk::Bitmap->create_from_data 127 (undef, $dropper_small_mask_bits, width, height); 128 return Gtk2::Gdk::Cursor->new_from_pixmap 129 ($icon, $mask, 130 Gtk2::Gdk::Color->new (0, 0, 0), 131 Gtk2::Gdk::Color->new (65535, 65535, 65535), 132 x_hot, y_hot); 133} 134