Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | package Tk::Text::Tag; |
2 | require Tk::Text; | |
3 | ||
4 | use overload '""' => \&name; | |
5 | ||
6 | ||
7 | use vars qw($VERSION); | |
8 | $VERSION = '3.007'; # $Id: //depot/Tk8/Text/Text/Tag.pm#7 $ | |
9 | ||
10 | sub _apply | |
11 | { | |
12 | my $self = shift; | |
13 | my $meth = shift; | |
14 | $self->widget->tag($meth => $self->name,@_); | |
15 | } | |
16 | ||
17 | sub name | |
18 | { | |
19 | return shift->[0]; | |
20 | } | |
21 | ||
22 | sub widget | |
23 | { | |
24 | return shift->[1]; | |
25 | } | |
26 | ||
27 | BEGIN | |
28 | { | |
29 | my $meth; | |
30 | foreach $meth (qw(cget configure bind add)) | |
31 | { | |
32 | *{$meth} = sub { shift->_apply($meth,@_) } | |
33 | } | |
34 | } | |
35 | ||
36 | sub new | |
37 | { | |
38 | my $class = shift; | |
39 | my $widget = shift; | |
40 | my $name = shift; | |
41 | my $obj = bless [$name,$widget],$class; | |
42 | $obj->configure(@_) if (@_); | |
43 | return $obj; | |
44 | } | |
45 | ||
46 | 1; |