###########################################
package HTML::Merge::Engine;
###########################################
# Modules #################################
use Carp;
use strict;
use vars qw(%cookies $suffix @objects @matrices @say
$INTERNAL_DB $INTERNAL_DSN);
# My Modules ##############################
use HTML::Merge::Error;
# Globals #################################
@objects = qw(user group subsite instance realm template say);
@matrices = qw(user_group user_realm group_realm
realm_template template_subsite realm_subsite);
@say = qw(group join:part realm been_grant:been_revoke
_realm protect:release subsite attach:detach);
$INTERNAL_DB='merge.db';
###########################################
sub Order (\$\$);
###########################################
sub AddSuffix
{
$suffix .= shift;
}
###########################################
sub DumpSuffix
{
my ($template, $line_num) = @$HTML::Merge::context;
eval '
if ($template =~ /\.$HTML::Merge::Ini::DEV_EXTENSION$/)
{
print $suffix;
}
';
&DumpCookies;
}
###########################################
sub DumpCookies
{
my $expire=$HTML::Merge::Ini::SESSION_TIMEOUT;
my $t;
my ($name, $val);
while (($name, $val) = each %cookies)
{
print "\n";
}
}
###########################################
sub new
{
my ($class) = @_;
my $self = {};
$self->{dbh} = undef; # Application database
$self->{sys_dbh} = undef; # System database handle
$self->{sth} = undef; # SQL statment handler
$self->{dsn} = undef; # The application dsn string
$self->{cred} = undef;
bless $self, $class;
}
###########################################
sub CreateObject
{
my $class = shift;
my %array;
tie %array, $class;
return $array{""};
}
###########################################
sub TIEHASH
{
my ($class) = @_;
my $this = {'storage' => {}};
%cookies = ();
$suffix = '';
bless $this, $class;
}
###########################################
sub FETCH
{
my ($self, $key) = @_;
$key ||= 0;
my $class = ref($self);
my $storage = $self->{'storage'};
if (exists $storage->{$key} && &UNIVERSAL::isa($storage->{$key},
$class))
{
return $storage->{$key};
}
$storage->{$key} = $class->new;
$storage->{$key}->Preconnect;
return $storage->{$key};
}
###########################################
sub DELETE
{
my ($self, $key) = @_;
my $storage = $self->{'storage'};
delete $storage->{$key};
}
###########################################
sub DESTROY
{
my $self = shift;
# Are we an item?
my $sth = $self->{'sth'};
if ($sth)
{
eval { $sth->finish; };
delete $self->{'sth'};
}
my $dbh = $self->{'dbh'};
if ($dbh)
{
$dbh->disconnect;
delete $self->{'dbh'};
}
# Are we the tied hash?
my $storage = $self->{'storage'};
if ($storage)
{
%$storage = ();
delete $self->{'storage'};
}
}
###########################################
sub CLEAR
{
my $self = shift;
$self->{'storage'} = {};
}
###########################################
sub Preconnect
{
my ($self, $dbtype, $db, $dbhost, $user, $password) = @_;
$dbtype ||= $HTML::Merge::Ini::DB_TYPE;
$dbhost ||= $HTML::Merge::Ini::DB_HOST;
$user ||= $HTML::Merge::Ini::DB_USER;
$password ||= &Convert($HTML::Merge::Ini::DB_PASSWORD2)
|| $HTML::Merge::Ini::DB_PASSWORD;
$db ||= $HTML::Merge::Ini::DB_DATABASE;
$self->{'dsn'} = ['dbi', $dbtype, $db, $dbhost];
$self->{'cred'} = [$user, $password];
$self->{'dbh'} = undef;
$self->{'sth'} = undef;
}
###########################################
sub DoConnect
{
my $self = shift;
return if $self->{'dbh'};
require DBI;
my $dsn = join(":", grep /./, @{$self->{'dsn'}});
my ($user, $password) = @{$self->{'cred'}};
my $dbh = DBI->connect($dsn, $user, $password, {'AutoCommit' =>
$HTML::Merge::Ini::AUTO_COMMIT}) ||
HTML::Merge::Error::HandleError('ERROR', $DBI::errstr);
$self->{'dbh'} = $dbh;
$self->{'sth'} = undef;
}
###########################################
sub Statement
{
my ($self, $sql) = @_;
HTML::Merge::Error::HandleError('INFO', $sql, 'SQL');
my $dbh = $self->DBH;
$dbh->do($sql) ||
return HTML::Merge::Error::HandleError('ERROR', $DBI::errstr);
}
###########################################
sub Query
{
my ($self, $sql) = @_;
HTML::Merge::Error::HandleError('INFO', $sql, 'SQL');
$self->{'sth'} = undef;
$self->{'fields'} = {};
my $dbh = $self->DBH();
my $sth = $dbh->prepare($sql) ||
return HTML::Merge::Error::HandleError('ERROR', $DBI::errstr);
$sth->execute ||
return HTML::Merge::Error::HandleError('ERROR', $DBI::errstr);
$self->{'sth'} = $sth;
$self->{'fields'} = $sth->fetchrow_hashref;
$self->{'fields'} ||= {};
$self->{'empty'} = !%{$self->{'fields'}};
$self->{'buffer'} = [$self->{'fields'}];
$self->{'index'} = 0;
}
###########################################
sub HasQuery
{
my $self = shift;
$self->{'sth'} ? 1 : 0;
}
###########################################
sub Empty
{
my $self = shift;
$self->{'empty'};
}
###########################################
sub Fetch
{
my ($self, $explicit, $atrow) = @_;
my $sth = $self->{'sth'};
return HTML::Merge::Error::HandleError('WARN', 'ILLEGAL_FETCH') unless ($sth);
$self->{'index'}++;
if ($explicit)
{
$self->{'buffer'} = undef;
return !$self->{'empty'} if ($atrow == 1);
}
my $candidate = $self->{'buffer'};
if ($candidate)
{
$self->{'buffer'} = undef;
$self->{'fields'} = $candidate->[0];
return %{$self->{'fields'}} ? 1 : undef;
}
my $hash = $sth->fetchrow_hashref;
unless ($hash)
{
$self->{'index'}--;
# $self->{'fields'} = {};
return undef;
}
$self->{'fields'} = $hash;
return 1;
}
###########################################
sub ReRun
{
my $self = shift;
my $sth = $self->{'sth'};
return HTML::Merge::Error::HandleError('WARN', 'ILLEGAL_FETCH') unless ($sth);
$sth->execute;
$self->{'fields'} = $sth->fetchrow_hashref;
$self->{'fields'} ||= {};
$self->{'buffer'} = [$self->{'fields'}];
$self->{'index'} = 0;
}
###########################################
sub Var
{
my ($self, $key) = @_;
return HTML::Merge::Error::HandleError('WARN', 'ILLEGAL_FETCH') && '' unless ($self->{'fields'});
return HTML::Merge::Error::HandleError('WARN', 'NO_SQL_MATCH') && '' unless (exists $self->{'fields'}->{$key});
return $self->{'fields'}->{$key};
}
###########################################
sub Columns
{
my $self = shift;
return HTML::Merge::Error::HandleError('WARN', 'ILLEGAL_FETCH') && '' unless ($self->{'sth'});
return @{$self->{'sth'}->{'NAME'}};
}
###########################################
sub Index
{
my $self = shift;
$self->{'index'};
}
###########################################
sub GetPersistent
{
my ($self, $var) = @_;
my ($sql, $val);
my $id;
my $db = ($HTML::Merge::Ini::SESSION_DB)?"$HTML::Merge::Ini::SESSION_DB.":'';
my $table = $db."sessions";
my $dbh = $self->SYS_DBH();
$self->ValidatePersistent;
$id = $self->{session_id};
$sql = "SELECT vardata
FROM $table
WHERE session_id = '$id'
AND varname = '$var'";
($val) = $dbh->selectrow_array($sql);
return (defined($val)) ? $val : '';
}
###########################################
sub SetPersistent
{
my ($self, $var, $val) = @_;
$self->ValidatePersistent;
$self->SetField($var, $val);
return "";
}
###########################################
sub ErasePersistent
{
my $self = shift;
$self->ValidatePersistent;
my $db = ($HTML::Merge::Ini::SESSION_DB)?"$HTML::Merge::Ini::SESSION_DB.":'';
my $table = $db."sessions";
my $id = $self->{session_id};
my $sql = "DELETE FROM $table
WHERE session_id = '$id'";
my $dbh = $self->SYS_DBH;
$dbh->do($sql) || HTML::Merge::Error::HandleError('ERROR', $DBI::errstr);
}
###########################################
sub ValidatePersistent
{
my $self = shift;
my ($id, $sql, $sth, @other, $other);
my $now = time;
my $db = ($HTML::Merge::Ini::SESSION_DB)?"$HTML::Merge::Ini::SESSION_DB.":'';
my $table = $db."sessions";
my $expire = YMD(time - 60 * $HTML::Merge::Ini::SESSION_TIMEOUT);
$self->CheckSessionTable;
$self->GetSessionID;
$id = $self->{session_id};
$self->SetField("", YMD(time));
$sql = "SELECT session_id
FROM $table
WHERE varname = ''
AND vardata < '$expire'";
@other = $self->LoadArray($sql);
return unless @other;
$sql = "DELETE FROM $table WHERE session_id IN ('" .
join("','", @other) . "')";
my $dbh = $self->SYS_DBH();
$dbh->do($sql);
}
###########################################
sub CreateSessionTable
{
my $self = shift;
my $dbh;
my $db = ($HTML::Merge::Ini::SESSION_DB)?"$HTML::Merge::Ini::SESSION_DB.":'';
my $table = $db."sessions";
my $ddl = "CREATE TABLE $table (
session_id VARCHAR(20) NOT NULL,
varname VARCHAR(30) NOT NULL,
vardata VARCHAR(255) NOT NULL
)";
# there is no relevance ro the value of the internal db because
# the program only need to know if we use mysql
my $database = ($HTML::Merge::Ini::SESSION_DB)?lc($self->{dsn}->[1]):'';
if ($database eq 'mysql')
{
$ddl .= " TYPE=Heap";
}
$dbh = $self->SYS_DBH();
$dbh->do($ddl) || croak $DBI::errstr;
$ddl = "CREATE UNIQUE INDEX ux_var
ON $table (session_id, varname)";
eval { $dbh->do($ddl); };
}
###########################################
sub CheckSessionTable
{
my $self = shift;
my $db = ($HTML::Merge::Ini::SESSION_DB)?"$HTML::Merge::Ini::SESSION_DB.":'';
my $table = $db."sessions";
my $sql = "SELECT Count(*) FROM $table";
my $sth;
return if ($self->{checked_session_table}++ > 1);
$@ = undef;
my $dbh = $self->SYS_DBH();
eval {
$sth = $dbh->prepare($sql) ||
die $DBI::errstr; # Do NOT call HandleError
$sth->execute ||
die $DBI::errstr; # Do NOT call HandleError
};
$self->CreateSessionTable if $@;
}
###########################################
sub GenerateSessionID
{
my $self = shift;
$self->{session_id} = substr($ENV{'REMOTE_ADDR'}, -8) . $$ . time % (3600 * 24);
$self->{session_id} =~ tr/0-9//cd;
}
###########################################
sub GetSessionID
{
my $self = shift;
my $created = $self->MakeSessionID;
return if $created;
my $id = $self->{session_id};
my $db = ($HTML::Merge::Ini::SESSION_DB)?"$HTML::Merge::Ini::SESSION_DB.":'';
my $table = $db."sessions";
my $sql = "SELECT Count(*)
FROM $table
WHERE session_id = '$id'
AND varname = ''";
my $dbh = $self->SYS_DBH();
my ($valid) = $dbh->selectrow_array($sql);
return if $valid;
my $fh = select;
select $fh->{'out'} if (tied($fh));
$self->SetField("", YMD(time));
&HTML::Merge::Error::TimeOut;
}
###########################################
sub MakeSessionID
{
my $self = shift;
my ($key, $val);
my $sql;
my $db = ($HTML::Merge::Ini::SESSION_DB)?"$HTML::Merge::Ini::SESSION_DB.":'';
my $table = $db."sessions";
my $expire=undef;
return 0 if $self->{session_id};
my $method = $HTML::Merge::Ini::SESSION_METHOD || 'C';
if ($method eq 'I')
{
$self->{session_id} = $ENV{'REMOTE_ADDR'};
return 1;
}
if ($method eq 'U')
{
$self->{session_id} = $ENV{'PATH_INFO'};
$self->{session_id} =~ s|/||g;
return 0 if $self->{session_id};
return 0 if $self->{'KLUDGE_NO_NEW_ID'};
$self->GenerateSessionID;
return 1;
}
if ($method eq 'C')
{
$HTML::Merge::Ini::SESSION_COOKIE ||= 'RZCKMRGSSN';
$self->{session_id} = $self->GetCookie($HTML::Merge::Ini::SESSION_COOKIE);
return 0 if $self->{session_id};
return 0 if $self->{'KLUDGE_NO_NEW_ID'};
$self->GenerateSessionID;
if ($HTML::Merge::Ini::STICKY_COOKIE)
{
$expire=$HTML::Merge::Ini::SESSION_TIMEOUT;
}
SetCookie($HTML::Merge::Ini::SESSION_COOKIE,
$self->{session_id},
$expire || "*");
return 1;
}
die "Session method incorrect";
}
###########################################
sub SetField
{
my ($self, $key, $val) = @_;
my ($sql, $count, $sth);
my $db = ($HTML::Merge::Ini::SESSION_DB)?"$HTML::Merge::Ini::SESSION_DB.":'';
my $table = $db."sessions";
my $id = $self->{session_id};
$sql = "SELECT Count(*)
FROM $table
WHERE session_id = '$id'
AND varname = '$key'";
my $dbh = $self->SYS_DBH();
($count) = $dbh->selectrow_array($sql);
if ($count)
{
$sql = "UPDATE $table
SET vardata = ?
WHERE session_id = '$id'
AND varname = '$key'";
}
else
{
$sql = "INSERT INTO $table (session_id, varname, vardata)
VALUES ('$id', '$key', ?)";
}
$sth = $dbh->prepare($sql) ||
return HTML::Merge::Error::HandleError('ERROR', $DBI::errstr);
#$val ||= '';
$val=(defined $val)?$val:'';
$sth->execute($val) ||
return HTML::Merge::Error::HandleError('ERROR', $DBI::errstr);
}
###########################################
sub State
{
my $self=shift;
$self->{sth} ? $self->{sth}->state : (
$self->{'dbh'} ? $self->{'dbh'}->state : '');
}
###########################################
sub YMD
{
my @t = localtime(shift());
return sprintf("%04d" . "%02d" x 5, $t[5] + 1900, $t[4] + 1,
$t[3], $t[2], $t[1], $t[0]);
}
###########################################
sub GetCookie
{
shift if (UNIVERSAL::isa($_[0], __PACKAGE__));
my $name = shift;
my $cookie = $ENV{HTTP_COOKIE};
foreach (split(/;\s*/, $cookie))
{
my ($key, $val) = split(/=/, $_);
return $val if ($key eq $name);
}
}
###########################################
sub SetCookie
{
shift if (UNIVERSAL::isa($_[0], __PACKAGE__));
my ($name, $value, $expire) = @_;
my $extra;
$cookies{$name} = "$value";
unless ($expire)
{
$cookies{$name} .= "; expires=Tue, 19 Jan 2038 03:14:07 GMT";
}
else
{
if ($expire =~ /^\d+$/)
{
#require HTTP::Date;
my $t = time + $expire * 60;
$cookies{$name} .= "; expires=" . time2HTTPstr($t);
}
}
# last add a default path
$cookies{$name} .= "; path=$HTML::Merge::Ini::MERGE_PATH;";
$ENV{'HTTP_COOKIE'} .= ';' if $ENV{'HTTP_COOKIE'};
$ENV{'HTTP_COOKIE'} .= "$name=$value";
}
###########################################
sub ReadConfig
{
my $self = $0;
$self =~ s/\.\w+$/.conf/;
my @conf = ($self, "/etc/merge.conf", &GetHome . "/.merge");
foreach my $f (@conf)
{
if (open(CFG, $f))
{
no strict;
my $code = join("", );
close(CFG);
eval $code;
if ($@)
{
print "Status: 501 Server error\n";
print "Content-type: text/plain\n\n";
print "$f caused error: $@";
exit;
}
$HTML::Merge::config = $f;
last;
}
}
$self =~ s/\.\w+$/.ext/;
foreach my $ext (($self, "/etc/merge.ext"))
{
if (-f $self)
{
package HTML::Merge::Ext;
eval 'require $self;';
if ($@)
{
print "Status: 501 Server error\n";
print "Content-type: text/plain\n\n";
print "$self caused error: $@";
exit;
}
}
}
}
###############################################################################
sub GetHome
{
return if ($^O =~ /Win/);
my ($name,$passwd,$uid,$gid,
$quota,$comment,$gcos,$dir,$shell,$expire) = getpwuid($>);
return $dir;
}
###############################################################################
sub import
{
my (@param) = @_;
$param[1] |= '';
return if ($param[1] eq ':unconfig');
&ReadConfig;
}
###########################################
sub Convert
{
my ($db_pass, $rev) = @_;
my $from = pack("C*", map {hex($_)} ($HTML::Merge::Ini::S_FROM =~ /(..)/g));
my $to = pack("C*", map {hex($_)} ($HTML::Merge::Ini::S_TO =~ /(..)/g)); $from =~ s/-/\\-/;
$to =~ s/-/\\-/;
($from, $to) = ($to, $from) if $rev;
eval "\$db_pass =~ tr/$to/$from/;";
$db_pass;
}
###########################################
sub DBH
{
my $self = shift;
$self->DoConnect;
return $self->{'dbh'};
}
###########################################
sub SYS_DBH
{
my $self = shift;
return $self->{'sys_dbh'} if $self->{'sys_dbh'} ;
return $self->DBH() if $HTML::Merge::Ini::SESSION_DB;
require DBI;
$INTERNAL_DSN="dbi:SQLite:dbname=$HTML::Merge::Ini::MERGE_ABSOLUTE_PATH/$INTERNAL_DB";
my $sys_dbh = DBI->connect($INTERNAL_DSN,"","")
|| HTML::Merge::Error::HandleError('ERROR', $DBI::errstr);
$self->{'sys_dbh'} = $sys_dbh;
$self->{'sth'} = undef;
return $self->{'sys_dbh'};
}
###########################################
sub AddUser
{
my ($self, $user, $password, $realname, $tag) = @_;
croak "Invalid username: $user" unless ($user =~ /^\S{3,15}$/);
croak "Invalid password length: $password" unless ($password =~ /^\S{3,15}$/);
unless ($HTML::Merge::Ini::ALLOW_EASY_PASSWORDS)
{
$@ = undef;
eval{ require Data::Password; };
unless($@)
{
my $reason = Data::Password::IsBadPassword($password);
croak "Bad password $password: $reason" if $reason;
}
}
croak "Can't change user $user"
if ($user eq $HTML::Merge::Ini::ROOT_USER);
my $db = ($HTML::Merge::Ini::SESSION_DB)?"$HTML::Merge::Ini::SESSION_DB.":'';
my $table = $db."users_t";
my $salt = pack("CC", rand(26) + 65 ,rand(26) + 65);
my $cp = crypt($password, $salt);
my $dbh = $self->SYS_DBH();
my $sql = "SELECT Count(*) FROM $table WHERE username = '$user'";
my ($exists) = $dbh->selectrow_array($sql);
unless ($exists)
{
foreach (1 .. 10) # Lame concurrency handling
{
my $id = $self->GetNext($table);
my $sql = "INSERT INTO $table (epitaph, id, username) VALUES (0, $id, '$user')";
eval { $dbh->do($sql); };
last unless $@;
sleep 1;
}
}
$sql = "UPDATE $table SET password = ?, epitaph = 0
WHERE username = '$user'";
my $sth = $dbh->prepare($sql);
$sth->execute($cp);
if (defined($realname)) # May be an empty string
{
my $sql = "UPDATE $table SET realname = ? WHERE username = '$user'";
my $sth = $dbh->prepare($sql);
$sth->execute($realname);
}
if (defined($tag)) # May be an empty string
{
my $sql = "UPDATE $table SET tag = ? WHERE username = '$user'";
my $sth = $dbh->prepare($sql);
$sth->execute($tag);
}
}
###########################################
sub DelUser
{
my ($self, $user) = @_;
$self->Destruct('user' => $user);
}
###########################################
sub SetUser
{
my ($self, $user) = @_;
$self->SetPersistent("__user", join(":", $user,
$self->GetInstance));
}
###########################################
sub GetUser
{
my $self = shift;
# $self->{'KLUDGE_NO_NEW_ID'} = 1;
$self->ValidatePersistent;
# delete $self->{'KLUDGE_NO_NEW_ID'};
return undef unless $self->{'session_id'};
my ($u, $i) = split(/:/, $self->GetPersistent("__user"));
$i == $self->GetInstance ? $u : undef;
}
###############################################################################
sub Login
{
my ($self, $user, $pass) = @_;
my $dbh = $self->SYS_DBH();
my $db = ($HTML::Merge::Ini::SESSION_DB)?"$HTML::Merge::Ini::SESSION_DB.":'';
my $table = "${db}users_t";
my $sql = "SELECT password FROM $table WHERE username = '$user'";
my ($cp) = $dbh->selectrow_array($sql);
$cp = $HTML::Merge::Ini::ROOT_PASSWORD if ($user eq $HTML::Merge::Ini::ROOT_USER);
return 0 unless defined($cp); # May be an empty password!
my $candidate = crypt($pass, $cp);
if ($candidate eq $cp) {
$self->SetUser($user);
return 1;
}
$self->SetUser('');
return 0;
}
###########################################
sub ChangePassword
{
my ($self, $pass) = @_;
my $user = $self->GetUser;
HTML::Merge::Error::HandleError('ERROR',
"Not logged in") unless $user;
HTML::Merge::Error::HandleError('ERROR', "Can't change user $user")
if ($user eq $HTML::Merge::Ini::ROOT_USER);
$self->AddUser($user, $pass);
}
###########################################
sub HasKey
{
my ($self, $realm, $user) = @_;
$user ||= $self->GetUser;
return 0 unless $user;
return 1 if ($user eq $HTML::Merge::Ini::ROOT_USER);
my $make_sure_user_exists = $self->GetUserID($user);
my %keys;
my @keys = $self->Links('user' => $user, 'realm', $realm);
return 1 if @keys;
my @groups = $self->Links('user' => $user, 'group');
@keys = $self->Links('group' => \@groups, 'realm', $realm);
return 1 if @keys;
undef;
}
###########################################
sub CanEnter
{
my ($self, $template, $user) = @_;
unless ($template)
{
$template = $HTML::Merge::context->[0];
$template =~ s/^$HTML::Merge::Ini::TEMPLATE_PATH//;
}
my $default = 1;
foreach ($self->Links('template' => $template, 'realm'))
{
$user ||= $self->GetUser;
return undef unless $user;
return 1 if $self->HasKey($_, $user);
$default = 0; # Some keys were requested - return 0 if none matched
}
my @subsites = $self->Links('template' => $template, 'subsite');
foreach ($self->Links('subsite' => \@subsites, 'realm'))
{
$user ||= $self->GetUser;
return undef unless $user;
return 1 if $self->HasKey($_, $user);
$default = 0; # Some keys were requested - return 0 if none matched
}
return $default;
}
###########################################
sub GetNext
{
my ($self, $table) = @_;
my $dbh = $self->SYS_DBH();
my $sql = "SELECT Max(id) FROM $table";
my ($max) = $dbh->selectrow_array($sql);
return $max + 1;
}
###########################################
sub Required
{
my ($self, $template) = @_;
my $tid = $self->GetTemplateID($template);
my $dbh = $self->SYS_DBH();
my $db = ($HTML::Merge::Ini::SESSION_DB)?"$HTML::Merge::Ini::SESSION_DB.":'';
my $sql = "SELECT B.realmname
FROM ${db}realm_template_matrix A,
${db}realms_t B
WHERE A.template_id = $tid
AND B.id = A.realm_id";
$self->LoadArray($sql);
}
###########################################
sub Require
{
my ($self, $template, $realms) = @_;
my @realms = split(/,\s*/, $realms);
my $tid = $self->GetTemplateID($template);
my $db = ($HTML::Merge::Ini::SESSION_DB)?"$HTML::Merge::Ini::SESSION_DB.":'';
my $table = $db."realm_template_matrix";
my $iid = $self->GetInstance;
my $dbh = $self->SYS_DBH();
my $sql = "DELETE FROM $table WHERE template_id = $tid";
$dbh->do($sql);
foreach (@realms)
{
$self->Request($_, $template);
}
}
###########################################
sub InitDatabase
{
my $self = shift;
$self ||= __PACKAGE__->CreateObject();
my $sysdata_file = "$HTML::Merge::Ini::MERGE_ABSOLUTE_PATH/private/sql/tbl.dat";
$self->CreateMeta();
# now let's create the meta data tables_internal
$self->CreateMetaDataTable();
# populate default meta
$self->LoadSysTableFromFile($sysdata_file);
foreach (@objects)
{
$self->CreateTable($_);
}
foreach (@matrices)
{
$self->CreateMatrix($_);
}
}
###########################################
sub CreateTable
{
my ($self, $table) = @_;
print "Creating $table table...";
my $db = ($HTML::Merge::Ini::SESSION_DB)?"$HTML::Merge::Ini::SESSION_DB.":'';
my $dbh = $self->SYS_DBH;
my $ddl = <do($ddl);
$ddl = "CREATE UNIQUE INDEX x_$table ON ${db}${table}s_t (${table}name)";
if ($table eq 'template')
{
$ddl =~ s/\)$/, instance_id)/;
}
$dbh->do($ddl);
print "\n";
}
###########################################
sub GetSay
{
shift if UNIVERSAL::isa($_[0], __PACKAGE__);
my ($child, $parent, $how) = @_;
Order($child, $parent);
# Must search for first occurence@
my ($str) = grep {$_ eq $parent || $_ eq "_$child"} @say;
return unless $str;
my %say = @say;
my ($add, $del) = split(/:/, $say{$str});
return ($add, $del) unless $how;
$how = ucfirst(lc($how));
my $proc = UNIVERSAL::can(__PACKAGE__, "Translate$how");
return map {&$proc;} ($add, $del) if $proc;
return ($add, $del);
}
###########################################
sub TranslateImperative
{
my @tokens = split(/_/, $_);
$_ = ucfirst(lc($tokens[-1]));
}
###########################################
sub TranslatePast
{
s/_/ /;
s/e$//;
$_ .= 'ed';
}
###########################################
sub CreateMatrix
{
my ($self, $matrix) = @_;
my ($child, $parent) = split(/_/, $matrix);
print "Creating $child/$parent table...";
my $db = ($HTML::Merge::Ini::SESSION_DB)?"$HTML::Merge::Ini::SESSION_DB.":'';
my $dbh = $self->SYS_DBH();
my $table = "${matrix}_matrix";
my $index_prefix;
my ($add, $del) = GetSay($child, $parent);
my $ddl = <do($ddl);
$index_prefix=$db;
chop($index_prefix);
$index_prefix .="_$matrix";
foreach (($child, $parent)) {
$ddl = "CREATE INDEX x_$index_prefix\_$_ ON $table (${_}_id)";
$dbh->do($ddl);
}
$ddl = "CREATE UNIQUE INDEX ux_$index_prefix ON $table (${child}_id, ${parent}_id)";
$dbh->do($ddl);
my $sql = "INSERT INTO ${db}metadata (child, parent, stradd, strdel, tbl)
VALUES ('$child', '$parent', '$add', '$del', '${matrix}_matrix')";
$dbh->do($sql);
print "\n";
}
###########################################
sub CreateMeta
{
my ($self) = @_;
my $db = ($HTML::Merge::Ini::SESSION_DB)?"$HTML::Merge::Ini::SESSION_DB.":'';
my $dbh = $self->SYS_DBH();
my $object = "VARCHAR(25) NOT NULL";
my $table = "${db}metadata";
my $sql;
my $ddl = <do("CREATE DATABASE $db") if $HTML::Merge::Ini::SESSION_DB;
$dbh->do($ddl);
$ddl = "CREATE UNIQUE INDEX ux_metadata
ON $table (child, parent)";
$dbh->do($ddl);
$sql = "DELETE FROM $table";
$dbh->do($sql);
}
###########################################
sub IsMatrix
{
shift if UNIVERSAL::isa($_[0], __PACKAGE__);
my ($child, $parent) = @_;
my $cache = undef if undef;
unless ($cache)
{
my %cache;
@cache{@matrices} = (1) x scalar(@matrices);
$cache = \%cache;
}
return $cache->{"${child}_$parent"};
}
###########################################
sub Order (\$\$)
{
my ($a, $b) = @_;
return if IsMatrix($$a, $$b);
($$a, $$b) = ($$b, $$a);
}
###########################################
sub Assert
{
my ($self, $child, $childval, $parent, $parentval, $del) = @_;
unless (IsMatrix($child, $parent))
{
($child, $childval, $parent, $parentval) =
($parent, $parentval, $child, $childval);
}
my $db = ($HTML::Merge::Ini::SESSION_DB)?"$HTML::Merge::Ini::SESSION_DB.":'';
my $dbh = $self->SYS_DBH;
my $matrix = "${db}${child}_${parent}_matrix";
my $child_id = $self->GetIndex($child, $childval);
my $parent_id = $self->GetIndex($parent, $parentval);
my $where = "WHERE ${child}_id = $child_id
AND ${parent}_id = $parent_id";
if ($del)
{
my $sql = "DELETE FROM $matrix $where";
$dbh->do($sql);
return;
}
my $sql = "SELECT Count(*) FROM $matrix $where";
my $already = $dbh->selectrow_array($sql);
return if $already;
my $id = $self->GetNext($matrix);
$sql = "INSERT INTO $matrix (id, ${child}_id, ${parent}_id)
VALUES ($id, $child_id, $parent_id)";
$dbh->do($sql);
}
###########################################
sub GetIndex
{
my ($self, $tbl, $val) = @_;
my $db = ($HTML::Merge::Ini::SESSION_DB)?"$HTML::Merge::Ini::SESSION_DB.":'';
my $dbh = $self->SYS_DBH();
my $where = "WHERE ${tbl}name = '$val'";
my $fun = ucfirst($tbl);
my $proc = UNIVERSAL::can($self, "Where$fun");
$where .= ' AND ' . &$proc($self, $val) if $proc;
my $table = "${db}${tbl}s_t";
my $sql = "SELECT id, epitaph FROM $table $where";
my ($id, $epitaph) = $dbh->selectrow_array($sql);
if ($epitaph)
{
my $sql = "UPDATE $table SET epitaph = 0
WHERE id = $id";
$dbh->do($sql);
}
return $id if $id;
$proc = UNIVERSAL::can($self, "Bail$fun");
return if ($proc && &$proc($self, $val));
$id = $self->GetNext($table);
$proc = UNIVERSAL::can($self, "Insert$fun");
my $fields = "(epitaph, id, ${tbl}name)";
my $values = "(0, $id, '$val')";
&$proc($self, \$fields, \$values, $val) if $proc;
$sql = "INSERT INTO $table $fields VALUES $values";
$dbh->do($sql);
return $id;
}
###########################################
sub GetDetails
{
my ($self, $tbl, $val) = @_;
my $db = ($HTML::Merge::Ini::SESSION_DB)?"$HTML::Merge::Ini::SESSION_DB.":'';
my $dbh = $self->SYS_DBH;
my $where = "WHERE ${tbl}name = '$val'";
my $fun = ucfirst($tbl);
my $proc = UNIVERSAL::can($self, "Where$fun");
$where .= ' AND ' . &$proc($self, $val) if $proc;
my $table = "${db}${tbl}s_t";
my $sql = "SELECT description, tag FROM $table $where";
my ($name, $tag) = $dbh->selectrow_array($sql);
return undef unless defined($name) || defined($tag);
wantarray ? ($name, $tag) : $name;
}
###########################################
sub SetDBField
{
my ($self, $tbl, $val, $field, $col) = @_;
my $db = ($HTML::Merge::Ini::SESSION_DB)?"$HTML::Merge::Ini::SESSION_DB.":'';
my $dbh = $self->SYS_DBH;
my $where = "WHERE ${tbl}name = '$val'";
my $fun = ucfirst($tbl);
my $proc = UNIVERSAL::can($self, "Where$fun");
$where .= ' AND ' . &$proc($self, $val) if $proc;
my $table = "${db}${tbl}s_t";
my $sql = "UPDATE $table SET $field = '$col' $where";
$dbh->do($sql);
}
###########################################
sub GetInstance
{
my $self = shift;
$self->GetInstanceID($HTML::Merge::config);
}
###########################################
sub WhereTemplate
{
my $self = shift;
my $instance = $self->GetInstance;
return "instance_id = $instance";
}
###########################################
sub InsertTemplate
{
my $self = shift;
my $instance = $self->GetInstance;
${$_[0]} =~ s/\)/, instance_id)/;
${$_[1]} =~ s/\)/, $instance)/;
}
###########################################
sub BailUser
{
my ($self, $user) = @_;
croak "No user '$user'";
return 1;
}
###########################################
sub Destruct
{
my ($self, $tbl, $val) = @_;
my $id = $self->GetIndex($tbl, $val);
return unless $id;
my $dbh = $self->SYS_DBH;
my $db = ($HTML::Merge::Ini::SESSION_DB)?"$HTML::Merge::Ini::SESSION_DB.":'';
my $sql = "DELETE FROM ${db}${tbl}s_t WHERE id = $id";
$dbh->do($sql);
my @mats = Dependencies($tbl);
foreach (@mats)
{
my $sql = "DELETE FROM ${db}${_}_matrix
WHERE ${tbl}_id = $id";
$dbh->do($sql);
}
}
###########################################
sub Dependencies
{
shift if UNIVERSAL::isa($_[0], __PACKAGE__);
my $t = shift;
map {s/_$t$//; s/^${t}_//; $_; } grep {/^${t}_/ || /_$t$/}
@{[@matrices]};
}
###########################################
sub Children
{
shift if UNIVERSAL::isa($_[0], __PACKAGE__);
my $t = shift;
map {s/_$t$//; $_;} grep /_$t$/, @{[@matrices]};
}
###########################################
sub Parents
{
shift if UNIVERSAL::isa($_[0], __PACKAGE__);
my $t = shift;
map {s/^${t}_//; $_; } grep /^${t}_/, @{[@matrices]};
}
###########################################
sub LoadArray
{
my ($self, $sql, @extra) = @_;
my $dbh = $self->SYS_DBH();
my $sth = $dbh->prepare($sql);
$sth->execute(@extra) || confess($sql);
my @vec;
while (my ($item) = $sth->fetchrow_array)
{
push(@vec, $item);
}
return wantarray ? @vec : \@vec;
}
###########################################
sub GetVector
{
my ($self, $tbl) = @_;
my $fun = "Weed" . ucfirst($tbl) . 's';
my $code = UNIVERSAL::can($self, $fun);
&$code($self) if $code;
my $db = ($HTML::Merge::Ini::SESSION_DB)?"$HTML::Merge::Ini::SESSION_DB.":'';
my $table ="${db}${tbl}s_t";
my $sql = "SELECT ${tbl}name FROM $table
WHERE epitaph = 0 ORDER BY ${tbl}name";
my $vec = $self->LoadArray($sql);
return wantarray ? @$vec : $vec;
}
###########################################
sub WeedTemplates
{
my $self = shift;
my $db = ($HTML::Merge::Ini::SESSION_DB)?"$HTML::Merge::Ini::SESSION_DB.":'';
my $table ="${db}templates_t";
my @weed;
my $sql = "SELECT templatename FROM $table";
my $vec = $self->LoadArray($sql);
@weed = grep { ! -f "$HTML::Merge::Ini::TEMPLATE_PATH/$_"
|| -d "$HTML::Merge::Ini::TEMPLATE_PATH/$_" }
@$vec;
$sql = "UPDATE $table SET epitaph = 1 WHERE
templatename in (" .
join(", ", map {"'$_'"} @weed) . ")";
my $dbh = $self->SYS_DBH;
$dbh->do($sql);
my @files;
my $dir = $HTML::Merge::Ini::TEMPLATE_PATH;
for (;;)
{
$dir .= "/*";
my @these = grep { ! -d $_ } glob($dir);
last unless @these;
push(@files, @these);
}
foreach (map {s|^$HTML::Merge::Ini::TEMPLATE_PATH/||; $_;}
@files)
{
$self->GetTemplateID($_);
}
}
###########################################
sub GetHash
{
my ($self, $tbl) = @_;
my $vec = $self->GetVector($tbl);
my %hash;
@hash{@$vec} = @$vec;
return wantarray ? %hash : \%hash;
}
###########################################
#@matrices = qw(user_group user_realm group_realm
# realm_template template_subsite realm_subsite);
my %mnemonics = qw(user_group JoinGroup:PartGroup
user_realm GrantUser:RevokeUser
group_realm GrantGroup:RevokeGroup
realm_template Request:Waive
template_subsite Attach:Detach
realm_subsite GrandRequest:GrandWaive);
foreach my $mat (keys %mnemonics)
{
my ($assert, $retract) = split(/:/, $mnemonics{$mat});
my ($child, $parent) = split(/_/, $mat);
my $code = <Assert('$child' => \$$child, '$parent' => \$$parent);
}
sub $retract
{
my (\$self, \$$child, \$$parent) = \@_;
\$self->Assert('$child' => \$$child, '$parent' => \$$parent, 1);
}
CODE
eval $code;
die $@ if $@;
}
foreach (@objects)
{
my $tok = ucfirst($_);
my $code = <GetIndex('$_', \$$tok);
}
sub GetAll${tok}s
{
my \$self = shift;
\$self->GetHash('$_');
}
sub Get${tok}s
{
my \$self = shift;
\$self->GetVector('$_');
}
sub Get${tok}Name
{
my (\$self, \$$tok) = \@_;
\$$tok ||= \$self->Get$tok;
\$self->GetDetails('$_' => \$$tok);
}
CODE
eval $code;
die $@ if $@;
}
###########################################
sub GetOneDrill
{
shift if UNIVERSAL::isa($_[0], __PACKAGE__);
my ($from, $to) = @_;
my $hash = {};
foreach (@matrices) {
my ($child, $parent) = split(/_/);
$hash->{$child} ||= {};
$hash->{$child}->{$parent} = "${child}_${parent}";
}
my $ary = [];
&Recur($from, $to, $ary, 0, $hash);
&Recur($to, $from, $ary, 1, $hash);
return $ary;
}
###########################################
sub Recur
{
shift if UNIVERSAL::isa($_[0], __PACKAGE__);
my ($from, $to, $ary, $opp, $hash, @way) = @_;
if($from eq $to)
{
@way = reverse @way if $opp;
push(@$ary, \@way);
return;
}
my $node = $hash->{$from};
foreach (keys %$node)
{
&Recur($_, $to, $ary, $opp, $hash, @way, $node->{$_});
}
}
###############################################################################
sub GetDrill
{
shift if UNIVERSAL::isa($_[0], __PACKAGE__);
my ($from, $to) = @_;
my $cache = undef if undef;
$cache ||= {};
return $cache->{$from, $to} if exists $cache->{$from, $to};
my $ref = GetOneDrill($from, $to);
return $cache->{$from, $to} = $ref;
}
###############################################################################
sub Links
{
my ($self, $child, $this, $parent, $only) = @_;
my $sql;
my $db = ($HTML::Merge::Ini::SESSION_DB)?"$HTML::Merge::Ini::SESSION_DB.":'';
my ($check, $read) = ($child, $parent);
Order($child, $parent);
my $comp;
unless (UNIVERSAL::isa($this, 'ARRAY'))
{
$comp = "= '$this'";
}
else
{
return () unless $#$this >= 0;
$comp = "IN (" . join(", ", map {"'$_'";} @$this) . ")";
}
my $extra;
if ($only)
{
$extra = " AND B.${read}name = '$only'";
}
$sql = "SELECT B.${read}name
FROM ${db}${child}_${parent}_matrix A,
${db}${read}s_t B,
${db}${check}s_t C
WHERE C.${check}name $comp
AND C.id = A.${check}_id
AND B.id = A.${read}_id $extra
ORDER BY B.${read}name";
$self->LoadArray($sql);
}
###############################################################################
sub Linkers
{
my ($self, $child, $parent) = @_;
my $sql;
my ($check, $read) = ($parent, $child);
my $db = ($HTML::Merge::Ini::SESSION_DB)?"$HTML::Merge::Ini::SESSION_DB.":'';
Order($child, $parent);
$sql = "SELECT DISTINCT B.${read}name
FROM ${db}${child}_${parent}_matrix A,
${db}${read}s_t B
WHERE B.id = A.${read}_id
ORDER BY B.${read}name";
$self->LoadArray($sql);
}
###############################################################################
sub time2str ($$)
{
my ($fmt, $time) = @_;
my $s;
eval { require POSIX;
$s = POSIX::strftime($fmt, localtime($time));
};
return $s if $s;
eval { require Date::Format;
$s = Date::Format::time2str($time);
};
return $s;
}
###############################################################################
sub Force ($$)
{
my ($value, $flags) = @_;
return unless $HTML::Merge::Ini::VALUE_CHECKING;
if ($flags =~ /n/i)
{
HTML::Merge::Error::HandleError('ERROR', "'$value' is not an integer")
unless ($value eq ($value * 1));
}
if ($flags =~ /i/i)
{
HTML::Merge::Error::HandleError('ERROR', "'$value' is not an integer")
unless ($value eq ($value * 1)
&& $value == int($value));
}
if ($flags =~ /u/i)
{
HTML::Merge::Error::HandleError('ERROR', "'$value' is negative")
if $value < 0;
}
}
###############################################################################
sub time2HTTPstr
{
my $time = shift;
my @day = qw(Sun Mon Tue Wed Thu Fri Sat);
my @month = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
my ($sec, $min, $hour, $mday, $mon, $year, $wday);
$time = time unless defined $time;
($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($time);
return sprintf("%s, %02d %s %04d %02d:%02d:%02d GMT",
$day[$wday],
$mday, $month[$mon], $year+1900,
$hour, $min, $sec);
}
###########################################
sub CreateMetaDataTable
{
my ($self) = @_;
my $dbh = $self->SYS_DBH();
my $db = ($HTML::Merge::Ini::SESSION_DB)?"$HTML::Merge::Ini::SESSION_DB.":'';
my $table = "${db}tbl";
my $ddl = "CREATE TABLE $table (
tbl VARCHAR(6),
langug_code VARCHAR(6),
code VARCHAR(6),
name VARCHAR(50),
number FLOAT,
note VARCHAR(255),
realm_id INTEGER
)";
$dbh->do($ddl);
# create indexes
$ddl = "CREATE UNIQUE INDEX ux_tbl
ON $table (tbl,langug_code,code)";
eval { $dbh->do($ddl); };
$ddl = "CREATE INDEX x_langug_code
ON $table (langug_code)";
eval { $dbh->do($ddl); };
}
###########################################
sub LoadSysTableFromFile
{
my ($self,$file) = @_;
my $dbh = $self->SYS_DBH();
my $db = ($HTML::Merge::Ini::SESSION_DB)?"$HTML::Merge::Ini::SESSION_DB.":'';
my (@col,$col,$val);
my $table = $db;
my $sql;
my $sth;
$file ||='list';
open(I,"$file") || die "can't open data file $file";
# get first line
$table .= ;
chomp $table;
# get the second line
$col=;
chomp $col;
chop $col;
# create the collumn line
$col=~ s/\|/\,/g;
# create the val
@col=split(/\,/,$col);
$val= '?,' x ($#col+1);
chop($val);
# do the insert string
$sql="INSERT INTO $table ($col) VALUES ($val)";
$sth=$dbh->prepare($sql);
# truncate the table
$dbh->do("DELETE FROM $table");
while()
{
next if(/^#/ || !(/\|/));
@col=split(/\|/,$_);
pop(@col);
$sth->execute(@col) || die $dbh->errstr;
}
}
###########################################
1;
###########################################
__END__
=head1 NAME
HTML::Merge::Engine - Run time Engine
=head1 FUNCTIONS
=head2 Order
Given two scalars (most likely names of tables), swaps the
values of the two if they don't make up a Matrix table.
=head2 IsMatrix(CHILD, PARENT)
Can be called both directly as a function call and as a method call
$self->IsMatrix
returns true if CHILD_PARENT is one of the "matrix"-like tables.
=head2 LoadArray(SQL, @EXTRA)
Received an SQL statement and optional values to be
parameters of the SQL statement (I have not seen this used)
Prepares and executes a query and return the array of the
first column (!) as either an array or an array ref depending
on the calling context.
=head2 Links
=head2 $self->HasKey(REALM, USERNAME)
Returns if the given user is connected to the REALM directly or
through being a member of a group.
This is the translation of the $RAUTH directive.
TODO -> test and update the docs of RAUTH
If no username is given, the currently logged in user is used.
returns 0 if no user given and not logged in
returns 1 if the user is connected to the REALM
returns undef otherwise
=head2 $self->CanEnter(TEMPLATE, USERNAME)
Invoked from the main script of merge.cgi
this checks if the given user can access the given template.
=head2 Login(USERNAME, PASSWORD)
Checks if the given username/password pair is in the database
(or if the user is the admin user with the admin password in the conf file)