package DBI::Library::Database;
use strict;
use warnings;
use utf8;
use HTML::Entities;
use vars qw(
$m_dbh
$m_dsn
$m_sDefaultClass
@EXPORT_OK
@ISA
%m_hFunctions
$m_sServerName
$m_nSecs
);
$m_sDefaultClass = 'DBI::Library::Database' unless defined $DBI::Library::Database::m_sDefaultClass;
require Exporter;
use DBI::Library qw(:all $m_dbh $m_dsn);
@DBI::Library::Database::ISA = qw(DBI::Library Exporter);
@DBI::Library::Database::EXPORT = qw(useexecute);
@DBI::Library::Database::EXPORT_OK =
qw(getActionRight catright topicright getAction fulltext searchDB rss readMenu deleteMessage reply editMessage addMessage getIndex CurrentPass CurrentUser CurrentHost CurrentDb Driver execute useexecute quote void fetch_hashref fetch_AoH fetch_array updateModules deleteexecute editexecute addexecute tableLength tableExists addUser hasAcount isMember right checkPass checkSession setSid getName initDB checkFlood GetColumns GetAttrs GetCollation GetColumnCollation GetExtra GetNull GetEngineForRow GetEngines GetCharacterSet GetDataBases GetAutoIncrement GetPrimaryKey GetAutoIncrementValue fetch_string);
%DBI::Library::Database::EXPORT_TAGS = (
'all' => [
qw(getActionRight catright topicright getAction
fulltext searchDB rss readMenu deleteMessage reply editMessage addMessage
getIndex CurrentPass CurrentUser CurrentHost CurrentDb Driver addUser hasAcount isMember right checkPass checkSession setSid getName initDB tableLength tableExists useexecute void fetch_hashref fetch_AoH fetch_array updateModules deleteexecute editexecute addexecute checkFlood GetColumns GetAttrs GetCollation GetColumnCollation GetExtra GetNull GetEngineForRow GetEngines GetCharacterSet GetDataBases GetAutoIncrement GetPrimaryKey GetAutoIncrementValue fetch_string)
],
'dynamic' => [
qw(CurrentPass CurrentUser CurrentHost CurrentDb Driver useexecute void fetch_hashref fetch_AoH fetch_array updateModules deleteexecute editexecute addexecute)
],
'independent' => [
qw(CurrentPass CurrentUser CurrentHost CurrentDb Driver tableLength tableExists initDB useexecute void fetch_hashref fetch_AoH fetch_array updateModules deleteexecute editexecute addexecute fetch_string)
],
'mysql' => [
qw(getIndex CurrentPass CurrentUser CurrentHost CurrentDb Driver addUser hasAcount isMember right checkPass checkSession setSid getName checkFlood GetColumns GetAttrs GetCollation GetColumnCollation GetExtra GetNull GetEngineForRow GetEngines GetCharacterSet GetDataBases GetAutoIncrement GetPrimaryKey GetAutoIncrementValue)
],
);
$DBI::Library::Database::VERSION = '1.18';
$m_nSecs = 10;
=head1 NAME
DBI::Library::Database - Database interface for MySQL::Admin::GUI
=head1 SYNOPSIS
use DBI::Library::Database;
=head2 new()
constructor
=cut
sub new {
my ( $class, @initializer ) = @_;
my $self = {};
bless $self, ref $class || $class || $m_sDefaultClass;
$m_dbh = $self->SUPER::initDB(@initializer) if (@initializer);
return $self;
} ## end sub new
=head2 getName
$name = $m_oDatabase->getName($m_sSid);
=cut
sub getName {
my ( $self, @p ) = getSelf(@_);
my $m_sSid = $p[0];
if ( defined $m_sSid ) {
my $sql = 'SELECT user FROM `users` where sid = ?;';
my $sth = $m_dbh->prepare($sql) or warn $m_dbh->errstr;
$sth->execute($m_sSid) or warn $m_dbh->errstr;
my $name = $sth->fetchrow_array();
$sth->finish();
return $name;
} else {
return 'guest';
} ## end else [ if ( defined $m_sSid )]
} ## end sub getName
=head2 setSid
$sid = $m_oDatabase->setSid( name, pass );
=cut
sub setSid {
my ( $self, @p ) = getSelf(@_);
my $name = $p[0];
my $pass = $p[1];
my $ip = $p[2];
use POSIX qw(strftime);
my $time = strftime "%d.%m.%Y %H:%M:%S", localtime;
use MD5;
my $md5 = new MD5;
$md5->add($name);
$md5->add($pass);
$md5->add($time);
$md5->add($ip);
my $fingerprint = $md5->hexdigest();
my $sql = 'UPDATE users SET sid = ? ,ip = ? WHERE user = ?';
my $sth = $m_dbh->prepare($sql);
$sth->execute( $fingerprint, $ip, $name );
$sth->finish();
return $fingerprint;
} ## end sub setSid
=head2 checkSession
$bool = $m_oDatabase->checkSession($sUser,$m_sSid);
=cut
sub checkSession {
my ( $self, @p ) = getSelf(@_);
my $sUser = shift @p;
my $ssid = shift @p;
my $ip = shift @p;
my $return = 0;
if ( length($sUser) > 3 && length($ssid) > 3 ) {
my $sql = 'select sid from users where user = ?';
my $sth = $m_dbh->prepare($sql);
$sth->execute($sUser) or warn $m_dbh->errstr;
my $session = $sth->fetchrow_array();
$sth->finish();
$return = 1 if ( defined $session && defined $ssid && $ssid eq $session );
} ## end if ( length($sUser) > ...)
return $return;
} ## end sub checkSession
=head2 checkPass
bool checkPass( user, crypt_pass);
=cut
sub checkPass {
my ( $self, @p ) = getSelf(@_);
my $u = $p[0];
my $cp = $p[1];
if ( defined $u ) {
my $sql = q(SELECT pass FROM users where user = ?);
my $sth = $m_dbh->prepare($sql) or warn $m_dbh->errstr;
$sth->execute($u);
my $cpass = $sth->fetchrow_array();
$sth->finish();
$cpass = defined $cpass ? $cpass : 0;
return ( $cp eq $cpass ) ? 1 : 0;
} ## end if ( defined $u )
return 0;
} ## end sub checkPass
=head2 right()
$nRight = right($m_sAction,$sUsername);
=cut
sub right {
my ( $self, @p ) = getSelf(@_);
my $sUser = $p[0];
return userright($sUser);
} ## end sub right
=head2 userright()
userright( user );
=cut
sub userright {
my ( $self, @p ) = getSelf(@_);
my $sUser = $p[0];
my $sql = 'SELECT `right` FROM users where `user` = ? ';
my $sth = $m_dbh->prepare($sql);
$sth->execute($sUser);
my @q = $sth->fetchrow_array;
$sth->finish();
return $q[0];
} ## end sub userright
=head2 catright()
catright( 'name|name2' );
=cut
sub catright {
my ( $self, @p ) = getSelf(@_);
my $cat = $p[0];
my @select = split /\|/, $cat;
my %sel;
$sel{$_} = 1 foreach @select;
my @cats = $self->fetch_AoH('SELECT * FROM cats');
my $nRight = 0;
for ( my $i = 0 ; $i <= $#cats ; $i++ ) {
$nRight = $cats[$i]->{right} if ( $sel{ $cats[$i]->{name} } && $cats[$i]->{right} > $nRight );
} ## end for ( my $i = 0 ; $i <=...)
return $nRight;
} ## end sub catright
=head2 isMember
isMember($sUser);
=cut
sub isMember {
my ( $self, @p ) = getSelf(@_);
my $sUser = lc $p[0];
if ( defined $sUser ) {
my $sth = $m_dbh->prepare('SELECT user FROM users where user = ?') or warn $m_dbh->errstr;
$sth->execute($sUser);
my ($member) = $sth->fetchrow_array();
$sth->finish();
return defined $member ? ( $sUser eq $member ) ? 1 : 0 : 0;
} else {
return 1;
} ## end else [ if ( defined $sUser ) ]
} ## end sub isMember
=head2 hasAcount
bool hasAcount( $email )
=cut
sub hasAcount {
my ( $self, @p ) = getSelf(@_);
my $mail = lc $p[0];
if ( defined $mail ) {
my $sth = $m_dbh->prepare('SELECT email FROM users where email = ?')
or warn $m_dbh->errstr;
$sth->execute($mail);
my ($email) = $sth->fetchrow_array();
$sth->finish();
return ( $mail eq $email ) ? 1 : 0;
} else {
return 1;
} ## end else [ if ( defined $mail ) ]
} ## end sub hasAcount
=head2 addUser
$m_oDatabase->addUser(user, pass,mail);
=cut
sub addUser {
my ( $self, @p ) = getSelf(@_);
my $newuser = $p[0];
my $newpass = $p[1];
my $mail = $p[2];
use MD5;
my $md5 = new MD5;
$md5->add($newuser);
$md5->add($newpass);
my $fingerprint = $md5->hexdigest();
my $sql_addUser = q/insert into users (user,pass,email,`right`,cats) values(?,?,?,1,'news|member')/;
my $sth = $m_dbh->prepare($sql_addUser);
my $anzahl = $sth->execute( $newuser, $fingerprint, $mail ) or warn $m_dbh->errstr;
$sth->finish();
return 1 if ( $anzahl + 0 == 1 );
} ## end sub addUser
=head2 serverName()
set serverName.
=cut
sub serverName {
my ( $self, @p ) = getSelf(@_);
if ( defined $p[0] ) {
$m_sServerName = $p[0];
} else {
return $m_sServerName;
} ## end else [ if ( defined $p[0] ) ]
} ## end sub serverName
=head2 floodtime()
set floodtime.
=cut
sub floodtime {
my ( $self, @p ) = getSelf(@_);
if ( defined $p[0] ) {
$m_nSecs = $p[0];
} else {
return $m_nSecs;
} ## end else [ if ( defined $p[0] ) ]
} ## end sub floodtime
=head2 checkFlood
checkFlood(ip,optional time in seconds )
checkFlood( remote_addr() );
=cut
sub checkFlood {
my ( $self, @p ) = getSelf(@_);
my $ip = $p[0];
$m_nSecs = defined $p[1] ? $p[1] : $m_nSecs;
my $return = 0;
if ( defined $ip ) {
my $sql = q(SELECT ti FROM flood where remote_addr = ? );
my $sth = $m_dbh->prepare($sql) or warn $m_dbh->errstr;
$sth->execute($ip);
my $ltime = $sth->fetchrow_array();
unless ( defined $ltime ) {
$self->void( 'insert into flood (remote_addr, ti) VALUES(?,?)', $ip, time() );
$return = 1;
} else {
$return = ( time() - $ltime > $m_nSecs ) ? 1 : 0;
$self->void( 'update flood set ti =? where remote_addr = ?', time(), $ip );
} ## end else
$sth->finish();
} ## end if ( defined $ip )
return $return;
} ## end sub checkFlood
=head2 GetAutoIncrementValue()
GetAutoIncrementValue(table)
=cut
sub GetAutoIncrementValue {
my ( $self, @p ) = getSelf(@_);
my $name = $p[0];
my @a = $self->fetch_AoH('SHOW TABLE STATUS');
for ( my $i = 0 ; $i <= $#a ; $i++ ) {
return $a[$i]->{Auto_increment} if ( $a[$i]->{Name} eq $name );
} ## end for ( my $i = 0 ; $i <=...)
} ## end sub GetAutoIncrementValue
=head2 GetPrimaryKey()
liefert die primary_key(s) der tabelle zurueck
@array = GetPrimaryKey(table)
=cut
sub GetPrimaryKey {
my ( $self, @p ) = getSelf(@_);
my $tbl = $p[0];
if ( defined $tbl ) {
$tbl = $m_dbh->quote_identifier($tbl);
my @caption = $self->fetch_AoH("show columns from $tbl");
my @return;
for ( my $j = 0 ; $j <= $#caption ; $j++ ) {
push @return, $caption[$j]->{'Field'} if ( $caption[$j]->{'Key'} eq 'PRI' );
} ## end for ( my $j = 0 ; $j <=...)
push @return, $caption[0]->{'Field'} if $#caption eq 0;
return @return;
} else {
return 0;
} ## end else [ if ( defined $tbl ) ]
} ## end sub GetPrimaryKey
=head2 getIndex()
=cut
sub getIndex {
my ( $self, @p ) = getSelf(@_);
my $tbl = $p[0];
if ( defined $tbl ) {
$tbl = $m_dbh->quote_identifier($tbl);
my $hr = $self->fetch_hashref("SHOW CREATE TABLE $tbl");
my @return;
foreach my $line ( split /\n/, $hr->{'Create Table'} ) {
if ( $line =~ /(PRIMARY KEY|FOREIGN KEY|FULLTEXT KEY|UNIQUE KEY|KEY) (`([^`]+)`)? ?(\(([^)]+)\))?/ ) {
my $type = $1;
my $name = $type eq 'FOREIGN KEY' ? $return[$#return]->{field} : $2;
delete $return[$#return];
my $sfields = $5;
my @fields;
push @fields, /`([^`]+)`/ for split ',', $5;
if ( $line =~ /REFERENCES `([^`]+)` \(([^)]+)\)/ ) {
my $table = $1;
my @references;
push @references, /`([^`]+)`/ for split ',', $2;
push @return,
{
field => /`([^`]+)`/,
foreignTable => $table,
foreignFields => [@fields],
foreignReferences => [@references],
name => $name,
type => $type,
ondelete => $line =~ /ON DELETE CASCADE/ ? 'CASCADE'
: $line =~ /ON DELETE SET DEFAULT/ ? 'SET DEFAULT'
: '',
onupdate => $line =~ /ON UPDATE CASCADE/ ? 'CASCADE'
: $line =~ /ON UPDATE SET DEFAULT/ ? 'SET DEFAULT'
: '',
}
for split ',', $sfields;
} else {
push @return,
{
field => /`([^`]+)`/,
name => $name,
type => $type,
} for split ',', $5;
} ## end else [ if ( $line =~ /REFERENCES `([^`]+)` \(([^)]+)\)/(([(])))]
} ## end if ( $line =~ /(PRIMARY KEY|FOREIGN KEY|FULLTEXT KEY|UNIQUE KEY|KEY) (`([^`]+)`)? ?(\(([^)]+)\))?/((([(]))))
} ## end foreach my $line ( split /\n/...)
return @return;
} ## end if ( defined $tbl )
} ## end sub getIndex
=head2 getConstraintKeys()
=cut
sub getConstraintKeys {
my ( $self, @p ) = getSelf(@_);
my $tbl = $p[0];
my $key = $p[1];
my @return;
if ( defined $tbl ) {
$tbl = $m_dbh->quote_identifier($tbl);
my $hr = $self->fetch_hashref("SHOW CREATE TABLE $tbl");
foreach my $line ( split /\n/, $hr->{'Create Table'} ) {
my %keys;
if ( $line =~ /CONSTRAINT `([^`]+)` FOREIGN KEY \(([^)]+)\)/ ) {
my $i = 0;
for ( split ',', $2 ) {
/`([^`]+)`/;
$keys{$1} = 1;
} ## end for ( split ',', $2 )
push @return, $1 if ( $keys{$key} and $return[ $#return - 1 ] ne $1 );
} ## end if ( $line =~ /CONSTRAINT `([^`]+)` FOREIGN KEY \(([^)]+)\)/(([(])))
} ## end foreach my $line ( split /\n/...)
return @return;
} ## end if ( defined $tbl )
} ## end sub getConstraintKeys
=head2 GetAutoIncrement()
returns the auto_increment Column.
GetAutoIncrement(table)
=cut
sub GetAutoIncrement {
my ( $self, @p ) = getSelf(@_);
my $tbl = $p[0];
if ( defined $tbl ) {
$tbl = $m_dbh->quote_identifier($tbl);
my @caption = $self->fetch_AoH("show columns from $tbl");
my $r;
for ( my $j = 0 ; $j <= $#caption ; $j++ ) {
$r = $caption[$j]->{'Field'} if ( $caption[$j]->{'Extra'} eq 'auto_increment' );
} ## end for ( my $j = 0 ; $j <=...)
return $r;
} else {
return 0;
} ## end else [ if ( defined $tbl ) ]
} ## end sub GetAutoIncrement
=head2 fetch_string()
=cut
sub fetch_string {
my ( $self, @p ) = getSelf(@_);
my @a = $self->fetch_array(@p);
return $a[0];
} ## end sub fetch_string
#html erzeugende funktionen
=head2 GetDataBases()
returns a <select> list with the Databases.
=cut
sub GetDataBases {
my ( $self, @p ) = getSelf(@_);
my $name = $p[0] ? shift(@p) : 'm_ChangeCurrentDb';
my $change = $p[0] ? 'onchange="submitForm(this.form)"' : '';
my $m_sCurrentDb = $self->CurrentDb();
my @dbs = $self->fetch_array('show Databases');
my $return = qq|<select align="center" $change name="$name" style="width:75%" >|;
$return .=
$_ eq $m_sCurrentDb
? qq|<option value="$_" selected="selected" >$_(| . $self->TableCount4Db($_) . q|)</option>|
: qq|<option value="$_">$_(| . $self->TableCount4Db($_) . q|)</option>|
foreach @dbs;
$return .= '</select>';
return $return;
} ## end sub GetDataBases
=head2 TableCount4Db()
Gibt die anzahl der tabellen fuer die angegebene Datenbank zurueck.
=cut
sub TableCount4Db {
my ( $self, @p ) = getSelf(@_);
$p[0] = $m_dbh->quote_identifier( $p[0] );
my @count = $self->fetch_array("show tables from $p[0]");
warn $@ if $@;
return $#count > 0 ? $#count : 0;
} ## end sub TableCount4Db
=head2 GetCharacterSet()
gibt das Charset zu coalation zurueck.
GetCharacterSet(coalation);
=cut
sub GetCharacterSet {
my ( $self, @p ) = getSelf(@_);
my $c = shift @p;
if ( defined $c ) {
my $coalation = $self->fetch_hashref( "SHOW COLLATION like ?", $c );
return $coalation->{Charset};
} else {
return 0;
} ## end else [ if ( defined $c ) ]
} ## end sub GetCharacterSet
=head2 GetEngines()
gibt die verfuegbaren Engines zurueck.
GetEngines(tabelle);
=cut
sub GetEngines {
my ( $self, @p ) = getSelf(@_);
my $tbl = shift @p;
my $name = shift @p;
if ( defined $tbl ) {
my @co = $self->fetch_AoH('SHOW ENGINES');
my $status = $self->fetch_hashref( 'SHOW TABLE STATUS where `Name` = ? ', $tbl );
my $return = qq|<select class="editTable" name="$name">|;
$return .=
$_->{Engine} eq $status->{Engine}
? qq|<option value="$_->{Engine}" selected="selected" >$_->{Engine}</option>|
: qq|<option value="$_->{Engine}">$_->{Engine}</option>|
foreach @co;
$return .= '</select>';
return $return;
} else {
return 0;
} ## end else [ if ( defined $tbl ) ]
} ## end sub GetEngines
=head2 GetEngineForRow()
GetEngineForRow(tabelle, zeile);
=cut
sub GetEngineForRow {
my ( $self, @p ) = getSelf(@_);
my $tbl = shift @p;
my $name = shift @p;
if ( defined $tbl && defined $name ) {
my @co = $self->fetch_array('SHOW ENGINES');
my @EINGINES = $self->fetch_AoH( 'SHOW TABLE STATUS where `Name` = ? ', $tbl );
my $return = qq|<select class="editTable" name="$name">|;
$return .=
$_->{Engine} eq "@co"
? qq|<option value="$_->{Engine}" selected="selected" >$_->{Engine}</option>|
: qq|<option value="$_->{Engine}">$_->{Engine}</option>|
foreach @EINGINES;
$return .= '</select>';
return $return;
} else {
return 0;
} ## end else [ if ( defined $tbl && defined...)]
} ## end sub GetEngineForRow
=head2 GetNull()
gibt die NULL( NULL | not NULL ) auswahlliste zurueck
GetNull( selected extra, slect_name );
=cut
sub GetNull {
my ( $self, @p ) = getSelf(@_);
my $null = shift @p;
my $name = shift @p;
if ( defined $null && defined $name ) {
my $return = qq|<select class="editTable" name="$name">|;
$return .= qq|<option value="not NULL">not NULL</option>|;
$return .=
$null eq 'YES'
? qq|<option value="NULL" selected="selected">NULL</option>|
: qq|<option value="NULL">NULL</option>|;
$return .= q|</select>|;
return $return;
} else {
return 0;
} ## end else [ if ( defined $null && ...)]
} ## end sub GetNull
=head2 GetExtra()
gibt die extra(auto_increment) auswahlliste zurueck
GetExtra(selected extra, slect_name);
=cut
sub GetExtra {
my ( $self, @p ) = getSelf(@_);
my $selected = shift @p;
my $name = shift @p;
if ( defined $selected && defined $name ) {
my $return = qq|<select class="editTable" name="$name">|;
$return .= '<option value=""></option>';
$return .=
$selected eq "auto_increment"
? q|<option value="auto_increment" selected="selected">auto_increment</option>|
: q|<option value="auto_increment">auto_increment</option>|;
$return .= q|</select>|;
return $return;
} else {
return 0;
} ## end else [ if ( defined $selected...)]
} ## end sub GetExtra
=head2 GetColumnCollation()
gibt eine auswahlliste (select) zurueck.
GetColumnCollation( tabelle ,columne, name_select);
=cut
sub GetColumnCollation {
my ( $self, @p ) = getSelf(@_);
my $tbl = shift @p;
my $column = shift @p;
my $name = shift @p;
if ( defined $tbl && defined $column && defined $name ) {
$tbl = $m_dbh->quote_identifier($tbl);
my $col = $self->fetch_hashref( "show full columns from $tbl where field = ?", $column );
my @collation = $self->fetch_AoH("SHOW COLLATION");
my $return = qq|<select class="editTable" name="$name" style="width:100px;"><option></option>|;
unless ( $col->{Collation} ) {
$return .= qq|<option value="NULL" selected="selected" >NULL</option>|;
} else {
$return .=
$_->{Collation} eq $col->{Collation}
? qq|<option value="$_->{Collation}" selected="selected" >$_->{Collation}</option>|
: qq|<option value="$_->{Collation}">$_->{Collation}</option>|
foreach @collation;
} ## end else
$return .= '</select>';
return $return;
} else {
return 0;
} ## end else [ if ( defined $tbl && defined...)]
} ## end sub GetColumnCollation
=head2 GetCollation()
$sel = GetCollation( name, selected );
=cut
sub GetCollation {
my ( $self, @p ) = getSelf(@_);
my $name = shift @p;
my $selected = shift @p;
no warnings; #$selected maybe empty
my @collation = $self->fetch_AoH("SHOW COLLATION");
if ($name) {
my @a = $self->fetch_AoH("SHOW TABLE STATUS");
for ( my $i = 0 ; $i <= $#a ; $i++ ) {
$selected = $a[$i]->{Collation} if ( $a[$i]->{Name} eq $selected );
} ## end for ( my $i = 0 ; $i <=...)
} ## end if ($name)
my $return = qq|<select class="editTable" name="$name" style="width:100px;"><option></option>|;
$return .= qq|<option value="$_->{Collation}"| . ( $selected eq $_->{Collation} ? 'selected="selected"' : '' ) . qq|>$_->{Collation}</option>|
foreach @collation;
$return .= '</select>';
return $return;
} ## end sub GetCollation
=head2 GetCharset()
$sel = GetCharset(name,selected table);
=cut
sub GetCharset {
my ( $self, @p ) = getSelf(@_);
my $name = shift @p;
my $selected = shift @p;
my @Charset = $self->fetch_AoH("SHOW Charset");
if ($name) {
my @a = $self->fetch_AoH("SHOW TABLE STATUS");
for ( my $i = 0 ; $i <= $#a ; $i++ ) {
$selected = $a[$i]->{Collation} if ( $a[$i]->{Name} eq $selected );
} ## end for ( my $i = 0 ; $i <=...)
} ## end if ($name)
$selected = GetCharacterSet($selected);
my $return = qq|<select class="editTable" name="$name" style="width:100px;"><option></option>|;
$return .= qq|<option value="$_->{Charset}"| . ( $selected eq $_->{Charset} ? 'selected="selected"' : '' ) . qq|>$_->{Charset}</option>|
foreach @Charset;
$return .= '</select>';
return $return;
} ## end sub GetCharset
=head2 GetAttrs
$sel = GetAttrs($tbl, $field, $name );
=cut
sub GetAttrs {
my ( $self, @p ) = getSelf(@_);
my $tbl = shift @p;
my $select = shift @p;
my $name = shift @p;
if ($tbl) {
$tbl = $m_dbh->quote_identifier($tbl);
my $hr = $self->fetch_hashref("SHOW CREATE TABLE $tbl");
$select = $self->quote_identifier($select);
return qq|<select class="editTable" name="$name" style="width:100px;"><option></option><option value="UNSIGNED" |
. (
$hr->{'Create Table'} =~ /$select[^,]+UNSIGNED/ ? 'selected="selected"'
: ''
)
. q|>UNSIGNED</option><option value="UNSIGNED ZEROFILL" |
. (
$hr->{'Create Table'} =~ /$select[^,]+UNSIGNED ZEROFILL/ ? 'selected="selected"'
: ''
)
. q|>UNSIGNED ZEROFILL</option><option value="ON UPDATE CURRENT_TIMESTAMP" |
. (
$hr->{'Create Table'} =~ /$select[^,]+ON UPDATE CURRENT_TIMESTAMP/ ? 'selected="selected"'
: ''
) . q|>ON UPDATE CURRENT_TIMESTAMP</option></select>|;
} else {
return
qq(<select class="editTable" name="$name" style="width:100px;"><option></option><option value="UNSIGNED" )
. ( $select eq 'UNSIGNED' ? 'selected="selected"' : '' )
. q(>UNSIGNED</option><option value="UNSIGNED ZEROFILL" )
. ( $select eq 'UNSIGNED ZEROFILL' ? 'selected="selected"' : '' )
. q(>UNSIGNED ZEROFILL</option><option value="ON UPDATE CURRENT_TIMESTAMP" )
. ( $select eq 'ON UPDATE CURRENT_TIMESTAMP' ? 'selected="selected"' : '' )
. q(>ON UPDATE CURRENT_TIMESTAMP</option></select>);
} ## end else [ if ($tbl) ]
} ## end sub GetAttrs
=head2 GetColumns
$sel = GetColumns($tbl , $name, $selected);
=cut
sub GetColumns {
my ( $self, @p ) = getSelf(@_);
my $tbl = shift @p;
my $name = shift @p;
my $selected = $p[0] ? shift @p : '';
$tbl = $m_dbh->quote_identifier($tbl);
my @col = $self->fetch_AoH("show columns from $tbl");
my $return = qq|<select class="editTable" name="$name" style="width:100px;">|;
$return .= qq|<option value="$_->{Field}" | . ( $selected eq $_->{Field} ? 'selected="selected"' : '' ) . qq|>$_->{Field}</option>| foreach @col;
$return .= '</select>';
return $return;
} ## end sub GetColumns
=head2 addMessage
my %message = (
thread => $thread,
title => $headline,
body => $body,
thread => $thread,
cat => $cat,
attach => $sra,
format => $format,
id => $id,
user => $sUser,
attach => $m_sFilename,
ip => remote_addr(),
);
my $id = addMessage(\%message);
=cut
sub addMessage {
my ( $self, @p ) = getSelf(@_);
if ( $self->checkFlood( $p[0]->{ip} ) ) {
my $thread = defined $p[0]->{thread} ? $p[0]->{thread} : 'trash';
$thread = ( $thread =~ /^(\w{3,50})$/ ) ? $1 : 'trash';
$thread = $m_dbh->quote_identifier($thread);
my $headline = defined $p[0]->{title} ? $p[0]->{title} : 'headline';
$headline = ( $headline =~ /^(.{3,100})$/ ) ? $1 : 'Invalid headline';
my $sUser = defined $p[0]->{user} ? $p[0]->{user} : 'guest';
my $body = defined $p[0]->{body} ? $p[0]->{body} : 'Body';
my $cat = defined $p[0]->{cat} ? $p[0]->{cat} : 'news';
my $rght = $self->catright($cat);
my $attach = defined $p[0]->{attach} ? $p[0]->{attach} : 0;
my $format = defined $p[0]->{format} ? $p[0]->{format} : 'markdown';
my $m_sAction = defined $p[0]->{action} ? $p[0]->{action} : 'news';
my $sql = "insert into $thread (`title`,`body`,`attach`,`cat`,`right`,`user`,`action`,`format`) values(?,?,?,?,?,?,?,?)";
my $sth = $m_dbh->prepare($sql);
$sth->execute( $headline, $body, $attach, $cat, $rght, $sUser, $m_sAction, $format )
or warn $m_dbh->errstr;
my $id = $m_dbh->last_insert_id( undef, undef, qw(news news_id) );
$sth->finish();
return $id;
} else {
return 0;
} ## end else [ if ( $self->checkFlood...)]
} ## end sub addMessage
=head2 editMessage()
my %message = (
thread => $thread,
title => $headline,
body => $body,
thread => $thread,
cat => $cat,
attach => $sra,
format => $format,
id => $id,
user => $sUser,
attach => $m_sFilename,
ip => remote_addr(),
);
editMessage(\%message);
=cut
sub editMessage {
my ( $self, @p ) = getSelf(@_);
if ( $self->checkFlood( $p[0]->{ip} ) ) {
my $thread = defined $p[0]->{thread} ? $p[0]->{thread} : 'trash';
$thread = ( $thread =~ /^(\w{3,50})$/ ) ? $1 : 'trash';
$thread = $m_dbh->quote_identifier($thread);
my $refid = defined $p[0]->{id} ? $p[0]->{id} : 1;
my $headline = defined $p[0]->{title} ? $p[0]->{title} : 'headline';
$headline = ( $headline =~ /^(.{3,100})$/ ) ? $1 : 'Invalid headline';
my $sUser = defined $p[0]->{user} ? $p[0]->{user} : 'guest';
my $body = defined $p[0]->{body} ? $p[0]->{body} : 'Body';
my $attach = defined $p[0]->{attach} ? $p[0]->{attach} : 0;
my $format = defined $p[0]->{format} ? $p[0]->{format} : 'markdown';
my $cat = defined $p[0]->{cat} ? $p[0]->{cat} : 'news';
my $up =
defined $p[0]->{uploadpath}
? $p[0]->{uploadpath}
: '/srv/www/htdocs/downloads';
if ( $attach ne '0.0' ) {
my $sql_insert = qq/update $thread set title =?, body =? , attach= ?,format =?,user =?,cat =?,`right` =? where id = ?;/;
my $sth = $m_dbh->prepare($sql_insert);
$sth->execute( $headline, $body, $attach, $format, $sUser, $cat, $self->catright($cat), $refid )
or warn $m_dbh->errstr;
$sth->finish();
} else {
my $sql_insert = qq/update $thread set title =?, body = ? ,format = ?,user = ?,cat = ?,`right` =? where id = ?;/;
my $sth = $m_dbh->prepare($sql_insert);
$sth->execute( $headline, $body, $format, $sUser, $cat, $self->catright($cat), $refid )
or warn $m_dbh->errstr;
$sth->finish();
} ## end else [ if ( $attach ne '0.0' )]
} ## end if ( $self->checkFlood...)
} ## end sub editMessage
=head2 reply
my %reply =(
title => $headline,
body => $body,
id => $reply,
user => $sUser,
attach => $sra,
format => $html,
ip => remote_addr(),
);
reply(\%reply);
=cut
sub reply {
my ( $self, @p ) = getSelf(@_);
if ( $self->checkFlood( $p[0]->{ip} ) ) {
my $headline = defined $p[0]->{title} ? $p[0]->{title} : 'headline';
$headline = ( $headline =~ /^(.{3,100})$/ ) ? $1 : 'Invalid headline';
my $sUser = defined $p[0]->{user} ? $p[0]->{user} : 'guest';
my $body = defined $p[0]->{body} ? $p[0]->{body} : 'Body';
my $attach = defined $p[0]->{attach} ? $p[0]->{attach} : 0;
my $format = defined $p[0]->{format} ? $p[0]->{format} : 'markdown';
my $refid = defined $p[0]->{id} ? $p[0]->{id} : 1;
my $sql = "insert into replies (`title`,`body`,`attach`,`right`,`user`,`refererId`,`format`) values(?,?,?,?,?,?,?)";
my $sth = $m_dbh->prepare($sql);
$sth->execute( $headline, $body, $attach, $self->topicright($refid), $sUser, $refid, $format )
or warn $m_dbh->errstr;
$sth->finish();
} ## end if ( $self->checkFlood...)
} ## end sub reply
=head2 deleteMessage
$bool = $self->deleteMessage($table,$id);
=cut
sub deleteMessage {
my ( $self, @p ) = getSelf(@_);
my $p_sTable = $p[0];
my $id = $p[1];
my $sql_backup = "select * from $p_sTable Where id = '$id'";
my $sth_backup = $m_dbh->prepare($sql_backup);
$sth_backup->execute();
my $backup = $sth_backup->fetchrow_hashref();
my $c = ( $p_sTable eq 'replies' ) ? 'replies' : $backup->{cat};
my $refererId = ( $p_sTable eq 'replies' ) ? $backup->{refererId} : 0;
my $sql_trash =
"insert into `trash` (`table`,`oldId`,`title`,`body`,`date`,`user`,`right`,`attach`,`cat`,`sticky`,`refererId`,`format`) values(?,?,?,?,?,?,?,?,?,?,?)";
my $sth_trash = $m_dbh->prepare($sql_trash);
$sth_trash->execute(
$p_sTable, $id, $backup->{title}, $backup->{body}, $backup->{date}, $backup->{user},
$backup->{right}, $backup->{attach}, $c, $backup->{sticky}, $refererId, $backup->{format}
);
my $sql_delete = "DELETE FROM $p_sTable Where id = '$id'";
my $sth = $m_dbh->prepare($sql_delete);
$sth->execute() or warn $m_dbh->errstr;
$sth->finish();
return 1;
} ## end sub deleteMessage
=head2 readMenu()
@menu = $m_oDatabase->readMenu($sThread,$nRight,$nStart,$nEnd);
=cut
sub readMenu {
my ( $self, @p ) = getSelf(@_);
my $thread = $p[0];
my $p_nRight = $p[1];
my $p_nStart = $p[2];
my $p_nEnd = $p[3];
$p_nStart = 0 unless ( defined $p_nStart );
$p_nEnd = 10 unless ( defined $p_nEnd );
my $limit = $p_nEnd - $p_nStart;
my $sql_read = qq/select title,id from $thread where `right` <= $p_nRight order by date desc LIMIT $p_nStart , $limit/;
my $sth = $m_dbh->prepare($sql_read);
$sth->execute();
my @output;
while ( my @data = $sth->fetchrow_array() ) {
my $headline = $data[0];
my $id = $data[1];
$headline =~ s/(.{15}).+/$1.../;
my $nl = "javascript:requestURI('$m_sServerName$ENV{SCRIPT_NAME}?action=$thread&von=$p_nStart&bis=$p_nEnd');";
push @output,
{
text => $headline,
href => $nl,
};
} ## end while ( my @data = $sth->...)
$sth->finish();
return @output;
} ## end sub readMenu
=head2 rss()
$rss = $m_oDatabase->rss($thread,int start);
=cut
sub rss {
my ( $self, @p ) = getSelf(@_);
my $thread = $p[0];
$thread = 'news' unless ( defined $thread );
my $p_nStart = $p[1];
$p_nStart = 0 unless ( defined $p_nStart );
my $description = $p[2];
$description = 'Feed' unless ( defined $description );
my $time = localtime;
my $sql_read = qq/select *from $thread where `right` = '0' order by id desc LIMIT $p_nStart , 10/;
my $sth = $m_dbh->prepare($sql_read);
$sth->execute();
my @output;
push @output,
qq(<?xml version="1.0" encoding="UTF-8"?>\n<rss xmlns:atom="http://www.w3.org/2005/Atom" version="2.0"><channel><title><![CDATA[$thread]]></title>\n<description><![CDATA[$description]]></description>\n<link><![CDATA[$m_sServerName]]></link>\n<language>de</language>\n<pubDate><![CDATA[$time]]></pubDate>\n);
while ( my @data = $sth->fetchrow_array() ) {
my $headline = $data[0];
my $body = $data[1];
my $href = $data[9];
my $link = "$m_sServerName?$m_sServerName/cgi-bin/mysql.pl?action=reply&reply=$href&thread=news#$href";
push @output,
"\n<item>\n<title><![CDATA[$headline]]></title>\n<link><![CDATA[$link]]></link>\n<description><![CDATA[$body]]></description></item>";
} ## end while ( my @data = $sth->...)
push @output, "\n</channel>\n</rss>";
$sth->finish();
return "@output";
} ## end sub rss
=head2 searchDB()
searchDB($query,$column,$table,$rigt,$start,$end);
regexp search in tabelle ...
=cut
sub searchDB {
my ( $self, @p ) = getSelf(@_);
my $p_sQuery = $p[0];
eval { return 0 if /($p_sQuery)/; };
return "Invalid regexp : $@" if $@;
$p_sQuery = $self->quote($p_sQuery);
my $p_sCol = $p[1];
$p_sCol = $m_dbh->quote_identifier($p_sCol);
my $p_sTable = $p[2];
$p_sTable = $m_dbh->quote_identifier($p_sTable);
my $p_nRight = $p[3];
my $p_nStart = $p[4] ? $p[4] : 0;
my $p_nEnd = $p[5] ? $p[5] : 100;
my $limit = $p_nEnd - $p_nStart;
$p_nRight = $p_nRight =~ /(\d+)/ ? $1 : 0;
$p_nStart = $p_nStart =~ /(\d+)/ ? $1 : 0;
$limit = $limit =~ /(\d+)/ ? $1 : 10;
my $sql_select =
"SELECT * FROM $p_sTable WHERE `right` <= $p_nRight && ( $p_sCol REGEXP $p_sQuery || title REGEXP $p_sQuery ) order by date desc LIMIT $p_nStart , $limit ";
my $b =
'<table align="center" summary="layoutSearch" border="0" cellpadding="0" cellspacing="0" width="100%"><tr><td class="caption">Title</td><td class="caption">User</td><td class="caption">Datum</td></tr>';
my @messages = $self->fetch_AoH($sql_select);
for ( my $i = 0 ; $i <= $#messages ; $i++ ) {
my $body = $messages[$i]->{body};
if ( !utf8::is_utf8($body) ) {
utf8::decode($body);
} ## end if ( !utf8::is_utf8($body...))
$body =~ s/\[([^\]])+\]//gs;
$body =~ s?<[^>]+>??gs;
my $j = index $body, /$p[0]/;
$j = $j > 50 ? $j - 50 : 0;
$body = substr( $body, $j, 150 );
$body = encode_entities($body);
$body =~ s?($p[0])?<span style="color:red;">$1</span>?ig;
if ( !utf8::is_utf8( $messages[$i]->{title} ) ) {
utf8::decode( $messages[$i]->{title} );
} ## end if ( !utf8::is_utf8( $messages...))
$messages[$i]->{title} = encode_entities( $messages[$i]->{title} );
$messages[$i]->{title} =~ s?($p[0])?<span style="color:red;">$1</span>?ig;
my $link = "javascript:requestURI('$m_sServerName$ENV{SCRIPT_NAME}?action=showthread&reply=$messages[$i]->{id}','showthread','showthread');";
$b .=
qq(<tr><td class="values"><a href="$link" class="menuLink">$messages[$i]->{title}</a></td><td class="values">$messages[$i]->{user}</td><td align="right" class="values"><font size="-1">$messages[$i]->{date}</font></td></tr><tr><td colspan="3"><font size="-2">$body</font></td></tr>);
} ## end for ( my $i = 0 ; $i <=...)
$b .= '</table>';
return $b;
} ## end sub searchDB
=head2 fulltext()
@messages = fulltext(query,table);
fulltextsuche in tabelle ...
=cut
sub fulltext {
my ( $self, @p ) = getSelf(@_);
my $p_sQuery = $p[0];
eval { return 0 if /($p_sQuery)/; };
return "Invalid Query : <br/>" if $@;
$p_sQuery = $self->quote($p_sQuery);
my $p_sTable = $p[1];
$p_sTable = $m_dbh->quote_identifier($p_sTable);
my $p_nRight = $p[2];
my $p_nStart = $p[3] ? $p[3] : 0;
my $p_nEnd = $p[4] ? $p[4] : 100;
my $limit = $p_nEnd - $p_nStart;
$p_nRight = $p_nRight =~ /(\d+)/ ? $1 : 0;
$p_nStart = $p_nStart =~ /(\d+)/ ? $1 : 0;
$limit = $limit =~ /(\d+)/ ? $1 : 10;
my $b = '<table class="ShowTables"><tr><td class="caption">Title</td><td class="caption">User</td><td class="caption">Datum</td></tr>';
my @messages = $self->fetch_AoH(
"SELECT * FROM $p_sTable where `right` <= $p_nRight and MATCH (title,body) AGAINST($p_sQuery) order by date desc LIMIT $p_nStart , $limit");
for ( my $i = 0 ; $i <= $#messages ; $i++ ) {
my $body = $messages[$i]->{body};
if ( !utf8::is_utf8($body) ) {
utf8::decode($body);
} ## end if ( !utf8::is_utf8($body...))
$body =~ s/\[([^\]])+\]//gs;
$body =~ s?<[^>]+>??gs;
my $j = index $body, $p_sQuery;
$j = $j > 50 ? $j - 50 : 0;
$body = substr( $body, $j, 150 );
$body = encode_entities($body);
$body =~ s/($p[0])/<span style="color:red;">$1<\/span>/ig;
if ( !utf8::is_utf8( $messages[$i]->{title} ) ) {
utf8::decode( $messages[$i]->{title} );
} ## end if ( !utf8::is_utf8( $messages...))
$messages[$i]->{title} = encode_entities( $messages[$i]->{title} );
$messages[$i]->{title} =~ s/($p[0])/<span style="color:red;">$1<\/span>/ig;
my $link = "javascript:requestURI('$m_sServerName$ENV{SCRIPT_NAME}?action=showthread&reply=$messages[$i]->{id}','showthread','showthread')";
$b .=
qq(<tr><td class="values"><a href="$link" class="menuLink">$messages[$i]->{title}</a></td><td class="values">$messages[$i]->{user}</td><td align="right" class="values"><font size="-1">$messages[$i]->{date}</font></td></tr><tr><td colspan="3"><font size="-2">$body</font></td></tr>);
} ## end for ( my $i = 0 ; $i <=...)
$b .= '</table>';
return $b;
} ## end sub fulltext
=head2 getAction
$hashref = $m_oDatabase->getAction($m_sAction);
=cut
sub getAction {
my ( $self, @p ) = getSelf(@_);
my $m_sAction = $p[0];
my $sql = q/select * from actions where action = ?/;
my $sth = $m_dbh->prepare($sql) or warn $m_dbh->errstr;
$sth->execute($m_sAction);
my $hr = $sth->fetchrow_hashref;
$sth->finish();
return $hr;
} ## end sub getAction
=head2 getActionRight
$right = $m_oDatabase->getActionRight($m_sAction);
=cut
sub getActionRight {
my ( $self, @p ) = getSelf(@_);
my $m_sAction = $p[0];
my $sql = q/select `right` from actions where action = ?/;
my $sth = $m_dbh->prepare($sql) or warn $m_dbh->errstr;
$sth->execute($m_sAction);
my $hr = $sth->fetchrow_array;
$sth->finish();
return $hr;
} ## end sub getActionRight
=head2 topicright()
topicright(id);
=cut
sub topicright {
my ( $self, @p ) = getSelf(@_);
my $id = $p[0];
my $sql = 'SELECT `right` FROM news where id = ?';
my $sth = $m_dbh->prepare($sql);
$sth->execute($id);
my @q = $sth->fetchrow_array;
$sth->finish();
return $q[0];
} ## end sub topicright
=head2 getSelf()
getSelf or CGI
=cut
sub getSelf {
return @_ if defined( $_[0] ) && ( !ref( $_[0] ) ) && ( $_[0] eq 'DBI::Library::Database' );
return (
defined( $_[0] ) && ( ref( $_[0] ) eq 'DBI::Library::Database'
|| UNIVERSAL::isa( $_[0], 'DBI::Library::Database' ) )
)
? @_
: ( $DBI::Library::Database::m_sDefaultClass->new, @_ );
} ## end sub getSelf
package DBI::Library::Database::db;
use vars qw(@ISA);
@ISA = qw(DBI::Library:::db);
=head2 prepare()
=cut
sub prepare {
my ( $m_dbh, @args ) = @_;
my $sth = $m_dbh->SUPER::prepare(@args) or return;
return $sth;
} ## end sub prepare
package DBI::Library::Database::st;
use vars qw(@ISA);
@ISA = qw(DBI::Library::st);
=head2 execute()
=cut
sub execute {
my ( $sth, @args ) = @_;
my $rv = $sth->SUPER::execute(@args) or return;
return $rv;
} ## end sub execute
=head2 fetch()
=cut
sub fetch {
my ( $sth, @args ) = @_;
my $row = $sth->SUPER::fetch(@args) or return;
return $row;
} ## end sub fetch
=head1 SEE ALSO
L<MySQL::Admin::GUI> L<DBI> L<DBI::Library>
=head1 AUTHOR
Dirk Lindner <lze@cpan.org>
=head1 LICENSE
Copyright (C) 2005-2016 by Hr. Dirk Lindner
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public License
as published by the Free Software Foundation;
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
=cut
1;