# -*- 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: slaven@rezic.de
# 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<WE::DB>.
=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<WE::DB::Obj>
=item UserDBClass
By default L<WE::DB::User>
=item ContentDBClass
By default L<WE::DB::Content>
=item OnlineUserDBClass
By default L<WE::DB::OnlineUser>
=item NameDBClass
By default L<WE::DB::Name>
=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<objdb.db>
=item UserDBFile
By default F<userdb.db>
=item ContentDBFile
By default F<content>
=item OnlineUserDBFile
By default F<onlinedb.db>
=item NameDBFile
By default F<name.db>
=back
To change other aspects of the subdatabases, change the following
methods (B<WARNING>: 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<useversioning> in C<WEprojectinfo>).
The arguments C<Title>, C<VisibleToMenu> and C<Rights> are used, if
defined, to set the respective object members.
=cut
sub release_page {
my $self = shift;
my $newobj = shift;
my %args = @_;
if (!defined $newobj) {
die "Object is missing in release_page";
}
my $objdb = $self->ObjDB;
my $useversioning = delete $args{-useversioning};
my $pid = $newobj->Id;
my $versionedobj;
if ($useversioning) {
$versionedobj = $objdb->ci($pid);
$versionedobj->{Release_State} = "released";
# XXX have to re-get the object because ci changed it!
$newobj = $objdb->get_object($pid);
}
$newobj->{Release_State} = "released";
foreach my $copykey (qw(Title VisibleToMenu Rights)) {
if (defined $args{$copykey}) {
$versionedobj->{$copykey} = $args{$copykey} if $versionedobj;
$newobj->{$copykey} = $args{$copykey};
}
}
$objdb->replace_object($versionedobj) if $versionedobj;
$objdb->replace_object($newobj);
$newobj;
}
1;
__END__
=back
=head1 HISTORY
Historically this module preloaded the standard ObjDB, UserDB,
ContentDB, OnlineUserDB and NameDB classes with C<<
WE::DB->use_databases >>. Since about 2005-01-23 this modules are only
preloaded if actually needed (that is, on construction time). This
means that some inherited modules which depend on this preloading
should do the preloading itself now.
=head1 CAVEATS
See incompatible change in L</HISTORY>.
=head1 AUTHOR
Slaven Rezic - slaven@rezic.de
=head1 SEE ALSO
L<WE::DB>.
=cut