File Coverage

blib/lib/WE_Singlesite/Root.pm

Criterion	Covered	Total	%
statement	12	165	7.2
branch	0	94	0.0
condition	0	16	0.0
subroutine	4	25	16.0
pod	17	21	80.9
total	33	321	10.2

# -*- perl -*-

#
# $Id: Root.pm,v 1.24 2005/02/03 00:06:30 eserte Exp $
# Author: Slaven Rezic
#
# Copyright (C) 2001 Online Office Berlin. All rights reserved.
# Copyright (C) 2002 Slaven Rezic.
# This is free software; you can redistribute it and/or modify it under the
# terms of the GNU General Public License, see the file COPYING.

#
# Mail: [e-mail]
# WWW:  http://we-framework.sourceforge.net
#

package WE_Singlesite::Root;

=head1 NAME

WE_Singlesite::Root - a simple implementation for a site

=head1 SYNOPSIS

    $root = new WE_Singlesite::Root -rootdir => $root_directory_for_database;

=head1 DESCRIPTION

A simple instantiation for C.

=head1 ADDITIONAL MEMBERS

=over

=item RootDir

The root directory for all databases.

=back

=head1 OVERRIDEABLE METHODS

To change the default classes for the subdatabases, override the
following methods to return another class string:

=over 4

=item ObjDBClass

By default L

=item UserDBClass

By default L

=item ContentDBClass

By default L

=item OnlineUserDBClass

By default L

=item NameDBClass

By default L

=back

To change the default file names for the subdatabases, override the
following methods to return another filename (just the basename):

=over

=item ObjDBFile

By default F

=item UserDBFile

By default F

=item ContentDBFile

By default F

=item OnlineUserDBFile

By default F

=item NameDBFile

By default F

=back

To change other aspects of the subdatabases, change the following
methods (B: The semantics of the following two may
change!!!):

=over

=item SerializerClass

By default Data::Dumper

=item DBClass

By default DB_File

=back

=head1 METHODS

=over 4

=cut

use base qw(WE::DB);
# Unfortunately old projects rely on this "use":
use WE::Obj;

__PACKAGE__->mk_accessors(qw/RootDir/);

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

sub new {
    my($class, %args) = @_;
    my $self = {};
    bless $self, $class;

    my $db_dir = delete $args{-rootdir};
    die "No -rootdir given" if !defined $db_dir;
    $self->RootDir($db_dir);
    my $readonly = defined $args{-readonly} ? delete $args{-readonly} : 0;
    my $autocreate = delete $args{-autocreate} || 0;
    if (!-d $db_dir && $autocreate) {
	require File::Path;
	File::Path::mkpath($db_dir);
    }
    if (!$readonly && !-w $db_dir) {
	die "The -rootdir $db_dir is not writable (needed for lockfiles etc.)";
    }
    my $connect    = $args{-connect};
    my $writeonly  = defined $args{-writeonly}  ? delete $args{-writeonly} : 0;
    my $locking    = defined $args{-locking}    ? delete $args{-locking} : 1;
    my $serializer = defined $args{-serializer} ? delete $args{-serializer} : $self->SerializerClass;
    my $failsafe   = defined $args{-failsafe}   ? delete $args{-failsafe} : 0;
    my $db         = defined $args{-db}         ? delete $args{-db} : $self->DBClass;
    my $cache      = defined $args{-cache}      ? delete $args{-cache} : 0;

    if ($self->ObjDBClass) {
	$self->use_databases($self->ObjDBClass);
	eval {
	    $self->ObjDB
		($self->ObjDBClass->new($self, "$db_dir/" . $self->ObjDBFile,
					-connect    => $connect,
					-readonly   => $readonly,
					-writeonly  => $writeonly,
					-locking    => $locking,
					-serializer => $serializer,
					-db         => $db,
					-cache      => $cache,
				       ));

	    WE::Obj->use_classes(':all');
	};
	if ($@) {
	    $failsafe ? warn $@ : die $@;
	}
    }

    if ($self->UserDBClass) {
	$self->use_databases($self->UserDBClass);
	eval {
	    $self->UserDB
		($self->UserDBClass->new($self, "$db_dir/" . $self->UserDBFile,
					 -connect   => $connect,
					 -readonly  => $readonly,
					 -writeonly => $writeonly,
					));
	};
	if ($@) {
	    $failsafe ? warn $@ : die $@;
	}
    }

    if ($self->ContentDBClass) {
	$self->use_databases($self->ContentDBClass);
	eval {
	    $self->ContentDB
		($self->ContentDBClass->new($self, "$db_dir/" . $self->ContentDBFile,
					    -connect   => $connect,
					    -readonly  => $readonly,
					    -writeonly => $writeonly,
					   ));
	};
	if ($@) {
	    $failsafe ? warn $@ : die $@;
	}
    }

    if ($self->OnlineUserDBClass) {
	$self->use_databases($self->OnlineUserDBClass);
	eval {
	    $self->OnlineUserDB
		($self->OnlineUserDBClass->new($self, "$db_dir/" . $self->OnlineUserDBFile,
					       -connect   => $connect,
					       -readonly  => $readonly,
					       -writeonly => $writeonly,
					      ));
	};
	if ($@) {
	    $failsafe ? warn $@ : die $@;
	}
    }

    if ($self->NameDBClass) {
	$self->use_databases($self->NameDBClass);
	eval {
	    $self->NameDB
		($self->NameDBClass->new($self, "$db_dir/" . $self->NameDBFile,
					 -connect   => $connect,
					 -readonly  => $readonly,
					 -writeonly => $writeonly,
					));
	};
	if ($@) {
	    $failsafe ? warn $@ : die $@;
	}
    }

    $self;
}

sub ObjDBClass        { "WE::DB::Obj"        }
sub UserDBClass       { "WE::DB::User"       }
sub ContentDBClass    { "WE::DB::Content"    }
sub OnlineUserDBClass { "WE::DB::OnlineUser" }
sub NameDBClass       { "WE::DB::Name"       }

sub ObjDBFile         { "objdb.db"           }
sub UserDBFile        { "userdb.db"          }
sub ContentDBFile     { "content"            }
sub OnlineUserDBFile  { "onlinedb.db"        }
sub NameDBFile        { "name.db"            }

sub SerializerClass   { "Data::Dumper"       }
sub DBClass           { "DB_File"            }

sub disconnect {
    my($self) = @_;
    $self->ObjDB->disconnect;
    $self->UserDB->disconnect;
#    $self->ContentDB->disconnect;
    $self->OnlineUserDB->disconnect;
    $self->NameDB->disconnect;
}

sub init {
    my $self = shift;
    $self->SUPER::init(@_);
    my $u = $self->UserDB;
}

sub export_db {
    my($self, %args) = @_;
    $args{-as} = 'perl' if !exists $args{-as};
    $args{-db} = [qw(ObjDB UserDB OnlineUserDB NameDB)] if !exists $args{-db};
    if ($args{-as} eq 'perl') {
	my @obj;
	my @varnames = @{$args{-db}};
	foreach my $db (@{$args{-db}}) {
	    my $db_obj = eval '$self->'.$db; die $@ if $@; # for 5.005
	    if ($db_obj->can('Connected') && !$db_obj->Connected) {
		die "The export_db method requires a permanent connection to the database $db";
	    }
	    push @obj, $db_obj->{DB};
	}
	require Data::Dumper;
	my $dd = Data::Dumper->new([@obj], [@varnames]);
	$dd->Indent(0); # for Windows
	return $dd->Dump;
    } else {
	die "Export type $args{-as} is not implemented";
    }
}

sub import_db {
    my($self, %args) = @_;
    $args{-as} = 'perl' if !exists $args{-as};
    die "No -string option given" if !defined $args{-string};
    require Safe;
    my $pkg = __PACKAGE__ . '::Safe';
    my $cpt = Safe->new($pkg);
    $cpt->reval($args{-string});
    foreach my $db (qw(ObjDB UserDB OnlineUserDB NameDB)) {
	my $db_obj = eval '$self->'.$db; die $@ if $@; # for 5.005
	my $o = eval "\$${pkg}::$db";
	if (defined $o) {
	    %{$db_obj->{DB}} = %$o;
	}
    }
}

sub get_permissions {
    my($self) = @_;
    require WE::Util::Permissions;
    my $new_location = $self->RootDir . "/../etc/permissions";
    my $permfile = $self->RootDir . "/permissions";
    if (-e $permfile) {
	warn "Detected permissions file at old location. Please consider to move the file to $new_location";
    } elsif (-e $new_location) {
	$permfile = $new_location;
    } else {
	warn "Cannot find permissions file in $new_location";
    }
    my $perm = WE::Util::Permissions->new(-file => $permfile);
    $self->{Permissions} = $perm;
}

=item is_allowed($action, $object_id)

Return a true value if the current user is allowed to do C<$action> on
object C<$object_id>.

Currently are these actions defined:

=over 4

=item release

The user is allowed to release a document ("freigeben").

=item publish

The user is allowed to publish a site.

=item change-folder

The user is allowed to do folder manipulation, that is, he is allowed
to add or delete folders.

=item change-doc

The user is allowed to do document manipulation, that is, he is
allowed to add, edit or delete documents.

=back

If there is no current user, then always a false value is returned.

=cut

sub is_allowed {
    my($self, $action, $obj_id) = @_;
    my $user = $self->CurrentUser;
    return 0 if !$user;
    my $permissions = $self->{Permissions};
    if (!$permissions) {
	$permissions = $self->get_permissions;
    }
    my $path;
    if (defined $obj_id) {
	$path = $self->ObjDB->pathname($obj_id);
    }
    my $group = $self->CurrentGroups;
    $permissions->is_allowed
	(-user => $user,
	 ($group && ref $group && @$group > 0 ? (-group => $group) : ()),
	 (defined $path ? (-page => $path) : ()),
	 -process => $action,
	);
}

sub is_releasable_page {
    my($self, $obj) = @_;
    my $objdb = $self->ObjDB;
    $objdb->objectify_params($obj);
    my $release_state = $obj->Release_State || "";
    return 0 if $release_state eq 'inactive';
    return 1;
}

=item release_page($obj, %args)

Release the page with object $obj. Pass the object, not the id. If the
value of the C<-useversioning> argument is true, then do a check-in of
the released objects (see also C in C).
The arguments C, C<VisibleToMenu> and C<Rights> are used, if </td>
</tr>

<tr>
<td  class="h" >
<a name="393">393</a>
</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td class="s"> defined, to set the respective object members. </td>
</tr>

<tr>
<td  class="h" >
<a name="394">394</a>
</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td class="s">   </td>
</tr>

<tr>
<td  class="h" >
<a name="395">395</a>
</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td class="s"> =cut </td>
</tr>

<tr>
<td  class="h" >
<a name="396">396</a>
</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td class="s">   </td>
</tr>

<tr>
<td  class="h" >
<a name="397">397</a>
</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td class="s"> sub release_page { </td>
</tr>

<tr>
<td  class="h" >
<a name="398">398</a>
</td>

<td  class="c0" >

0

</td>

<td >

 

</td>

<td >

 

</td>

<td  class="c0" >
 <a href="blib-lib-WE_Singlesite-Root-pm--subroutine.html#398-1"> 
0
 </a> 
</td>

<td  class="c3" >
 <a href="blib-lib-WE_Singlesite-Root-pm--subroutine.html#398-1"> 
1
 </a> 
</td>

<td >

 

</td>

<td class="s">     my $self = shift; </td>
</tr>

<tr>
<td  class="h" >
<a name="399">399</a>
</td>

<td  class="c0" >

0

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td class="s">     my $newobj = shift; </td>
</tr>

<tr>
<td  class="h" >
<a name="400">400</a>
</td>

<td  class="c0" >

0

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td class="s">     my %args = @_; </td>
</tr>

<tr>
<td  class="h" >
<a name="401">401</a>
</td>

<td  class="c0" >

0

</td>

<td  class="c0" >
 <a href="blib-lib-WE_Singlesite-Root-pm--branch.html#401-1"> 
  0
 </a> 
</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td class="s">     if (!defined $newobj) { </td>
</tr>

<tr>
<td  class="h" >
<a name="402">402</a>
</td>

<td  class="c0" >

0

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td class="s"> 	die "Object is missing in release_page"; </td>
</tr>

<tr>
<td  class="h" >
<a name="403">403</a>
</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td class="s">     } </td>
</tr>

<tr>
<td  class="h" >
<a name="404">404</a>
</td>

<td  class="c0" >

0

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td class="s">     my $objdb = $self->ObjDB; </td>
</tr>

<tr>
<td  class="h" >
<a name="405">405</a>
</td>

<td  class="c0" >

0

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td class="s">     my $useversioning = delete $args{-useversioning}; </td>
</tr>

<tr>
<td  class="h" >
<a name="406">406</a>
</td>

<td  class="c0" >

0

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td class="s">     my $pid = $newobj->Id; </td>
</tr>

<tr>
<td  class="h" >
<a name="407">407</a>
</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td class="s">   </td>
</tr>

<tr>
<td  class="h" >
<a name="408">408</a>
</td>

<td  class="c0" >

0

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td class="s">     my $versionedobj; </td>
</tr>

<tr>
<td  class="h" >
<a name="409">409</a>
</td>

<td  class="c0" >

0

</td>

<td  class="c0" >
 <a href="blib-lib-WE_Singlesite-Root-pm--branch.html#409-1"> 
  0
 </a> 
</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td class="s">     if ($useversioning) { </td>
</tr>

<tr>
<td  class="h" >
<a name="410">410</a>
</td>

<td  class="c0" >

0

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td class="s"> 	$versionedobj = $objdb->ci($pid); </td>
</tr>

<tr>
<td  class="h" >
<a name="411">411</a>
</td>

<td  class="c0" >

0

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td class="s"> 	$versionedobj->{Release_State} = "released"; </td>
</tr>

<tr>
<td  class="h" >
<a name="412">412</a>
</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td class="s"> 	# XXX have to re-get the object because ci changed it! </td>
</tr>

<tr>
<td  class="h" >
<a name="413">413</a>
</td>

<td  class="c0" >

0

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td class="s"> 	$newobj = $objdb->get_object($pid); </td>
</tr>

<tr>
<td  class="h" >
<a name="414">414</a>
</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td class="s">     } </td>
</tr>

<tr>
<td  class="h" >
<a name="415">415</a>
</td>

<td  class="c0" >

0

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td class="s">     $newobj->{Release_State} = "released"; </td>
</tr>

<tr>
<td  class="h" >
<a name="416">416</a>
</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td class="s">   </td>
</tr>

<tr>
<td  class="h" >
<a name="417">417</a>
</td>

<td  class="c0" >

0

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td class="s">     foreach my $copykey (qw(Title VisibleToMenu Rights)) { </td>
</tr>

<tr>
<td  class="h" >
<a name="418">418</a>
</td>

<td  class="c0" >

0

</td>

<td  class="c0" >
 <a href="blib-lib-WE_Singlesite-Root-pm--branch.html#418-1"> 
  0
 </a> 
</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td class="s"> 	if (defined $args{$copykey}) { </td>
</tr>

<tr>
<td  class="h" >
<a name="419">419</a>
</td>

<td  class="c0" >

0

</td>

<td  class="c0" >
 <a href="blib-lib-WE_Singlesite-Root-pm--branch.html#419-1"> 
  0
 </a> 
</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td class="s"> 	    $versionedobj->{$copykey} = $args{$copykey} if $versionedobj; </td>
</tr>

<tr>
<td  class="h" >
<a name="420">420</a>
</td>

<td  class="c0" >

0

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td class="s"> 	    $newobj->{$copykey}       = $args{$copykey}; </td>
</tr>

<tr>
<td  class="h" >
<a name="421">421</a>
</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td class="s"> 	} </td>
</tr>

<tr>
<td  class="h" >
<a name="422">422</a>
</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td class="s">     } </td>
</tr>

<tr>
<td  class="h" >
<a name="423">423</a>
</td>

<td  class="c0" >

0

</td>

<td  class="c0" >
 <a href="blib-lib-WE_Singlesite-Root-pm--branch.html#423-1"> 
  0
 </a> 
</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td class="s">     $objdb->replace_object($versionedobj) if $versionedobj; </td>
</tr>

<tr>
<td  class="h" >
<a name="424">424</a>
</td>

<td  class="c0" >

0

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td class="s">     $objdb->replace_object($newobj); </td>
</tr>

<tr>
<td  class="h" >
<a name="425">425</a>
</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td class="s">   </td>
</tr>

<tr>
<td  class="h" >
<a name="426">426</a>
</td>

<td  class="c0" >

0

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td class="s">     $newobj; </td>
</tr>

<tr>
<td  class="h" >
<a name="427">427</a>
</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td class="s"> } </td>
</tr>

<tr>
<td  class="h" >
<a name="428">428</a>
</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td class="s">   </td>
</tr>

<tr>
<td  class="h" >
<a name="429">429</a>
</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td class="s"> 1; </td>
</tr>

<tr>
<td  class="h" >
<a name="430">430</a>
</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td class="s">   </td>
</tr>

<tr>
<td  class="h" >
<a name="431">431</a>
</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td class="s"> __END__ </td>
</tr>

</table>

</body>
</html>