home *** CD-ROM | disk | FTP | other *** search
/ PC Welt 2006 November (DVD) / PCWELT_11_2006.ISO / casper / filesystem.squashfs / usr / share / perl5 / Data / Grove / Parent.pm next >
Encoding:
Text File  |  2003-10-21  |  8.1 KB  |  385 lines

  1. #
  2. # Copyright (C) 1998,1999 Ken MacLeod
  3. # Data::Grove::Parent is free software; you can redistribute it and/or
  4. # modify it under the same terms as Perl itself.
  5. #
  6. # $Id: Parent.pm,v 1.2 1999/12/22 21:15:00 kmacleod Exp $
  7. #
  8.  
  9. ###
  10. ### WARNING
  11. ###
  12. ###
  13. ### This code has a bug in it that renders it useless.  In the FETCH
  14. ### routines, the new object created should have a reference to the
  15. ### the tied object that has $self as the underlying value.  As of
  16. ### this version, I don't know of a way to get to the tied object.
  17. ###
  18.  
  19. # Search for places marked `VALIDATE' to see where validation hooks
  20. # may be added in the future.
  21.  
  22. use strict;
  23.  
  24. #--------------------------------------------------------------------------
  25. # Data::Grove::Parent
  26. #--------------------------------------------------------------------------
  27.  
  28. package Data::Grove::Parent;
  29.  
  30. use UNIVERSAL;
  31. use Carp;
  32.  
  33. use vars qw{ $VERSION };
  34.  
  35. # will be substituted by make-rel script
  36. $VERSION = "0.08";
  37.  
  38. sub new {
  39.     my $type = shift;
  40.     my $raw = shift;
  41.     my $parent = shift;
  42.  
  43.     if (UNIVERSAL::isa($raw, 'Data::Grove::Parent')) {
  44.         return $raw;
  45.     }
  46.  
  47.     my @properties = ( Raw => $raw );
  48.  
  49.     if (defined $parent) {
  50.         push @properties, Parent => $parent;
  51.     }
  52.  
  53.     my $dummy = bless {}, ref($raw);
  54.     tie %$dummy, $type, @properties;
  55.     return $dummy;
  56. }
  57.  
  58. sub TIEHASH  {
  59.     my $type = shift;
  60.  
  61.     return bless { @_ }, $type;
  62. }
  63.  
  64. sub STORE    {
  65.     my $self = shift;
  66.     my $key = shift;
  67.     my $value = shift;
  68.  
  69.     if (exists $self->{$key}) {
  70.     $self->{$key} = $value;
  71.     } else {
  72.     # VALIDATE
  73.     if (UNIVERSAL::isa($value, 'Data::Grove::Parent')) {
  74.         $value = $value->{Raw};
  75.     } elsif (UNIVERSAL::isa($value, 'Data::Grove::ParentList')) {
  76.         $value = $value->[0];
  77.     }
  78.     $self->{Raw}{$key} = $value;
  79.     }
  80. }
  81.  
  82. sub FETCH {
  83.     my $self = shift;
  84.     my $key = shift;
  85.  
  86.     if (exists $self->{$key}) {
  87.     return $self->{$key};
  88.     } else {
  89.     my $value = $self->{Raw}{$key};
  90.     if (ref($value) eq 'ARRAY') {
  91.         $value = Data::Grove::ParentList->new($value, $self);
  92.     }
  93.     return $value;
  94.     }
  95. }
  96.  
  97. sub FIRSTKEY {
  98.     my $self = shift;
  99.     my $raw = $self->{Raw};
  100.  
  101.     $self->{'__each_in_raw'} = 1;
  102.     my $a = scalar keys %$raw;
  103.     each %$raw;
  104. }
  105.  
  106. sub NEXTKEY  {
  107.     my $self = shift;
  108.     my $raw = $self->{Raw};
  109.  
  110.     my ($key, $value);
  111.     if ($self->{'__each_in_raw'}) {
  112.     if (($key, $value) = each %$raw) {
  113.         return $key;
  114.     }
  115.     delete $self->{'__each_in_raw'};
  116.     my $a = scalar keys %$self;
  117.     }
  118.  
  119.     return each %$self;
  120. }
  121.  
  122. sub EXISTS {
  123.     my $self = shift;
  124.     my $key = shift;
  125.  
  126.     return (exists $self->{Raw}{$key})
  127.     || (exists $self->{$key});
  128. }
  129.  
  130.  
  131. sub DELETE {
  132.     my $self = shift;
  133.     my $key = shift;
  134.  
  135.     if (exists $self->{$key}) {
  136.     croak "can't delete \`Parent' or \`Raw' properties\n"
  137.         if ($key eq 'Parent' || $key eq 'Raw');
  138.     delete $self->{$key};
  139.     } else {
  140.     delete $self->{'Raw'}{$key};
  141.     }
  142. }
  143.  
  144. sub CLEAR {
  145.     my $self = shift;
  146.  
  147.     %{ $self->{Raw} } = ();
  148. }
  149.  
  150. #--------------------------------------------------------------------------
  151. # Data::Grove::ParentList
  152. #--------------------------------------------------------------------------
  153.  
  154. package Data::Grove::ParentList;
  155.  
  156. use UNIVERSAL;
  157.  
  158. sub new {
  159.     my $type = shift;
  160.     my $raw = shift;
  161.     my $parent = shift;
  162.  
  163.     if (UNIVERSAL::isa($raw, 'Data::Grove::ParentList')) {
  164.         return $raw;
  165.     }
  166.  
  167.     my $dummy = [];
  168.     tie @$dummy, $type, $raw, $parent;
  169.     return $dummy;
  170. }
  171.  
  172. sub TIEARRAY {
  173.     my $type = shift;
  174.  
  175.     return bless [ @_ ], $type;
  176. }
  177.  
  178. sub FETCHSIZE {
  179.     scalar @{$_[0][0]};
  180. }
  181.  
  182. sub STORESIZE {
  183.     $#{$_[0][0]} = $_[1]-1;
  184. }
  185.  
  186. sub STORE {
  187.     my $self = shift;
  188.     my $index = shift;
  189.     my $value = shift;
  190.  
  191.     # VALIDATE
  192.     if (UNIVERSAL::isa($value, 'Data::Grove::Parent')) {
  193.     $value = $value->{Raw};
  194.     } elsif (UNIVERSAL::isa($value, 'Data::Grove::ParentList')) {
  195.     $value = $value->[0];
  196.     }
  197.     $self->[0][$index] = $value;
  198. }
  199.  
  200. sub FETCH {
  201.     my $self = shift;
  202.     my $index = shift;
  203.  
  204.     my $value = $self->[0][$index];
  205.     if (defined $value) {
  206.     if (ref($value)) {
  207.         return Data::Grove::Parent->new($value, $self->[1]);
  208.     } else {
  209.         return Data::Grove::Parent->new({ Data => $value }, $self->[1]);
  210.     }
  211.     }
  212.  
  213.     return $value;
  214. }
  215.  
  216. sub CLEAR {
  217.     @{$_[0][0]} = ();
  218. }
  219.  
  220. sub POP {
  221.     pop(@{$_[0][0]});
  222. }
  223.  
  224. sub PUSH {
  225.     my $o = shift;
  226.  
  227.     foreach my $value (@_) {
  228.     # VALIDATE
  229.     if (UNIVERSAL::isa($value, 'Data::Grove::Parent')) {
  230.         $value = $value->{Raw};
  231.     } elsif (UNIVERSAL::isa($value, 'Data::Grove::ParentList')) {
  232.         $value = $value->[0];
  233.     }
  234.     }    
  235.     push(@{$o->[0]},@_);
  236. }
  237.  
  238. sub SHIFT {
  239.     shift(@{$_[0][0]});
  240. }
  241.  
  242. sub UNSHIFT {
  243.     my $o = shift;
  244.  
  245.     foreach my $value (@_) {
  246.     # VALIDATE
  247.     if (UNIVERSAL::isa($value, 'Data::Grove::Parent')) {
  248.         $value = $value->{Raw};
  249.     } elsif (UNIVERSAL::isa($value, 'Data::Grove::ParentList')) {
  250.         $value = $value->[0];
  251.     }
  252.     }    
  253.     unshift(@{$o->[0]},@_);
  254.  
  255. sub SPLICE
  256. {
  257.     my $ob  = shift;                    
  258.     my $sz  = $ob->FETCHSIZE;
  259.     my $off = @_ ? shift : 0;
  260.     $off   += $sz if $off < 0;
  261.     my $len = @_ ? shift : $sz-$off;
  262.  
  263.     foreach my $value (@_) {
  264.     # VALIDATE
  265.     if (UNIVERSAL::isa($value, 'Data::Grove::Parent')) {
  266.         $value = $value->{Raw};
  267.     } elsif (UNIVERSAL::isa($value, 'Data::Grove::ParentList')) {
  268.         $value = $value->[0];
  269.     }
  270.     }    
  271.     return splice(@{$ob->[0]},$off,$len,@_);
  272. }
  273.  
  274. #--------------------------------------------------------------------------
  275. # Data::Grove
  276. #--------------------------------------------------------------------------
  277.  
  278. package Data::Grove;
  279.  
  280. sub root {
  281.     my $self = shift;
  282.  
  283.     return $self
  284.     if !defined $self->{Parent};
  285.  
  286.     return $self->{Parent}->root(@_);
  287. }
  288.  
  289. sub rootpath {
  290.     my $self = shift;
  291.  
  292.     if (defined $self->{Parent}) {
  293.         return ($self->{Parent}->rootpath, $self);
  294.     } else {
  295.         return ($self);
  296.     }
  297. }
  298.  
  299. sub add_magic {
  300.     my $self = shift;
  301.     my $parent = shift;
  302.  
  303.     return Data::Grove::Parent->new($self, $parent);
  304. }
  305.  
  306. 1;
  307.  
  308. __END__
  309.  
  310. =head1 NAME
  311.  
  312. Data::Grove::Parent - provide parent properties to Data::Grove objects
  313.  
  314. =head1 SYNOPSIS
  315.  
  316.  use Data::Grove::Parent;
  317.  
  318.  $root = $object->root;
  319.  $rootpath = $object->rootpath;
  320.  $tied = $object->add_magic([ $parent ]);
  321.  
  322.  $node = Data::Grove::Parent->new($hash [, $parent]);
  323.  $node_list = Data::Grove::ParentList->new($array [, $parent]);
  324.  
  325. =head1 DESCRIPTION
  326.  
  327. Data::Grove::Parent is an extension to Data::Grove that adds
  328. `C<Parent>' and `C<Raw>' properties to Data::Grove objects and methods
  329. for returning the root node of a grove, a list of nodes between and
  330. including the root node and the current node, and a method that
  331. creates parented nodes.
  332.  
  333. Data::Grove::Parent works by creating a Perl ``tied'' object that
  334. contains a parent reference (`C<Parent>') and a reference to the
  335. original Data::Grove object (`C<Raw>').  Tying-magic is used so that
  336. every time you reference the Data::Grove::Parent object it actually
  337. references the underlying raw object.
  338.  
  339. When you retrieve a list or a property of the Raw object,
  340. Data::Grove::Parent automatically adds magic to the returned list or
  341. node.  This means you only call `add_magic()' once to create the first
  342. Data::Grove::Parent object and then use the grove objects like you
  343. normally would.
  344.  
  345. The most obvious use of this is so you don't have to call a
  346. `C<delete>' method when you want to release a grove or part of a
  347. grove; since Data::Grove and Data::Grove::Parent objects have no
  348. cyclic references, Perl can garbage collect them normally.
  349.  
  350. A secondary use is to allow you to reuse grove or property set
  351. fragments in multiple trees.  WARNING: Data::Grove currently does not
  352. protect you from creating your B<own> cyclic references!  This could
  353. lead to infinite loops if you don't take care to avoid them.
  354.  
  355. =head1 METHODS
  356.  
  357. =over 4
  358.  
  359. =item $object->root()
  360.  
  361. =item $object->rootpath()
  362.  
  363. `C<root()>' returns the root node if `C<$object>' is a
  364. `C<Data::Grove::Parent>' object.  `C<rootpath()>' returns an array of
  365. all the nodes between and including the root node and `C<$object>'.
  366.  
  367. =item $tied = $object->add_magic([ $parent ])
  368.  
  369. `C<add_magic()>' returns a C<Data::Grove::Parent> object with
  370. `C<$object>' as it's `C<Raw>' object.  If `C<$parent>' is given, that
  371. becomes the tied object's parent object.
  372.  
  373. =back
  374.  
  375. =head1 AUTHOR
  376.  
  377. Ken MacLeod, ken@bitsko.slc.ut.us
  378.  
  379. =head1 SEE ALSO
  380.  
  381. perl(1), Data::Grove(3)
  382.  
  383. =cut
  384.