File Coverage

blib/lib/WE/DB/ObjBase.pm

Criterion	Covered	Total	%
statement	12	205	5.8
branch	0	78	0.0
condition	0	18	0.0
subroutine	4	24	16.6
pod	17	18	94.4
total	33	343	9.6

# -*- perl -*-

#
# $Id: ObjBase.pm,v 1.16 2004/02/19 22:26:53 eserte Exp $
# Author: Slaven Rezic
#
# Copyright (C) 2002 Slaven Rezic. All rights reserved.
# This package is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
# Mail: [e-mail]
# WWW:  http://www.rezic.de/eserte/
#

=head1 NAME

WE::DB::ObjBase - base class for WE_Framework object databases

=head1 SYNOPSIS

    use base qw(WE::DB::ObjBase);

=head1 DESCRIPTION

=cut

package WE::DB::ObjBase;
use base qw(WE::DB::Base);

use strict;
use vars qw($VERSION);
$VERSION = sprintf("%d.%02d", q$Revision: 1.16 $ =~ /(\d+)\.(\d+)/);

use WE::Util::Date;

=head2 METHODS

Please see also L for inherited methods.

=over

=cut

=item children($object_id)

Like children_ids, but return objects.

=cut

sub children {
    my($self, $obj_id) = @_;
    map {
	my $o = $self->get_object($_);
	if (!$o) {
	    my $obj_id = $obj_id;
	    my $child_id = $_;
	    $self->idify_params($obj_id, $child_id);
	    warn "Inconsistency in children method call for objid=$obj_id detected: child with objid=$child_id non-existent. Consider to run we_fsck. Error";
	    ();
	} else {
	    $o;
	}
    } $self->children_ids($obj_id);
}

=item parents($object_id)

Like parent_ids, but return parent objects instead.

=cut

sub parents {
    my($self, $obj_id) = @_;
    map {
	my $o = $self->get_object($_);
	if (!$o) {
	    warn "Inconsistency in parents($obj_id) detected";
	    ();
	} else {
	    $o;
	}
    } $self->parent_ids($obj_id);
}

=item versions($object_id)

Like version_ids, but return version objects instead.

=cut

sub versions {
    my($self, $obj_id) = @_;
    map {
	my $o = $self->get_object($_);
	if (!$o) {
	    warn "Inconsistency in versions($obj_id) detected";
	    ();
	} else {
	    $o;
	}
    } $self->version_ids($obj_id);
}

=item objectify_params($id_or_obj, ...)

For each parameter in the list, change the argument to be an object of
the database.

=cut

sub objectify_params {
    my $self = shift;
    foreach (@_) {
	if (!UNIVERSAL::isa($_, "WE::Obj")) {
	    $_ = $self->get_object($_);
	}
    }
}

=item idify_params($id_or_obj, ...)

For each parameter in the list, change the argument to be an object
identifier if it was an object, or leave it as it was.

=cut

sub idify_params {
    my $self = shift;
    foreach (@_) {
	if (UNIVERSAL::isa($_,"WE::Obj")) {
	    $_ = $_->Id;
	}
    }
}

=item replace_content_from_file($object_id, $filename)

Like replace_content, but get contents from file.

=cut

sub replace_content_from_file {
    my($self, $objid, $filename) = @_;
    $self->idify_params($objid);
    open(F, $filename) or die "Can't open file $filename: $!";
    local $/ = undef;
    my $new_content = ;
    close F;
    $self->replace_content($objid, $new_content);
}

=item walk($object_id, $sub_routine, @args)

Traverse the object hierarchie, beginning at the object with id
C<$object_id>. For each object, C<$sub_routine> is called with the
object id and optional C<@args>. Note that the subroutine is B
called for the start object itself.

If there's no persistent connection to the database (i.e. the database
was not accessed with -connect => 1), then using
B is advisable for better performance.

Here are some examples for using walk.

Get the number of descendent objects from the folder with Id
C<$folder_id>. The result is in the C<$obj_count> variable:

    my $obj_count = 0;
    $objdb->walk($folder_id, sub {
		     my($id, $ref) = @_;
		     $$ref++;
		 }, \$obj_count);
    warn "There are $obj_count objects in $folder_id\n";

Get all released descendant objects. The released state should be
recorded in the Release_State member. The resulting list is a flat
array.

    my @results;
    $objdb->walk($folder_id, sub {
		     my($id) = @_;
                     my $obj = $objdb->get_object($id);
		     if ($obj->Release_State eq 'released') {
			 push @results, $obj;
		     }
		 });
    # The released objects are in @results.

If you want to break the recursion on a condition, simply use an
C-block and C on the condition. See the source code of
C method for an example.

C uses postorder traversal, that is, subtrees first, node later.

Note that the start object itself is not included in the traversal and
the subroutine will not be called for it.

The returned value of the last callback called with be returned.

=item walk_preorder($object_id, $sub_routine, @args)

This is like C, but uses preorder instead of postorder, that is,
node first, children later.

Note that the start object itself will be included in the traversal.
This is different from the C method.

In preorder walk, the traversal of subtrees can be avoided by setting
the global variable C<$WE::DB::Obj::prune> to a true value.

=cut

sub walk {
    my($self, $objid, $sub_routine, @args) = @_;
    my $ret;
    $self->idify_params($objid);
    if (!UNIVERSAL::isa($sub_routine, 'CODE')) {
	die "Second parameter of walk should be code reference";
    }
    for my $sub_obj_id ($self->children_ids($objid)) {
	$self->walk($sub_obj_id, $sub_routine, @args);
	$ret = $sub_routine->($sub_obj_id, @args);
    }
    $ret;
}

sub walk_preorder {
    my($self, $objid, $sub_routine, @args) = @_;
    my $ret;
    $self->idify_params($objid);
    if (!UNIVERSAL::isa($sub_routine, 'CODE')) {
	die "Second parameter of walk_preorder should be code reference";
    }

    {
	local $WE::DB::Obj::prune;
	$ret = $sub_routine->($objid, @args);
	return $ret if $WE::DB::Obj::prune;
    }

    for my $sub_obj_id ($self->children_ids($objid)) {
	$ret = $self->walk_preorder($sub_obj_id, $sub_routine, @args);
    }
    $ret;
}

# XXX Document, and implement walk_up_prepostorder when needed!
sub walk_prepostorder {
    my($self, $objid, $pre_sub_routine, $post_sub_routine, @args) = @_;
    my $ret;
    $self->idify_params($objid);
    if (!UNIVERSAL::isa($pre_sub_routine, 'CODE') ||
	!UNIVERSAL::isa($post_sub_routine, 'CODE')) {
	die "Second and third parameters of walk_prepostorder should be code references";
    }

    {
	local $WE::DB::Obj::prune;
	$ret = $pre_sub_routine->($objid, @args);
	return $ret if $WE::DB::Obj::prune;
    }

    for my $sub_obj_id ($self->children_ids($objid)) {
	$ret = $self->walk_prepostorder($sub_obj_id, $pre_sub_routine, $post_sub_routine, @args);
    }

    {
	local $WE::DB::Obj::prune;
	$ret = $post_sub_routine->($objid, @args);
	return $ret if $WE::DB::Obj::prune;
    }

    $ret;
}

=item walk_up($object_id, $sub_routine, @args)

Same as C, but walk the tree up, that is, traverse all parents
from the object to the root.


=item walk_up_preorder($object_id, $sub_routine, @args)

Same as C, but traverse in pre-order, that is, from the
object to the root. Note that the object itself is also included in
the traversal.

In preorder walk, the further traversal of parents can be avoided by
setting the global variable C<$WE::DB::Obj::prune> to a true value.

=cut

sub walk_up {
    my($self, $objid, $sub_routine, @args) = @_;
    my $ret;
    $self->idify_params($objid);
    if (!UNIVERSAL::isa($sub_routine, 'CODE')) {
	die "Second parameter of walk_up should be code reference";
    }
    for my $p_obj_id ($self->parent_ids($objid)) {
	$self->walk_up($p_obj_id, $sub_routine, @args);
	$ret = $sub_routine->($p_obj_id, @args);
    }
    $ret;
}

sub walk_up_preorder {
    my($self, $objid, $sub_routine, @args) = @_;
    my $ret;
    $self->idify_params($objid);
    if (!UNIVERSAL::isa($sub_routine, 'CODE')) {
	die "Second parameter of walk_up_preorder should be code reference";
    }

    local $WE::DB::Obj::prune;
    $ret = $sub_routine->($objid, @args);
    return $ret if $WE::DB::Obj::prune;

    for my $p_obj_id ($self->parent_ids($objid)) {
	if (defined $p_obj_id) {
	    $ret = $self->walk_up_preorder($p_obj_id, $sub_routine, @args);
	}
    }
    $ret;
}

=item whole_tree([$objid])

Return the whole (sub)tree of C<$objid>. If C<$objid> is not given,
then return the whole tree. The elements of the tree are structured in
a nested array. Each element is a hash of the following elements: Id,
Title and isFolder.

=cut

sub whole_tree {
    my($self, $objid, $tree) = @_;
    $objid = $self->root_object->id if !defined $objid;
    $tree  = [] if !$tree;
    my $obj = $self->get_object($objid);
    if (!$obj) {
	warn "Can't get object $objid!";
	return;
    }
    push @$tree, {Id=>$obj->Id, Title=>$obj->Title, isFolder=>$obj->is_folder};
    my @children_ids = $self->children_ids($objid);
    if (@children_ids) {
	my $child_tree = [];
	foreach my $cid (@children_ids) {
	    $self->whole_tree($cid, $child_tree);
	}
	push @$tree, $child_tree;
    }
    $tree;
}

=item _undirty($object)

Return the object with all Dirty flags set to 0.

=cut

sub _undirty {
    my($self, $obj) = @_;
    $self->objectify_params($obj);
    $obj->Dirty(0);
    $obj->DirtyAttributes(0);
    $obj->DirtyContent(0);
    $self->replace_object($obj);
}

=item is_locked($object_id)

Return true if the object is locked by someone else.

=cut

sub is_locked {
    my($self, $obj) = @_;
    $self->objectify_params($obj);
    return 0 if !defined $obj->LockedBy || $obj->LockedBy eq '';
    return 0 if $obj->LockedBy eq $self->Root->CurrentUser;
    if ($obj->LockType eq 'SessionLock') {
	if ($self->Root->OnlineUserDB) {
	    my $r = $self->Root->OnlineUserDB->check_logged($obj->LockedBy);
	    if (!$r) {
		$self->unlock($obj); # XXX -force => 1 ???
	    }
	    return $r;
	} else {
	    return 0;
	}
    }
    return 1 if ($obj->LockType eq 'PermanentLock'); # XXX probably check for existing user?
    warn "Unknown lock type @{[ $obj->LockType ]}, assumed locked";
    1;
}

=item lock($object_id, -type => $lock_type)

Lock the object C<$object_id>. Only single objects can be locked (no
folder hierarchies). Locking must be handled in the client by using
C. The C<$lock_type> may have the following values:

=over 4

=item SessionLock

This lock should only be valid for this session. If the user closes
the session (either by a logout or by closing the browser window),
then the lock will be invalidated.

=item PermanentLock

This lock lasts over session ends.

=back

Return the object itself.

Now, it should be checked programmatically whether the lock can be set
or not (by looking at the value is_locked). It is not clear what is
the right solution, because there are version control systems where
breaking locks is possible (RCS).

=cut

sub lock {
    my($self, $obj_id, %args) = @_;
    die "Lock -type is missing" if !$args{-type};
    die "Valid Lock types are SessionLock and PermanentLock"
	unless $args{-type} =~ /^(Session|Permanent)Lock$/;
    $self->idify_params($obj_id);
    my $obj = $self->get_object($obj_id);
    $obj->LockedBy($self->Root->CurrentUser);
    $obj->LockType($args{-type});
    $obj->LockTime(epoch2isodate());
    $self->replace_object($obj);
}

=item unlock($object_id)

Unlock the object with id C<$object_id>.

Return the object itself.

Now, it should be checked programmatically whether the lock can be
unset or not (by looking at the value is_locked). It is not clear what
is the right solution, because there are version control systems where
breaking locks is possible (RCS).

=cut

sub unlock {
    my($self, $obj_id) = @_;
    $self->idify_params($obj_id);
    my $obj = $self->get_object($obj_id);
    $obj->LockedBy(undef);
    $obj->LockType(undef);
    $obj->LockTime(undef);
    $self->replace_object($obj);
}

=item pathobjects($object_or_id [, $parent_obj])

For the object or id C<$object_or_id>, the object path is returned.
This is similar to the C method, but returns a list of
objects instead of a pathname.

If C<$parent_obj> is given as a object, then the returned pathname is
only a partial path starting from this parent object.

=cut

sub pathobjects {
    my($self, $obj, $parent_obj) = @_;
    $self->objectify_params($obj);
    if (defined $parent_obj && $obj->Id eq $parent_obj->Id) {
	return ();
    }
    my @parents = $self->parent_ids($obj->Id);
    if (@parents) {
	($self->pathobjects($parents[0], $parent_obj), $obj);
    } else {
	($obj);
    }
}

=item pathobjects_with_cache($object_or_id [, $parent_obj], $cache_hash_ref)

As C, but also use a cache for a faster access.

=cut

sub pathobjects_with_cache {
    my($self, $obj, $parent_obj, $cache) = @_;
    if (!ref $obj && exists $cache->{$obj}) { # get by id
	return @{ $cache->{$obj} };
    }
    $self->objectify_params($obj);
    return () if !$obj;
    my $objid = $obj->Id;
    if (exists $cache->{$objid}) {
	return @{ $cache->{$objid} };
    }
    if (defined $parent_obj && $objid eq $parent_obj->Id) {
	$cache->{$obj->Id} = [];
	return ();
    }
    my @parents = $self->parent_ids($objid);
    if (@parents) {
	if (exists $cache->{$parents[0]}) {
	    (@{ $cache->{$parents[0]} }, $obj);
	} else {
	    my @parent_parents = $self->pathobjects_with_cache($parents[0], $parent_obj);
	    $cache->{$parents[0]} = [@parent_parents];
	    (@parent_parents, $obj);
	}
    } else {
	($obj);
    }
}

=item name_to_objid($name)

Return the object id for the object containing the Attribute
C. If there is no such object, undef is returned. Note: This
method may or may not be efficient, depending whether there is an
index database (C) or not.

=cut

sub name_to_objid {
    my($self, $name) = @_;
    my $objid;
    if ($self->Root->NameDB) {
	$objid = $self->Root->NameDB->get_id($name);
	return $objid if defined $objid;
    }
    # for backward compatibility (database without name.db)
    eval {
	local $SIG{__DIE__};
	$self->walk($self->root_object->Id, sub {
			my($id) = @_;
			my $obj = $self->get_object($id);
			if (defined $obj->Name && $obj->Name eq $name) {
			    $objid = $obj->Id;
			    die "Found";
			}
		    });
    };
    $objid;
}

1;

__END__