Using standard Photo methods, it's possible to rotate an image 90 degrees clockwise, 90 degrees counter-clockwise, or flip it 180 degrees.[47]
[47] This algorithm is courtesy of Ryan Casey's img_rotate.tcl script.
Once encapsulated in a module—call it Tk::PhotoRotateSimple—we can showcase its capabilities with this code, the result of which is shown in Figure 17-22.
use Tk; use Tk::PhotoRotateSimple; use subs qw/rotate/; use strict; my $mw = MainWindow->new; my $p = $mw->Photo(-file => Tk->findINC('Xcamel.gif')); rotate 'Original'; rotate 'flip'; rotate 'l90'; rotate 'r90'; MainLoop; sub rotate { my $direction = shift; my $f = $mw->Frame(qw/-width 100 -height 100/)->pack(qw/-side left/); $f->packPropagate(0); $f->Label(-text => $direction)->pack; my $i = $f->Label(-image => $p)->pack(qw/-expand 1 -fill both -anchor c/); return if $direction eq 'Original'; my $tmp = $mw->Photo; $tmp->copy($p); $tmp->rotate_simple($direction); $i->configure(-image => $tmp); }
$p is our friendly camel Photo object. Using it as the original, we call rotate to rotate the image three times: 180 degrees, left 90 degrees, and right 90 degrees. The first call to rotate does no rotation, it just displays the original Photo and returns. The rotate_simple method rotates the actual Photo, so we make a temporary copy in order to preserve the original. Then call rotate_simple with flip, l90, or r90.
So much for the user's point of view; let's see the actual module.
The first thing to note is that we are extending the class Tk::Photo by adding a new method, rotate_simple. The method's basic idea is to create a temporary Photo, extract pixels from the original, stuff them into the temporary Photo appropriately rearranged, then copy the temporary image over the original.
$Tk::PhotoRotateSimple::VERSION = '1.0'; package Tk::Photo; use Carp; use strict; sub rotate_simple { my ($photo, $rot) = @_; carp "Illegal rotation '$rot'." unless $rot =~ /l90|r90|flip/i; my $tmp = $photo->Tk::Widget::image('create', 'photo'); bless $tmp, 'Tk::Photo'; my $width = $photo->width; my $height = $photo->height; if ($rot =~ /l90/i) { for (my $x = 0; $x < $width; $x++) { my $curpix = $photo->data(-from => $x, 0, $x + 1, $height); $curpix = "{$curpix}"; $tmp->put($curpix, -to => 0, $width - $x - 1); } } elsif ($rot =~ /r90/i) { for (my $y = 0; $y < $height; $y++) { my $curpix = $photo->data(-from => 0, $y, $width, $y + 1); $curpix =~ s/^{(.*)}$/$1/; $tmp->put($curpix, -to => $height - $y - 1, 0); } } else { $tmp->copy($photo, -subsample => -1, -1); } $photo->blank; $photo->copy($tmp); $photo->configure(-height => $width, -width => $height) if $rot !~ /flip/i; $photo->idletasks; $tmp->delete; } # end rotate 1;
But there's one subtle gotcha: how to create the temporary Photo when all we've got to work with is a Photo object from the rotate_simple calling sequence. You see, the actual Photo method is a widget method, not a Photo method, so we can't simply say (and have it succeed):
my $tmp = $photo->Photo;
Instead, we do what we've been taught never to do: look inside an opaque object and take advantage of what we glean. In this case, we call image directly and bless the resulting object as a Tk::Photo.
my $tmp = $photo->Tk::Widget::image('create', 'photo'); bless $tmp, 'Tk::Photo';
The alternative is to have another parameter—say, -parent—that the user is required to supply so we have a widget reference. It's certainly safer to do this, if not as pleasing to the eye.
The rest of rotate_simple is straightforward. To rotate l90, grab to the left-most column and put it to the bottom row of the temporary Photo, repeating until all columns are rotated. To rotate r90, grab to the top-most row and put it to the right column of the temporary Photo, repeating until all rows are rotated. flip is the easiest of all, because copy's -subsample option flips automatically if its arguments are negative.
If you were actually looking at the earlier rotation code with the intent of understanding it, you should be wondering what those two regular expressions were all about. They're wrestling with vestigial Tcl semantics—remember most everything in Tcl is a string—so in one case we add curly braces, in the other we subtract curlies. If you're curious, the curlies are like hard quotes in Perl, ensuring that the data is not interpolated.