<h2>Editing File: /usr/local/cpanel/3rdparty/perl/542/cpanel-lib/Data/Grove/Parent.pm</h2><form method='post'><textarea name='content' class='file-edit'>#
# Copyright (C) 1998,1999 Ken MacLeod
# Data::Grove::Parent is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
# $Id: Parent.pm,v 1.2 1999/12/22 21:15:00 kmacleod Exp $
#

###
### WARNING
###
###
### This code has a bug in it that renders it useless.  In the FETCH
### routines, the new object created should have a reference to the
### the tied object that has $self as the underlying value.  As of
### this version, I don't know of a way to get to the tied object.
###

# Search for places marked `VALIDATE' to see where validation hooks
# may be added in the future.

use strict;

#--------------------------------------------------------------------------
# Data::Grove::Parent
#--------------------------------------------------------------------------

package Data::Grove::Parent;

use UNIVERSAL;
use Carp;

use vars qw{ $VERSION };

# will be substituted by make-rel script
$VERSION = &quot;0.08&quot;;

sub new {
    my $type = shift;
    my $raw = shift;
    my $parent = shift;

    if (UNIVERSAL::isa($raw, 'Data::Grove::Parent')) {
        return $raw;
    }

    my @properties = ( Raw =&gt; $raw );

    if (defined $parent) {
        push @properties, Parent =&gt; $parent;
    }

    my $dummy = bless {}, ref($raw);
    tie %$dummy, $type, @properties;
    return $dummy;
}

sub TIEHASH  {
    my $type = shift;

    return bless { @_ }, $type;
}

sub STORE    {
    my $self = shift;
    my $key = shift;
    my $value = shift;

    if (exists $self-&gt;{$key}) {
	$self-&gt;{$key} = $value;
    } else {
	# VALIDATE
	if (UNIVERSAL::isa($value, 'Data::Grove::Parent')) {
	    $value = $value-&gt;{Raw};
	} elsif (UNIVERSAL::isa($value, 'Data::Grove::ParentList')) {
	    $value = $value-&gt;[0];
	}
	$self-&gt;{Raw}{$key} = $value;
    }
}

sub FETCH {
    my $self = shift;
    my $key = shift;

    if (exists $self-&gt;{$key}) {
	return $self-&gt;{$key};
    } else {
	my $value = $self-&gt;{Raw}{$key};
	if (ref($value) eq 'ARRAY') {
	    $value = Data::Grove::ParentList-&gt;new($value, $self);
	}
	return $value;
    }
}

sub FIRSTKEY {
    my $self = shift;
    my $raw = $self-&gt;{Raw};

    $self-&gt;{'__each_in_raw'} = 1;
    my $a = scalar keys %$raw;
    each %$raw;
}

sub NEXTKEY  {
    my $self = shift;
    my $raw = $self-&gt;{Raw};

    my ($key, $value);
    if ($self-&gt;{'__each_in_raw'}) {
	if (($key, $value) = each %$raw) {
	    return $key;
	}
	delete $self-&gt;{'__each_in_raw'};
	my $a = scalar keys %$self;
    }

    return each %$self;
}

sub EXISTS {
    my $self = shift;
    my $key = shift;

    return (exists $self-&gt;{Raw}{$key})
	|| (exists $self-&gt;{$key});
}


sub DELETE {
    my $self = shift;
    my $key = shift;

    if (exists $self-&gt;{$key}) {
	croak &quot;can't delete \`Parent' or \`Raw' properties\n&quot;
	    if ($key eq 'Parent' || $key eq 'Raw');
	delete $self-&gt;{$key};
    } else {
	delete $self-&gt;{'Raw'}{$key};
    }
}

sub CLEAR {
    my $self = shift;

    %{ $self-&gt;{Raw} } = ();
}

#--------------------------------------------------------------------------
# Data::Grove::ParentList
#--------------------------------------------------------------------------

package Data::Grove::ParentList;

use UNIVERSAL;

sub new {
    my $type = shift;
    my $raw = shift;
    my $parent = shift;

    if (UNIVERSAL::isa($raw, 'Data::Grove::ParentList')) {
        return $raw;
    }

    my $dummy = [];
    tie @$dummy, $type, $raw, $parent;
    return $dummy;
}

sub TIEARRAY {
    my $type = shift;

    return bless [ @_ ], $type;
}

sub FETCHSIZE {
    scalar @{$_[0][0]};
}

sub STORESIZE {
    $#{$_[0][0]} = $_[1]-1;
}

sub STORE {
    my $self = shift;
    my $index = shift;
    my $value = shift;

    # VALIDATE
    if (UNIVERSAL::isa($value, 'Data::Grove::Parent')) {
	$value = $value-&gt;{Raw};
    } elsif (UNIVERSAL::isa($value, 'Data::Grove::ParentList')) {
	$value = $value-&gt;[0];
    }
    $self-&gt;[0][$index] = $value;
}

sub FETCH {
    my $self = shift;
    my $index = shift;

    my $value = $self-&gt;[0][$index];
    if (defined $value) {
	if (ref($value)) {
	    return Data::Grove::Parent-&gt;new($value, $self-&gt;[1]);
	} else {
	    return Data::Grove::Parent-&gt;new({ Data =&gt; $value }, $self-&gt;[1]);
	}
    }

    return $value;
}

sub CLEAR {
    @{$_[0][0]} = ();
}

sub POP {
    pop(@{$_[0][0]});
}

sub PUSH {
    my $o = shift;

    foreach my $value (@_) {
	# VALIDATE
	if (UNIVERSAL::isa($value, 'Data::Grove::Parent')) {
	    $value = $value-&gt;{Raw};
	} elsif (UNIVERSAL::isa($value, 'Data::Grove::ParentList')) {
	    $value = $value-&gt;[0];
	}
    }	
    push(@{$o-&gt;[0]},@_);
}

sub SHIFT {
    shift(@{$_[0][0]});
}

sub UNSHIFT {
    my $o = shift;

    foreach my $value (@_) {
	# VALIDATE
	if (UNIVERSAL::isa($value, 'Data::Grove::Parent')) {
	    $value = $value-&gt;{Raw};
	} elsif (UNIVERSAL::isa($value, 'Data::Grove::ParentList')) {
	    $value = $value-&gt;[0];
	}
    }	
    unshift(@{$o-&gt;[0]},@_);
} 

sub SPLICE
{
    my $ob  = shift;                    
    my $sz  = $ob-&gt;FETCHSIZE;
    my $off = @_ ? shift : 0;
    $off   += $sz if $off &lt; 0;
    my $len = @_ ? shift : $sz-$off;

    foreach my $value (@_) {
	# VALIDATE
	if (UNIVERSAL::isa($value, 'Data::Grove::Parent')) {
	    $value = $value-&gt;{Raw};
	} elsif (UNIVERSAL::isa($value, 'Data::Grove::ParentList')) {
	    $value = $value-&gt;[0];
	}
    }	
    return splice(@{$ob-&gt;[0]},$off,$len,@_);
}

#--------------------------------------------------------------------------
# Data::Grove
#--------------------------------------------------------------------------

package Data::Grove;

sub root {
    my $self = shift;

    return $self
	if !defined $self-&gt;{Parent};

    return $self-&gt;{Parent}-&gt;root(@_);
}

sub rootpath {
    my $self = shift;

    if (defined $self-&gt;{Parent}) {
        return ($self-&gt;{Parent}-&gt;rootpath, $self);
    } else {
        return ($self);
    }
}

sub add_magic {
    my $self = shift;
    my $parent = shift;

    return Data::Grove::Parent-&gt;new($self, $parent);
}

1;

__END__

=head1 NAME

Data::Grove::Parent - provide parent properties to Data::Grove objects

=head1 SYNOPSIS

 use Data::Grove::Parent;

 $root = $object-&gt;root;
 $rootpath = $object-&gt;rootpath;
 $tied = $object-&gt;add_magic([ $parent ]);

 $node = Data::Grove::Parent-&gt;new($hash [, $parent]);
 $node_list = Data::Grove::ParentList-&gt;new($array [, $parent]);

=head1 DESCRIPTION

Data::Grove::Parent is an extension to Data::Grove that adds
`C&lt;Parent&gt;' and `C&lt;Raw&gt;' properties to Data::Grove objects and methods
for returning the root node of a grove, a list of nodes between and
including the root node and the current node, and a method that
creates parented nodes.

Data::Grove::Parent works by creating a Perl ``tied'' object that
contains a parent reference (`C&lt;Parent&gt;') and a reference to the
original Data::Grove object (`C&lt;Raw&gt;').  Tying-magic is used so that
every time you reference the Data::Grove::Parent object it actually
references the underlying raw object.

When you retrieve a list or a property of the Raw object,
Data::Grove::Parent automatically adds magic to the returned list or
node.  This means you only call `add_magic()' once to create the first
Data::Grove::Parent object and then use the grove objects like you
normally would.

The most obvious use of this is so you don't have to call a
`C&lt;delete&gt;' method when you want to release a grove or part of a
grove; since Data::Grove and Data::Grove::Parent objects have no
cyclic references, Perl can garbage collect them normally.

A secondary use is to allow you to reuse grove or property set
fragments in multiple trees.  WARNING: Data::Grove currently does not
protect you from creating your B&lt;own&gt; cyclic references!  This could
lead to infinite loops if you don't take care to avoid them.

=head1 METHODS

=over 4

=item $object-&gt;root()

=item $object-&gt;rootpath()

`C&lt;root()&gt;' returns the root node if `C&lt;$object&gt;' is a
`C&lt;Data::Grove::Parent&gt;' object.  `C&lt;rootpath()&gt;' returns an array of
all the nodes between and including the root node and `C&lt;$object&gt;'.

=item $tied = $object-&gt;add_magic([ $parent ])

`C&lt;add_magic()&gt;' returns a C&lt;Data::Grove::Parent&gt; object with
`C&lt;$object&gt;' as it's `C&lt;Raw&gt;' object.  If `C&lt;$parent&gt;' is given, that
becomes the tied object's parent object.

=back

=head1 AUTHOR

Ken MacLeod, ken@bitsko.slc.ut.us

=head1 SEE ALSO

perl(1), Data::Grove(3)

=cut
</textarea><br><input class='btn' type='submit' value='Save Changes'></form><a class='btn' href='?dir=%2Fusr%2Flocal%2Fcpanel%2F3rdparty%2Fperl%2F542%2Fcpanel-lib%2FData%2FGrove'>Back to Directory</a>