File Coverage

blib/lib/Tk/Canvas/Draw.pm
Criterion Covered Total %
statement 10 12 83.3
branch n/a
condition n/a
subroutine 4 4 100.0
pod n/a
total 14 16 87.5


line stmt bran cond sub pod time code
1              
2             package Tk::Canvas::Draw;
3              
4             our $VERSION = '0.06';
5              
6             =head1 NAME
7              
8             Tk::Canvas::Draw - Simplifies drawing with a mouse in a perl/Tk Canvas
9              
10             =head1 SYNOPSIS
11              
12             use Tk::Canvas::Draw;
13              
14             Tk::Canvas::Draw->new($canvas, \&final_callback, $h_args);
15              
16             =head1 DESCRIPTION
17              
18             This module simplifies the drawing of perl/Tk shapes in a Canvas, using
19             a mouse. Once the first event is detected for the given mouse
20             button N, and in the specified Canvas, the Motion and ButtonRelease events
21             are bound to the same mouse button and Canvas. All subsequent points are
22             captured until the final ButtonRelease event occurs. Finally, any previous
23             set bindings for the Canvas and mouse button are reinstated, and the
24             registered callback is invoked to handle any necessary final processing.
25              
26             =head1 VERSION
27              
28             Version 0.06
29              
30             =head1 CONSTRUCTOR
31              
32             =head2 new
33              
34             Required parameters:
35              
36             =over 4
37              
38             =item $canvas
39              
40             The Tk::Canvas object where the mouse events will be captured.
41              
42             =item \&final_callback
43              
44             A callback to invoked when the event occurs. The argument
45             is required, but may be a non-blank string (eg. 'none') if the user is
46             certain that no final processing is necessary.
47             (See the section FINAL CALLBACK below)
48              
49             =item $h_args
50              
51             An optional reference to a hash containing any of the following arguments:
52              
53             =over 4
54              
55             =item 'style'
56              
57             The style of drawing to be done. Must be one of:
58              
59             =over 4
60              
61             =item 'none'
62              
63             Does not draw anything, just collects the (x,y) points generated by
64             moving the mouse over the canvas.
65              
66             =item 'free'
67              
68             Joins all points drawn to create freehand lines (this is the default).
69              
70             =item 'line'
71              
72             Joins the first point with the most recent point, to create a straight line.
73              
74             =item 'oval'
75              
76             Joins the first point with the most recent point to create an oval.
77              
78             =item 'circle'
79              
80             Joins the first point with the most recent point to create a circle.
81              
82             =item 'rectangle'
83              
84             Joins the first point with the most recent point to create a rectangle.
85              
86             =item 'mouse'
87              
88             The mouse button to bind the drawing to; one of {'1', '2' or '3'}.
89             The default is '1'.
90              
91             =back
92              
93             =item 'color'
94              
95             The color of the object being drawn. (Do not confuse this with the
96             'fill' argument). The default color is 'black'.
97              
98             =item 'fill'
99              
100             The color with which to fill the drawn shape (does not apply to styles
101             'free' or 'line'). The default fill is '0' (ie. no fill).
102              
103             =item 'width'
104              
105             The width of the shape being draw. In the case of lines (style 'free'
106             or 'line'), this referes to the line width; in all other shapes it is
107             the width of the shape's outline. The default width is '1'.
108              
109             =item 'action'
110              
111             A callback to invoke each time a new point is detected. It will be passed
112             a reference to an array containing the most recent (x, y) point detected,
113             eg. [ 123, 45 ].
114              
115             =back
116              
117             =back
118              
119             =head1 FINAL CALLBACK
120              
121             The final callback parameter names a subroutine to be invoked
122             when the mouse button is released. This subroutine is passed the
123             following 3 arguments:
124              
125             =over 4
126              
127             $o_obj -- The Tk::Canvas::Draw object
128              
129             $a_points -- A reference to an array containing the captured coordinate
130             points, each of which is an array reference in the form [ x, y ]
131              
132             $a_ids -- A reference to an array containing the ID(s) of the drawn shape
133              
134             =back
135              
136             =head1 METHODS
137              
138             =head2 restart($obj, $h_args)
139              
140             =over 4
141              
142             Lets the user reuse the Tk::Canvas::Draw object, optionally resetting any
143             of the same arguments as allowed to the new() method. This method takes
144             the following 2 arguments:
145              
146             =over 4
147              
148             $obj
149              
150             =over 4
151              
152             The Tk::Canvas::Draw object
153              
154             =back
155              
156             $h_args
157              
158             =over 4
159              
160             An optional hash, with the same values as allowed in the I
161             constructor. (See the I<$h_args> parameter in the REQUIRED PARAMETERS
162             section above)
163              
164             =back
165              
166             =back
167              
168             =back
169              
170             =head2 transform($obj, $a_points, $xoff, $yoff, $canvas)
171              
172             =over 4
173              
174             Allows the recreation of the shape given by the points in $a_points to
175             an alternate location in the canvas (or in a separate canvas), and returns
176             the ID(s) associated with the new shape. The following arguments are
177             required:
178              
179             =over 4
180              
181             $obj
182              
183             =over 4
184              
185             The Tk::Canvas::Draw object. The following accessor methods allow retrieval
186             of the corresponding member data:
187              
188             =over 4
189              
190             $obj->canvas
191             $obj->mouse
192             $obj->color
193             $obj->fill
194             $obj->width
195             $obj->style
196              
197             =back
198              
199             =back
200              
201             $a_points
202              
203             =over 4
204              
205             A reference to an array containing the (x, y) points generated by an
206             initial call to Tk::Canvas::Draw::new. For example:
207              
208             [ [10, 25], [12, 27], [13, 29], ... ]
209              
210             =back
211              
212             $xoff
213              
214             =over 4
215              
216             The x-offset by which to vary the new shape from the original
217              
218             =back
219              
220             $yoff
221              
222             =over 4
223              
224             The y-offset by which to vary the new shape from the original
225              
226             =back
227              
228             $canvas
229              
230             =over 4
231              
232             An optional Canvas on which to draw the new shape (it defaults to the
233             current Canvas used by $obj)
234              
235             =back
236              
237             =back
238              
239             =back
240              
241             =head1 EXAMPLE 1
242              
243             #!/usr/bin/perl -w
244             #
245             # Here's a quick example to stimulate your immediate excitement.
246             # The following program 'doodle' lets you draw colorful, freehand lines
247             # in a Tk Canvas!
248             ##
249              
250             use strict;
251             use warnings;
252             use Tk;
253             use Tk::Canvas::Draw;
254              
255             my $help = qq[
256             Click and move the mouse anywhere in the white box to begin drawing.
257             Type 'Escape' to clear everything.
258             ];
259              
260             my $a_all_ids = [ ];
261              
262             my $mw = new MainWindow(-title => 'Doodle -- Tk::Canvas::Draw example');
263             my $cv = $mw->Canvas(-bg => 'white', -width => 512, -height => 512)->pack;
264             $cv->createText(0, 0, -anch => 'nw', -text => $help);
265             Tk::Canvas::Draw->new($cv, \&done_drawing, { width => 5 });
266             $mw->bind("" => sub { map { $cv->delete($_) } @$a_all_ids });
267             MainLoop;
268              
269             # Tk::Canvas::Draw callback -- reinstall callback with a new, random color
270             sub done_drawing {
271             my ($o_obj, $a_points, $a_ids) = @_;
272             push @$a_all_ids, @$a_ids;
273             my $color = sprintf "#%02x%02x%02x", rand(256), rand(256), rand(256);
274             $o_obj->restart( { color => $color });
275             }
276              
277              
278             =head1 EXAMPLE 2
279              
280             #!/usr/bin/perl -w
281             #
282             # Another very simple example of Tk::Canvas::Draw, this time using
283             # each of the various allowable styles.
284             ##
285              
286             use strict;
287             use warnings;
288             use Tk;
289             use Tk::Canvas::Draw;
290              
291             my $a_style = [qw[ free line oval circle rectangle ]];
292             my $a_color = [qw[ black red blue purple orange ]];
293             my $stylenum = 0;
294             my $colornum = 0;
295              
296             my $mw = new MainWindow(-title => 'Tk::Canvas::Draw example');
297             my $cv = $mw->Canvas(-width => 512, -height => 512)->pack;
298             Tk::Canvas::Draw->new($cv, \&done, { width => 5, fill => 'white' });
299             MainLoop;
300              
301             # Tk::Canvas::Draw final callback - change style, reinstall callback
302             sub done {
303             my ($o_obj, $a_points, $a_ids) = @_;
304             my $style = $a_style->[++$stylenum % @$a_style];
305             my $color = $a_color->[++$colornum % @$a_color];
306             $o_obj->restart( { style => $style, color => $color });
307             }
308              
309              
310             =head1 EXAMPLE 3
311              
312             #!/usr/bin/perl -w
313             #
314             # A more complicated example of Tk::Canvas::Draw, this program gives
315             # the user more flexibility in choosing options to the constructor
316             # (although the color and width are randomized). It also demonstrates
317             # how to use the -action => \&callback argument, to track points while
318             # they are drawn, as well as showing the transform() method which can
319             # be used to make copies of the drawn object.
320             ##
321              
322             use strict;
323             use warnings;
324             use Tk;
325             use Tk::Canvas::Draw;
326              
327             #############
328             ## Globals ##
329             #############
330             my $a_styles = [qw[ free line oval circle rectangle ]];
331             my $a_font = [qw[ tahoma 12 ]];
332             my @all_id1 = ( );
333             my @all_id2 = ( );
334             my $b_fill = 0;
335             my $lastxy = "";
336             my $style;
337              
338             ##################
339             ## Main program ##
340             ##################
341             my $mw = new MainWindow(-title => 'Tk::Canvas::Draw example');
342             my $f1 = $mw->Frame()->pack(-fill => 'x');
343             my $f2 = $mw->Frame()->pack(-fill => 'both');
344             my $c1 = $f2->Canvas(-wi => 512,-he => 512, -bg => 'white');
345             my $c2 = $f2->Canvas(-wi => 512,-he => 512, -bg => '#ffffdf');
346             $c1->pack($c2, -side => 'left');
347              
348             button($f1, '>Quit (^Q)', sub { exit }, 'Control-q');
349             button($f1, '
350             button($f1, '
351              
352             choose_style($f1);
353             choose_fill($f1);
354             last_point($f1);
355             start_drawing($c1);
356             MainLoop;
357              
358             #################
359             ## Subroutines ##
360             #################
361             sub button {
362             my ($w, $text, $c_cmd, $bind) = @_;
363             my $side = ($text =~ s/^([<>])//)? $1: '<';
364             my $bt = $w->Button(-bg => '#ffafef', -text => $text);
365             $bt->configure(-comm => $c_cmd, -font => $a_font);
366             if ($bind || 0) {
367             $w->toplevel->bind("<$bind>" => sub { $bt->invoke });
368             }
369             $bt->pack(-side => ($side eq '<')? 'left': 'right');
370             }
371              
372             sub random_color {
373             sprintf "#%02x%02x%02x", rand(256), rand(256), rand(256);
374             }
375              
376             sub clear_last {
377             my $a_id1 = pop @all_id1;
378             my $a_id2 = pop @all_id2;
379             map { $c1->delete($_) } @$a_id1;
380             map { $c2->delete($_) } @$a_id2;
381             }
382              
383             sub clear_all {
384             while (@all_id1 > 0) {
385             clear_last();
386             }
387             }
388              
389             sub labeled_frame {
390             my ($w, $text) = @_;
391             my $fr = $w->Frame(-relief => 'ridge', -borderwidth => 4);
392             my $lb = $fr->Label(-text => $text, -font => $a_font);
393             $fr->pack(-side => 'left');
394             $lb->pack(-side => 'left');
395             return $fr;
396             }
397              
398             sub choose_style {
399             my ($w) = @_;
400             my $fr = labeled_frame($w, "Style");
401             my @args = (
402             -bg => '#7fcfff',
403             -variable => \$style,
404             -command => \&start_drawing,
405             -font => $a_font,
406             );
407             my $opt = $fr->Optionmenu(@args);
408             map { $opt->addOptions($_) } @$a_styles;
409             $style = 'free';
410             $opt->pack(-side => 'left');
411             }
412              
413             sub choose_fill {
414             my ($w) = @_;
415             my $fr = labeled_frame($w, "Fill Shapes");
416             my $a_comm = [
417             -font => $a_font,
418             -variable => \$b_fill,
419             -command => \&start_drawing,
420             ];
421             my $a_no = [ -text => "No", -value => 0 ];
422             my $a_yes = [ -text => "Yes", -value => 1 ];
423             my $r_no = $fr->Radiobutton(@$a_no, @$a_comm);
424             my $r_yes = $fr->Radiobutton(@$a_yes, @$a_comm);
425             $r_no->pack($r_yes, -side => 'left');
426             }
427              
428             sub last_point {
429             my ($w) = @_;
430             my $fr = labeled_frame($w, "Last Point");
431             my $lbl = $fr->Label(-textvar => \$lastxy, -font => $a_font);
432             $lbl->pack(-side => 'left');
433             }
434              
435             #==============================#
436             ## Tk::Canvas::Draw interface ##
437             #==============================#
438             sub start_drawing {
439             my $width = int(1 + rand(32));
440             my $color = random_color();
441             my $fill = $b_fill? random_color: 0;
442              
443             my $h_opts = {
444             'width' => $width,
445             'color' => $color,
446             'fill' => $fill,
447             'style' => $style,
448             'action' => \&show_last,
449             };
450              
451             new Tk::Canvas::Draw($c1, \&done_drawing, $h_opts);
452             }
453              
454             sub show_last {
455             my ($a_point) = @_;
456             my ($x, $y) = @$a_point;
457             $lastxy = sprintf "($x, $y)";
458             }
459              
460             sub done_drawing {
461             my ($o_obj, $a_pts, $a_ids) = @_;
462             push @all_id1, $a_ids;
463             push @all_id2, Tk::Canvas::Draw::transform($o_obj, $a_pts, 0, 0, $c2);
464             start_drawing();
465             }
466            
467              
468             =head1 AUTHOR
469              
470             John C. Norton
471              
472             =head1 COPYRIGHT & LICENSE
473              
474             Copyright 2009-2010 John C. Norton.
475              
476             This program is free software; you can redistribute it and/or modify it
477             under the terms of either: the GNU General Public License as published
478             by the Free Software Foundation; or the Artistic License.
479              
480             See http://dev.perl.org/licenses/ for more information.
481              
482             =cut
483              
484             ###############
485             ## Libraries ##
486             ###############
487 1     1   22416 use strict;
  1         2  
  1         25  
488 1     1   5 use warnings;
  1         2  
  1         26  
489 1     1   5 use Carp;
  1         6  
  1         64  
490 1     1   564 use Tk;
  0            
  0            
491              
492              
493             #############
494             ## Globals ##
495             #############
496             my $b_drawing = 0; # Disallow multiple simultaneous invocations
497              
498             my $h_defaults = {
499             'mouse' => 1,
500             'color' => 'black',
501             'fill' => 0,
502             'width' => 1,
503             'action' => 0,
504             'style' => 'free',
505             };
506              
507             my $h_aliases = {
508             'a' => 'action',
509             'c' => 'color',
510             'f' => 'fill',
511             'm' => 'mouse',
512             'w' => 'width',
513             's' => 'style',
514             };
515              
516             my $h_styles = {
517             'none' => 'Do not draw anything, just collect points',
518             'free' => 'Join all points to create freehand lines (default)',
519             'line' => 'Join first/last points to create straight lines',
520             'oval' => 'Join first/last points to create ovals',
521             'circle' => 'Join first/last points to create circles',
522             'rectangle' => 'Join first/last points to create rectangles',
523             };
524              
525              
526             ###############
527             ## Libraries ##
528             ###############
529             sub new {
530             my ($proto, $canvas, $c_result, $h_args) = @_;
531              
532             my $self = { 'points' => [ ], 'ids' => [ ], 'bindings' => { } };
533             bless $self, $proto;
534              
535             $self->assign_args($h_args);
536              
537             ($canvas || 0) or $self->fatal("Missing Canvas argument (arg \$1)");
538             ($c_result || 0) or $self->fatal("Missing result callback (arg \$2)");
539              
540             $self->{'canvas'} = $canvas;
541             $self->{'result'} = $c_result;
542              
543             my $mouse = $self->{'mouse'};
544             my $event = $self->{'start_event'};
545             my $a_draw = [ sub { $self->start_drawing(@_) }, Ev('x'), Ev('y') ];
546             $self->new_binding($canvas, $event, $a_draw);
547              
548             return $self;
549             }
550              
551              
552             ###############
553             ## Accessors ##
554             ###############
555             sub canvas { my ($self) = @_; $self->{'canvas'} }
556             sub mouse { my ($self) = @_; $self->{'mouse'} }
557             sub color { my ($self) = @_; $self->{'color'} }
558             sub fill { my ($self) = @_; $self->{'fill'} }
559             sub width { my ($self) = @_; $self->{'width'} }
560             sub style { my ($self) = @_; $self->{'style'} }
561              
562              
563             ##########################
564             ## User-visible Methods ##
565             ##########################
566             sub restart {
567             my ($self, $h_args) = @_;
568             $self->assign_args($h_args);
569             my $canvas = $self->{'canvas'};
570             my $event = $self->{'start_event'};
571             my $a_draw = [ sub { $self->start_drawing(@_) }, Ev('x'), Ev('y') ];
572             $self->new_binding($canvas, $event, $a_draw);
573             }
574              
575              
576             sub transform {
577             my ($self, $a_points, $xoff, $yoff, $canvas) = @_;
578             my $a_ids = [ ];
579             my ($x0, $y0);
580              
581             $canvas ||= $self->canvas;
582             my $color = $self->color;
583             my $fill = $self->fill;
584             my $width = $self->width;
585             my $style = $self->style;
586              
587             for (my $i = 0; $i < @$a_points; $i++) {
588             my $a_point = $a_points->[$i];
589             my ($x1, $y1) = ( $a_point->[0] + $xoff, $a_point->[1] + $yoff );
590              
591             if ($i > 0) {
592             my @args = ($x0, $y0, $x1, $y1);
593             if ($style eq 'free' or $style eq 'line') {
594             push @args, -width => $width;
595             $color and push @args, -fill => $color;
596             push @$a_ids, $canvas->createLine(@args);
597             } elsif ($style eq 'oval') {
598             push @args, -width => $width, -outline => $color;
599             $fill and push @args, -fill => $fill;
600             push @$a_ids, $canvas->createOval(@args);
601             } elsif ($style eq 'rectangle') {
602             push @args, -width => $width, -outline => $color;
603             $fill and push @args, -fill => $fill;
604             push @$a_ids, $canvas->createRectangle(@args);
605             } elsif ($style eq 'circle') {
606             my $rad = sqrt(($x1 - $x0) ** 2 + ($y1 - $y0) ** 2);
607             @args = ($x0 - $rad, $y0 - $rad, $x0 + $rad, $y0 + $rad);
608             push @args, -width => $width, -outline => $color;
609             $fill and push @args, -fill => $fill;
610             push @$a_ids, $canvas->createOval(@args);
611             }
612             }
613              
614             ($x0, $y0) = ($x1, $y1);
615             }
616              
617             return $a_ids;
618             }
619              
620              
621             ######################
622             ## Internal Methods ##
623             ######################
624             sub fatal {
625             my ($self, $errmsg) = @_;
626             carp "$errmsg\n";
627             exit;
628             }
629              
630              
631             sub new_binding {
632             my ($self, $canvas, $binding, $a_args) = @_;
633             my $c_prev = $canvas->Tk::bind($binding);
634             $self->{'bindings'}->{$binding} = $c_prev;
635             $canvas->Tk::bind($binding => $a_args);
636             }
637              
638              
639             sub restore_bindings {
640             my ($self, $canvas, $binding) = @_;
641             my $c_prev = delete $self->{'bindings'}->{$binding};
642             $canvas->Tk::bind($binding => $c_prev);
643             }
644              
645              
646             sub styles {
647             print "[Available Tk::Canvas::Draw styles]\n";
648             foreach my $key (sort keys %$h_styles) {
649             my $desc = $h_styles->{$key};
650             printf "%10.10s .... %s\n", $key, $desc;
651             }
652             }
653              
654              
655             sub assign_args {
656             my ($self, $h_args) = @_;
657              
658             # Make a copy of user-supplied args, resolving aliases
659             $h_args ||= { };
660             my $h_copy = { };
661             foreach my $k (keys %$h_args) {
662             my $key = $h_aliases->{$k} || $k;
663             $h_copy->{$key} = $h_args->{$k};
664             }
665              
666             # Resolve all arguments
667             foreach my $key (keys %$h_defaults) {
668             my $val = delete $h_copy->{$key};
669             if (defined($val)) {
670             $self->{$key} = $val;
671             } elsif (!defined($self->{$key})) {
672             $self->{$key} = $h_defaults->{$key};
673             }
674             }
675              
676             # Give an error if any arguments were invalid
677             my @leftover = keys %$h_copy;
678             if (@leftover > 0) {
679             my $s = (1 == @leftover)? "": "s";
680             my $errstr = "Unknown Tk::Canvas::Draw arg$s: ";
681             for (my $i = 0; $i < @leftover; $i++) {
682             my $arg = $leftover[$i];
683             $errstr .= ($i > 0)? ", '$arg'": "'$arg'";
684             }
685             $self->fatal($errstr);
686             }
687              
688             # Determine action when mouse button is clicked/moving/released
689             my $style = $self->{'style'};
690             if (!exists($h_styles->{$style})) {
691             my $styles = join(', ', keys %$h_styles);
692             $self->fatal("Unknown style '$style' (must be one of {$styles})");
693             }
694              
695             # Validate the mouse button
696             my $mouse = $self->{'mouse'};
697             if ($mouse !~ /^[123]$/) {
698             $self->fatal("Unknown mouse '$mouse' (must be one of {1, 2, 3})");
699             }
700              
701             # Assign events
702             $self->{'start_event'} = "";
703             $self->{'stop_event'} = "";
704             }
705              
706              
707             sub start_drawing {
708             my ($self, $canvas, $x, $y) = @_;
709              
710             $b_drawing++ and return;
711              
712             push @{$self->{'points'}}, [ $self->{'x'} = $x, $self->{'y'} = $y ];
713              
714             my $a_move = [ sub { $self->keep_drawing(@_) }, Ev('x'), Ev('y') ];
715             $self->new_binding($canvas, '', $a_move);
716              
717             my $a_stop = [ sub { $self->stop_drawing(@_) }, Ev('x'), Ev('y') ];
718             $self->new_binding($canvas, $self->{'stop_event'}, $a_stop);
719              
720             my $c_action = $self->{'action'};
721             ($c_action || 0) and $c_action->([ $x, $y ]);
722             }
723              
724              
725             sub keep_drawing {
726             my ($self, $canvas, $x1, $y1) = @_;
727              
728             my ($x0, $y0) = ($self->{'x'}, $self->{'y'});
729              
730             my $style = $self->{'style'};
731             if ($style ne 'none') {
732             my $method = "style_$style";
733             $self->$method($canvas, [ $x0, $y0, $x1, $y1 ]);
734             }
735              
736             my $c_action = $self->{'action'};
737             ($c_action || 0) and $c_action->([ $x1, $y1 ]);
738             }
739              
740              
741             sub stop_drawing {
742             my ($self, $canvas, $x, $y) = @_;
743              
744             my $h_bindings = $self->{'bindings'};
745             foreach my $binding (keys %$h_bindings) {
746             $self->restore_bindings($canvas, $binding);
747             }
748              
749             my $c_result = $self->{'result'};
750             my $a_points = $self->{'points'};
751             my $a_ids = $self->{'ids'};
752              
753             $self->{'points'} = [ ];
754             $self->{'ids'} = [ ];
755              
756             if (ref $c_result eq 'CODE') {
757             $c_result->($self, $a_points, $a_ids, $canvas);
758             }
759             $b_drawing = 0;
760             }
761              
762              
763             #==========#
764             ## Styles ##
765             #==========#
766             sub style_free {
767             my ($self, $canvas, $a_points) = @_;
768              
769             my ($x0, $y0, $x1, $y1) = @$a_points;
770              
771             my $width = $self->{'width'};
772             my $color = $self->{'color'};
773             my $a_ids = $self->{'ids'};
774              
775             my @args = ( -width => $width, -fill => $color );
776             push @$a_ids, $canvas->createLine($x0, $y0, $x1, $y1, @args);
777             push @{$self->{'points'}}, [ $self->{'x'} = $x1, $self->{'y'} = $y1 ];
778             }
779              
780              
781             sub style_line {
782             my ($self, $canvas, $a_points) = @_;
783              
784             my ($x1, $y1) = ($a_points->[-2], $a_points->[-1]);
785             my ($x0, $y0) = @{$self->{'points'}->[0]};
786              
787             my $width = $self->{'width'};
788             my $color = $self->{'color'};
789             my $a_ids = $self->{'ids'};
790              
791             if (@$a_ids > 0) {
792             pop @{$self->{'points'}};
793             my $id = pop @{$self->{'ids'}};
794             $canvas->delete($id);
795             }
796              
797             my @args = ( -width => $width, -fill => $color );
798             push @$a_ids, $canvas->createLine($x0, $y0, $x1, $y1, @args);
799             push @{$self->{'points'}}, [ $self->{'x'} = $x1, $self->{'y'} = $y1 ];
800             }
801              
802              
803             sub style_oval {
804             my ($self, $canvas, $a_points) = @_;
805              
806             my ($x1, $y1) = ($a_points->[-2], $a_points->[-1]);
807             my ($x0, $y0) = @{$self->{'points'}->[0]};
808              
809             my $width = $self->{'width'};
810             my $color = $self->{'color'};
811             my $fill = $self->{'fill'};
812             my $a_ids = $self->{'ids'};
813              
814             if (@$a_ids > 0) {
815             pop @{$self->{'points'}};
816             my $id = pop @{$self->{'ids'}};
817             $canvas->delete($id);
818             }
819              
820             my @args = ( -width => $width, -outline => $color );
821             $fill and push @args, -fill => $fill;
822             push @$a_ids, $canvas->createOval($x0, $y0, $x1, $y1, @args);
823             push @{$self->{'points'}}, [ $self->{'x'} = $x1, $self->{'y'} = $y1 ];
824             }
825              
826              
827             sub style_rectangle {
828             my ($self, $canvas, $a_points) = @_;
829              
830             my ($x1, $y1) = ($a_points->[-2], $a_points->[-1]);
831             my ($x0, $y0) = @{$self->{'points'}->[0]};
832              
833             my $width = $self->{'width'};
834             my $color = $self->{'color'};
835             my $fill = $self->{'fill'};
836             my $a_ids = $self->{'ids'};
837              
838             if (@$a_ids > 0) {
839             pop @{$self->{'points'}};
840             my $id = pop @{$self->{'ids'}};
841             $canvas->delete($id);
842             }
843              
844             my @args = ( -width => $width, -outline => $color );
845             $fill and push @args, -fill => $fill;
846             push @$a_ids, $canvas->createRectangle($x0, $y0, $x1, $y1, @args);
847             push @{$self->{'points'}}, [ $self->{'x'} = $x1, $self->{'y'} = $y1 ];
848             }
849              
850              
851             sub style_circle {
852             my ($self, $canvas, $a_points) = @_;
853              
854             my ($x1, $y1) = ($a_points->[-2], $a_points->[-1]);
855             my $a_center = $self->{'points'}->[0];
856             my ($x0, $y0) = @$a_center;
857             my $rad = sqrt(($x1 - $x0) ** 2 + ($y1 - $y0) ** 2);
858              
859             # Create the box surrounding the larger circle
860             my $a_corner1 = [ $x0 - $rad, $y0 - $rad ];
861             my $a_corner2 = [ $x0 + $rad, $y0 + $rad ];
862              
863             my $width = $self->{'width'};
864             my $color = $self->{'color'};
865             my $fill = $self->{'fill'};
866             my $a_ids = $self->{'ids'};
867              
868             if (@$a_ids > 0) {
869             pop @{$self->{'points'}};
870             my $id = pop @{$self->{'ids'}};
871             $canvas->delete($id);
872             }
873              
874             my @args = ( -width => $width, -outline => $color );
875             $fill and push @args, -fill => $fill;
876             push @$a_ids, $canvas->createOval(@$a_corner1, @$a_corner2, @args);
877             push @{$self->{'points'}}, [ $self->{'x'} = $x1, $self->{'y'} = $y1 ];
878             }
879              
880              
881             1;
882              
883              
884