summaryrefslogtreecommitdiff
path: root/Master/perltl/site/lib/Tk/Canvas.pm
blob: e1ce78b6a93f656fa7652721c5745b995da55a38 (plain)
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
package Tk::Canvas;
use vars qw($VERSION);
$VERSION = '3.018'; # $Id: //depot/Tk8/Canvas/Canvas.pm#18 $

use Tk qw($XS_VERSION);

use base qw(Tk::Widget);
Construct Tk::Widget 'Canvas';

bootstrap Tk::Canvas;

sub Tk_cmd { \&Tk::canvas }

Tk::Methods('addtag','bbox','bind','canvasx','canvasy','coords','create',
            'dchars','delete','dtag','find','focus','gettags','icursor',
            'index','insert','itemcget','itemconfigure','lower','move',
            'postscript','raise','scale','scan','select','type','xview','yview');

use Tk::Submethods ( 'create' => [qw(arc bitmap grid group image line oval
				     polygon rectangle text window)],
		     'scan'   => [qw(mark dragto)],
		     'select' => [qw(from clear item to)],
		     'xview'  => [qw(moveto scroll)],
		     'yview'  => [qw(moveto scroll)],
		     );

*CanvasBind  = \&Tk::bind;
*CanvasFocus = \&Tk::focus;

sub ClassInit
{
 my ($class,$mw) = @_;
 $mw->XYscrollBind($class);
 return $class;
}

sub BalloonInfo
{
 my ($canvas,$balloon,$X,$Y,@opt) = @_;
 my @tags = ($canvas->find('withtag', 'current'),$canvas->gettags('current'));
 foreach my $opt (@opt)
  {
   my $info = $balloon->GetOption($opt,$canvas);
   if ($opt =~ /^-(statusmsg|balloonmsg)$/ && UNIVERSAL::isa($info,'HASH'))
    {
     $balloon->Subclient($tags[0]);
     foreach my $tag (@tags)
      {
       return $info->{$tag} if exists $info->{$tag};
      }
     return '';
    }
   return $info;
  }
}



1;