home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / Cloth.pm < prev    next >
Encoding:
Perl POD Document  |  2003-09-16  |  10.7 KB  |  527 lines
  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 1.2 2003/09/16 18:16:45 joker Exp $
  12.  
  13. package Tk::Cloth;
  14.  
  15. use strict;
  16. use vars qw($VERSION);
  17.  
  18. $VERSION = sprintf("%d.%02d", q$Revision: 1.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
  527.