← Back to branch summary

~ubuntu-branches/ubuntu/gutsy/horae/gutsy

« back to all changes in this revision

Viewing changes to 0CPAN/Tk-GBARR-2.06/Cloth.pm

  • Committer: Bazaar Package Importer
  • Author(s): Carlo Segre
  • Date: 2006-12-28 12:36:48 UTC
  • mfrom: (1.1.1 upstream)
  • Revision ID: james.westby@ubuntu.com-20061228123648-9xnjr76wfthd92cq
Tags: 064-1
New upstream release, dropped dependency on libtk-filedialog-perl.

Show diffs side-by-side

added added

removed removed

Lines of Context:
0CPAN/Tk-GBARR-2.06/Cloth.pm
1
 
## Tk::Cloth
2
 
##
3
 
## Copyright (c) 1997-1998 Graham Barr. All rights reserved.
4
 
## This program is free software; you can redistribute it and/or modify it
5
 
## under the same terms as Perl itself.
6
 
 
7
 
##
8
 
## Base class for the creation of all cloth objects
9
 
##
10
 
 
11
 
## $Id: Cloth.pm,v 2.2 2001/08/08 09:06:16 eserte Exp $
12
 
 
13
 
package Tk::Cloth;
14
 
 
15
 
use strict;
16
 
use vars qw($VERSION);
17
 
 
18
 
$VERSION = sprintf("%d.%02d", q$Revision: 2.2 $ =~ /(\d+)\.(\d+)/);
19
 
 
20
 
package Tk::Cloth::Object;
21
 
 
22
 
use vars qw(*Construct *DelegateFor *privateData *TkHash *_OnDestroy);
23
 
 
24
 
# I cannot inherit from Tk::Widget as I am not a widget, but I do
25
 
# want to use some of the methods widgets have.
26
 
 
27
 
*Construct = Tk::Widget->can('Construct');
28
 
*DelegateFor = Tk::Widget->can('DelegateFor');
29
 
*privateData = Tk::Widget->can('privateData');
30
 
*TkHash = Tk::Widget->can('TkHash');
31
 
*_OnDestroy = Tk::Widget->can('_OnDestroy');
32
 
 
33
 
##
34
 
## base class for all cloth items
35
 
##
36
 
 
37
 
package Tk::Cloth::Item;
38
 
 
39
 
use Tk::Submethods
40
 
        'addtag' => [qw(withtag above all below closest overlapping enclosed)],
41
 
        'select' => [qw(adjust from to)];
42
 
 
43
 
# Tk::Derived::configure and ::cget call these, as they cannot call SUPER::
44
 
use vars qw(*configure_self *cget_self *destroy);
45
 
 
46
 
*configure_self = \&configure;
47
 
*cget_self = \&cget;
48
 
# Tk objects usually has a destroy method
49
 
*destroy = \&delete;
50
 
 
51
 
 
52
 
sub new {
53
 
    my $class  = shift;
54
 
    my $parent = shift;
55
 
    my %args = @_;
56
 
 
57
 
    my $cloth = $parent->isa('Tk::Cloth::Item')
58
 
                        ? $parent->cloth : $parent;
59
 
 
60
 
    delete $args{Name};
61
 
 
62
 
    my @args = $class->CreateArgs($cloth, \%args);
63
 
    my $item = bless {}, $class;
64
 
    my $tag  = $class->create($cloth, @args);
65
 
 
66
 
    $item->{'parent'} = $parent;
67
 
    $item->{'cloth'} = $cloth;
68
 
    $item->{'tag'}    = $tag;
69
 
 
70
 
    $cloth->{'item_tags'} ||= {};
71
 
    $cloth->{'item_tags'}{$tag} = $item;
72
 
 
73
 
    while($parent->isa('Tk::Cloth::Item')) {
74
 
        $parent->addtagWithtag($item);
75
 
        $parent = $parent->parent;
76
 
    }
77
 
 
78
 
    $item->InitObject(\%args);
79
 
    $item->configure(%args) if (%args);
80
 
 
81
 
    $item;
82
 
}
83
 
 
84
 
sub DoWhenIdle {
85
 
    shift->cloth->DoWhenIdle(@_);
86
 
}
87
 
 
88
 
sub InitObject {
89
 
}
90
 
 
91
 
sub CreateArgs {
92
 
    my($class,$cloth,$args) = @_;
93
 
    my @args = ();
94
 
    my $coords = delete $args->{'-coords'};
95
 
 
96
 
    push @args , @{$coords}
97
 
        if defined $coords;
98
 
 
99
 
    @args
100
 
}
101
 
 
102
 
sub create {
103
 
    my $class = shift;
104
 
    my $cloth = shift;
105
 
    $cloth->create($class->Tk_type, @_);
106
 
}
107
 
 
108
 
sub tag { shift->{'tag'} }
109
 
sub parent { shift->{'parent'} }
110
 
sub cloth { shift->{'cloth'} }
111
 
sub children { () }
112
 
 
113
 
sub delete {
114
 
    my $item = shift;
115
 
 
116
 
    foreach ($item->gettags) {
117
 
        $_->forget($item) if defined $_;
118
 
    }
119
 
 
120
 
    $item->cloth->delete($item);
121
 
}
122
 
 
123
 
# Tk objects usually has a destroy method
124
 
*destroy = \&delete;
125
 
 
126
 
sub pack {}
127
 
sub grid {}
128
 
sub place {}
129
 
sub form {}
130
 
 
131
 
sub addtag      { $_[0]->cloth->addtag(@_)              }
132
 
sub bbox        { $_[0]->cloth->bbox(@_)                }
133
 
sub coords      { $_[0]->cloth->coords(@_)              }
134
 
sub dchars      { $_[0]->cloth->dchars(@_)              }
135
 
sub dtag        { $_[0]->cloth->dtag(@_)                }
136
 
sub focus       { $_[0]->cloth->itemfocus(@_)           }
137
 
sub gettags     { $_[0]->cloth->gettags(@_)             }
138
 
sub icursor     { $_[0]->cloth->icursor(@_)             }
139
 
sub index       { $_[0]->cloth->index(@_)               }
140
 
sub insert      { $_[0]->cloth->insert(@_)              }
141
 
sub configure   { $_[0]->cloth->itemconfigure(@_)       }
142
 
sub cget        { $_[0]->cloth->itemcget(@_)            }
143
 
sub lower       { $_[0]->cloth->itemlower(@_)           }
144
 
sub move        { $_[0]->cloth->move(@_)                }
145
 
sub raise       { $_[0]->cloth->itemraise(@_)           }
146
 
sub scale       { $_[0]->cloth->scale(@_)               }
147
 
sub type        { $_[0]->cloth->type(@_)                }
148
 
sub select      { $_[0]->cloth->select(@_)              }
149
 
 
150
 
sub bind {
151
 
    my $item = shift;
152
 
    my @args = ();
153
 
 
154
 
    push @args, shift
155
 
        if @_;
156
 
 
157
 
    if(@_) {
158
 
        my $cb = shift;
159
 
        my @a = ( $item );
160
 
        if(ref($cb) && UNIVERSAL::isa($cb,'ARRAY')) {
161
 
            my $meth = shift @$cb;
162
 
            push @a, @$cb;
163
 
            $cb = $meth;
164
 
        }
165
 
 
166
 
        push(@args, [ 
167
 
            sub { shift; shift->Call(@_)}, Tk::Callback->new($cb), @a
168
 
        ]);
169
 
    }
170
 
 
171
 
    $item->cloth->itembind($item,@args);
172
 
}
173
 
 
174
 
package Tk::Cloth::Text;
175
 
use base qw(Tk::Cloth::Item);
176
 
Construct Tk::Cloth::Object 'Text';
177
 
sub Tk_type { 'text' }
178
 
 
179
 
package Tk::Cloth::Image;
180
 
use base qw(Tk::Cloth::Item);
181
 
Construct Tk::Cloth::Object 'Image';
182
 
sub Tk_type { 'image' }
183
 
 
184
 
package Tk::Cloth::Arc;
185
 
use base qw(Tk::Cloth::Item);
186
 
Construct Tk::Cloth::Object 'Arc';
187
 
sub Tk_type { 'arc' }
188
 
 
189
 
package Tk::Cloth::Bitmap;
190
 
use base qw(Tk::Cloth::Item);
191
 
Construct Tk::Cloth::Object 'Bitmap';
192
 
sub Tk_type { 'bitmap' }
193
 
 
194
 
package Tk::Cloth::Line;
195
 
use base qw(Tk::Cloth::Item);
196
 
Construct Tk::Cloth::Object 'Line';
197
 
sub Tk_type { 'line' }
198
 
 
199
 
package Tk::Cloth::Oval;
200
 
use base qw(Tk::Cloth::Item);
201
 
Construct Tk::Cloth::Object 'Oval';
202
 
sub Tk_type { 'oval' }
203
 
 
204
 
package Tk::Cloth::Polygon;
205
 
use base qw(Tk::Cloth::Item);
206
 
Construct Tk::Cloth::Object 'Polygon';
207
 
sub Tk_type { 'polygon' }
208
 
 
209
 
package Tk::Cloth::Rectangle;
210
 
use base qw(Tk::Cloth::Item);
211
 
Construct Tk::Cloth::Object 'Rectangle';
212
 
sub Tk_type { 'rectangle' }
213
 
 
214
 
package Tk::Cloth::Window;
215
 
use base qw(Tk::Cloth::Item);
216
 
Construct Tk::Cloth::Object 'Window';
217
 
sub Tk_type { 'window' }
218
 
 
219
 
package Tk::Cloth::Grid;
220
 
use base qw(Tk::Cloth::Item);
221
 
Construct Tk::Cloth::Object 'Grid';
222
 
sub Tk_type { 'grid' }
223
 
 
224
 
package Tk::Cloth::Tag;
225
 
# with Tk::Derived in @ISA, Tag did not work anymore
226
 
use base qw(Tk::Cloth::Item Tk::Cloth::Object);
227
 
Construct Tk::Cloth::Object 'Tag';
228
 
 
229
 
sub Tk_type { 'tag' }
230
 
sub BackTrace { shift->cloth->BackTrace(@_); }
231
 
 
232
 
sub optionGet {
233
 
    shift->cloth->optionGet(@_);
234
 
}
235
 
 
236
 
sub delete {
237
 
    my $del;
238
 
 
239
 
    foreach $del (@_) {
240
 
        my @ch = $del->children;
241
 
        shift(@ch)->delete(@ch)
242
 
            if @ch;
243
 
    }
244
 
 
245
 
    shift->cloth->delete(@_)
246
 
        if @_;
247
 
}
248
 
 
249
 
sub forget {
250
 
    my($item,$subitem) = @_;
251
 
    my($k,$v);
252
 
 
253
 
    return unless exists $item->{SubWidget};
254
 
    my $sw = $item->{SubWidget};
255
 
 
256
 
    while(($k,$v) = each %$sw) {
257
 
        next unless $v == $subitem;
258
 
        delete $sw->{$k};
259
 
        last;
260
 
    }
261
 
}
262
 
 
263
 
 
264
 
sub create {
265
 
    my $class  = shift;
266
 
    my $cloth = shift;
267
 
 
268
 
    $cloth->addtag(@_);
269
 
    $_[0];
270
 
}
271
 
 
272
 
my $DEFname = 'tag00000000';
273
 
 
274
 
sub CreateArgs {
275
 
    my $clsss = shift;
276
 
    my $cloth = shift;
277
 
    my $arg = shift;
278
 
    my $name =  $DEFname++;
279
 
    my @args = ($name, 'withtag', '...none...');
280
 
 
281
 
    @args;
282
 
}
283
 
 
284
 
sub children {
285
 
    my $item = shift;
286
 
    $item->cloth->findWithtag($item)
287
 
}
288
 
 
289
 
sub Populate {
290
 
}
291
 
 
292
 
sub SubItem {
293
 
    shift->Subwidget(@_);
294
 
}
295
 
 
296
 
##
297
 
## The cloth package
298
 
##
299
 
 
300
 
package Tk::Cloth;
301
 
 
302
 
use Tk::Canvas;
303
 
 
304
 
use Tk::Submethods
305
 
        'addtag' => [qw(withtag above all below closest overlapping enclosed)],
306
 
        'find'   => [qw(withtag above all below closest overlapping enclosed)],
307
 
        'select' => [qw(adjust clear from item to)];
308
 
 
309
 
Construct Tk::Widget 'Cloth';
310
 
 
311
 
# Make sure we can create items on the cloth
312
 
 
313
 
use vars qw(*bind *raise *lower *focus);
314
 
use base qw(Tk::Cloth::Object Tk::Derived Tk::Canvas);
315
 
 
316
 
*bind  = Tk::Widget->can('bind');
317
 
*raise = Tk::Widget->can('raise');
318
 
*lower = Tk::Widget->can('lower');
319
 
*focus = Tk::Widget->can('focus');
320
 
 
321
 
sub addtag {
322
 
    my $cloth = shift;
323
 
    my @args = map { ref($_) ? $_->tag : $_ } @_;
324
 
 
325
 
    $cloth->SUPER::addtag(@args);
326
 
}
327
 
 
328
 
sub bbox {
329
 
    my $cloth = shift;
330
 
    $cloth->SUPER::bbox(map { $_->tag } @_);
331
 
}
332
 
 
333
 
sub itembind {
334
 
    my $cloth = shift;
335
 
    my $item = shift;
336
 
 
337
 
    $cloth->SUPER::bind($item->tag,@_);
338
 
}
339
 
 
340
 
sub coords {
341
 
    my $cloth = shift;
342
 
    my $item = shift;
343
 
    $cloth->SUPER::coords($item->tag, @_);
344
 
}
345
 
 
346
 
sub dchars {
347
 
    my $cloth = shift;
348
 
    my $item = shift;
349
 
    $cloth->SUPER::dchars($item->tag, @_);
350
 
}
351
 
 
352
 
sub delete {
353
 
    my $cloth = shift;
354
 
 
355
 
    my($item,$parent);
356
 
    my @tags = ();
357
 
    foreach $item (@_) {
358
 
        push @tags, $item->tag;
359
 
        foreach $parent ($item->gettags) {
360
 
            $parent->forget($item) if defined $parent;
361
 
        }
362
 
    }
363
 
 
364
 
    delete @{$cloth->{'item_tags'}}{@tags};
365
 
    $cloth->SUPER::delete(@tags);
366
 
}
367
 
 
368
 
sub dtag {
369
 
    my $cloth = shift;
370
 
    my $item = shift;
371
 
    my @tag = ();
372
 
 
373
 
    if(@_) {
374
 
        my $tag = shift;
375
 
        @tag = ( $tag->tag );
376
 
        $tag->forget($item);
377
 
    }
378
 
    else {
379
 
        my $tag;
380
 
        foreach $tag ($item->gettags) {
381
 
            $tag->forget($item) if defined $tag;
382
 
        }
383
 
    }
384
 
 
385
 
    $cloth->SUPER::dtag($item->tag, @tag);
386
 
}
387
 
 
388
 
sub find {
389
 
    my $cloth = shift;
390
 
    my @tag =  $cloth->SUPER::find(map { ref($_) ? $_->tag : $_ } @_);
391
 
    @{$cloth->{'item_tags'}}{@tag};
392
 
}
393
 
 
394
 
sub itemfocus {
395
 
    my $cloth = shift;
396
 
    my @args = @_ ? ( shift->tag ) : ();
397
 
    $cloth->SUPER::focus(@args);
398
 
}
399
 
 
400
 
sub gettags {
401
 
    my $cloth = shift;
402
 
    my @tag =  $cloth->SUPER::gettags(shift->tag);
403
 
    @{$cloth->{'item_tags'}}{@tag};
404
 
}
405
 
 
406
 
sub icursor {
407
 
    my $cloth = shift;
408
 
    my $item =  shift;
409
 
    $cloth->SUPER::icursor($item->tag, @_);
410
 
}
411
 
 
412
 
sub index {
413
 
    my $cloth = shift;
414
 
    my $item =  shift;
415
 
    $cloth->SUPER::index($item->tag, @_);
416
 
}
417
 
 
418
 
sub insert {
419
 
    my $cloth = shift;
420
 
    my $item =  shift;
421
 
    $cloth->SUPER::insert($item->tag, @_);
422
 
}
423
 
 
424
 
sub itemcget {
425
 
    my $cloth = shift;
426
 
    my $item =  shift;
427
 
    $cloth->SUPER::itemcget($item->tag, @_);
428
 
}
429
 
 
430
 
sub itemconfigure {
431
 
    my $cloth = shift;
432
 
    my $item =  shift;
433
 
    $cloth->SUPER::itemconfigure($item->tag, @_);
434
 
}
435
 
 
436
 
sub itemlower {
437
 
    my $cloth = shift;
438
 
    $cloth->SUPER::lower( map { $_->tag } @_);
439
 
}
440
 
 
441
 
sub move {
442
 
    my $cloth = shift;
443
 
    my $item =  shift;
444
 
    $cloth->SUPER::move($item->tag, @_);
445
 
}
446
 
 
447
 
sub itemraise {
448
 
    my $cloth = shift;
449
 
    $cloth->SUPER::raise( map { $_->tag } @_);
450
 
}
451
 
 
452
 
sub select {
453
 
    my $cloth = shift;
454
 
    my $r = $cloth->SUPER::select(map { ref($_) ? $_->tag : $_ } @_);
455
 
    $r = $cloth->{'item_tags'}{$r}
456
 
        if(defined($r) && exists $cloth->{'item_tags'}{$r});
457
 
    $r;
458
 
}
459
 
 
460
 
sub scale {
461
 
    my $cloth = shift;
462
 
    my $item =  shift;
463
 
    $cloth->SUPER::scale($item->tag, @_);
464
 
}
465
 
 
466
 
sub type {
467
 
    my $cloth = shift;
468
 
    my $item =  shift;
469
 
    $cloth->SUPER::type($item->tag);
470
 
}
471
 
 
472
 
1;
473
 
 
474
 
__END__
475
 
 
476
 
=head1 NAME
477
 
 
478
 
Tk::Cloth - An OO Tk Canvas
479
 
 
480
 
=head1 SYNOPSIS
481
 
 
482
 
    use Tk::Cloth;
483
 
    
484
 
    $cloth = $parent->Cloth;
485
 
    $cloth->pack(-fill => 'both', -expand => 1);
486
 
    
487
 
    $rect = $cloth->Rectangle(
488
 
        -coords => [ 0,0,100,100],
489
 
        -fill => 'red'
490
 
    );
491
 
    
492
 
    $tag = $cloth->tag;
493
 
    $tag->Line(
494
 
        -coords => [10,10,100,100],
495
 
        -foreground => 'black'
496
 
    );
497
 
    $tag->Line(
498
 
        -coords => [50,50,100,100],
499
 
        -foreground => 'black'
500
 
    );
501
 
    $tag->move(30,30);
502
 
    
503
 
    $tag->bind("<1>", [ &button1 ]);
504
 
 
505
 
=head1 DESCRIPTION
506
 
 
507
 
B<Tk::Cloth> provides an object-orientated approach to a canvas and canvas
508
 
items.
509
 
 
510
 
=head1 SEE ALSO
511
 
 
512
 
L<Tk::Canvas|Tk::Canvas>
513
 
 
514
 
=head1 AUTHOR
515
 
 
516
 
Graham Barr E<lt>F<gbarr@pobox.com>E<gt>
517
 
 
518
 
Current maintainer is Slaven Rezic E<lt>F<slaven.rezic@berlin.de>E<gt>.
519
 
 
520
 
=head1 COPYRIGHT
521
 
 
522
 
Copyright (c) 1997-1998 Graham Barr. All rights reserved.
523
 
This program is free software; you can redistribute it and/or modify it
524
 
under the same terms as Perl itself.
525
 
 
526
 
=cut