PerlForms Code

#!/usr/bin/perl -w
#
# Copyright 2008 Samuel Borsutzky
#
# This file is part of PerlForms.
#
# PerlForms is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# PerlForms 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 General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with PerlForms.  If not, see <http://www.gnu.org/licenses/>.
#
#
#

package Db;

#
# database connection and methods
#

use DBI;

#my($commit)=500; #funzt ok
#my($insert)=3; #funzt ok
my($commit)=500;
my($insert)=20;
my($commcnt)=0;
my($inscnt)=0;
use vars '$debug';

print STDERR __PACKAGE__," loading...\n";

sub new {
    my($db)={};
    bless( $db, shift );
    my(%arg)=@_;
    $db->{dsn}="DBI:mysql:";
#    $db->{dsn}="DBI:Pg:";
    if(defined($arg{host})) {
        $db->{dsn}.="database=".$arg{dbname}.";";
        $db->{dsn}.="host=".$arg{host}.";";
        unless(defined($arg{port})) {
            $arg{port}="3306";
        }
        $db->{dsn}.="port=".$arg{port}.";";
    } elsif($db->{dsn}=~/Pg/) {
        $db->{dsn}.="dbname=".$arg{dbname};
    } else {
        $db->{dsn}.=$arg{dbname};
    }
    if(!defined($arg{user})) {
        $arg{user}=$arg{dbname};
    }
    if(!defined($arg{passwd})) {
        $arg{passwd}=$arg{user};
    }
    
    my($dbattr);
    $dbattr->{AutoCommit}=0;
    my($status)=$db->{dbh}=DBI->connect($db->{dsn},$arg{user},$arg{passwd},$dbattr);
    unless($status) {
        print STDERR __PACKAGE__."->new: DBI->connect failed: ".$DBI::errstr."\n";
        return undef;
    }
    $db;
}

sub exec {
    my($self)=shift;
    my($sql)=shift;
    
    $sql=~s/,\s*from/\n        /g;
    $sql=~s/,\s*where/\n        /g;
    $sql=~s/where\s*and/where\n            /g;

    my($sth);
    unless($sth=$self->{dbh}->prepare($sql)) {
        warn(__PACKAGE__."->exec: Prepare failed: ".$!);
        return undef;
    }
    unless($sth->execute) {
        warn(__PACKAGE__."->exec: Execute failed: ".$!);
        return undef;
    }
    my($result);
    unless($result=$sth->fetchall_arrayref) {
        warn(__PACKAGE__."->exec: fetchall_arrayref failed: ".$!);
        return undef;
    }
    if(++$commcnt>$commit) {
        unless($self->{dbh}->commit) {
            warn(__PACKAGE__."->exec: commit failed: ".$!);
            return undef;
        } else {
            $commcnt=0;
        }
    }
    $sth->finish;
    $result;
}

sub gettable {
    $self=shift;
    my(%arg)=@_;
    my($sql)="select * from ".$arg{table};
    $sql.=" order by ".$arg{sortkey} if(defined($arg{sortkey}) and $arg{sortkey}=~/\w/);
    my($sth)=$self->{dbh}->prepare($sql) or die("SQL-Query prepare failed: ".$sql."\n".$!);
    $sth->execute or die("SQL-Query failed: ".$sql."\n".$!);
    return($sth->fetchall_arrayref);
}

sub beg_ins {
    my($self)=shift;
    my($table)=shift;
    my($cols)=shift;
    my($vals)=shift;
    $self->{curcols}=$cols;
    $cols=~s/,$//g;
    $self->{cursql}="insert into ".$table." (".$cols.") values ";
    if(defined($vals)) {
        $vals=~s/,$//g;
        $self->{cursql}.="(".$vals.")," if defined($vals);
    }
    $self->{curtable}=$table;
}

sub exec_ins {
    my($self)=shift;
    $self->{cursql}=~s/,$//;
    $debug && print STDERR "Executing SQL insert: ".$self->{cursql}."\n";
    $sth=$self->{dbh}->prepare($self->{cursql}) or die;
    #print "\n".$self->{cursql}."\n";
    $sth->execute or print STDERR "Problem: ".$self->{cursql}."\n\n";
    #print $self->{cursql};
    $sth->finish;
    undef($self->{curtable});
    undef($self->{cursql});
    $inscnt=0;
    if(++$commcnt>$commit) {
        $self->{dbh}->commit;
        print "Commit.\n";
        $commcnt=0;
    }
}

sub insert {
    my($self)=shift;
    my($mode)=shift; ## mode==1 heisst nur einzelner insert, keine liste, import, etc.
    my($table)=shift;
    my($pair,@pairs,$n,$v,$cols,$vals);
    @pairs=@_;

    # spalten, werte zerlegen und zusammenfassen
    foreach $pair (@pairs) {
        ($n,$v)=split(/=/,$pair);
        $cols.=$n.",";
        $v=~s/^\s*\'\s*//g;
        $v=~s/\s*\'\s*$//g;
        $v=~s/\'/\\\'/g;
        $vals.="'".$v."',";
    }

    if(defined($self->{curtable}) and $self->{curtable} ne "") {

        # zusätzliche values anhängen wenn gleiches insert, ansonst. ausführen und neu aufbauen
        if($table eq $self->{curtable} and $cols eq $self->{curcols}) {

            $vals=~s/,$//;
            $self->{cursql}.="(".$vals."),";

            # wenn max. anz. zeilen erreicht ist, dann ausführen
            $self->exec_ins if($inscnt++>=$insert);

        } else {
            $self->exec_ins;
            $self->beg_ins($table,$cols,$vals);

            # falls einzelner insert, gleich ausführen
            $self->exec_ins if($mode eq "1");
        }
    
    } else {

        # sql-kommando aufbauen (da noch nicht geschehen)
        $self->beg_ins($table,$cols,$vals);

        # falls einzelner insert, gleich ausführen
        $self->exec_ins if($mode eq "1");

    }
    #print "letzte? ".$self->{cursql}."\n" if(defined($self->{cursql}));
}

sub delete {
    my($self)=shift;
    my($table)=shift;
    my(@pairs)=@_;
    my($sql)="delete from ".$table." where ";
    foreach $pair (@pairs) {
        if(!(($n,$v)=split(/=/,$pair))) { 
            print STDERR "Mism: ".$pair."\n";
            next; 
        }
        $sql.=$n."='".$v."' and ";
    }
    $sql=~s/and\ *$//g;
    print STDERR "db: sql: ".$sql."\n";
    #$sth=$self->{dbh}->prepare($sql);
    #$sth->execute or die;
    my($result)=$self->{dbh}->do($sql) or print STDERR "db SQL-Query failed.";
#    if(++$commcnt>9) {
    if(++$commcnt>$commit) {
        $self->{dbh}->commit;
        $commcnt=0;
    }
    #$sth->finish;
    ### dbh->do gibt bei erfolg die anzahl der betr records, sonst undef zurück. also:
    return 1 if(defined($result));
}

sub nofrecs {
    my($self)=shift;
    my($table)=shift;
    my(@crits)=@_;
    my($result);
    my($sql)="select count(*) from ".$table;
    $sql.=" where ".&where(@crits) if(@crits>0);
    #print $sql."\n";
    my($sth)=$self->{dbh}->prepare($sql) or die("SQL-Query failed: ".$sql);
    $sth->execute or die("SQL-Query failed: ".$sql);
    $result=$sth->fetchall_arrayref;
    ($result->[0]->[0]);
}

sub nofuser {
    my($self)=shift;
    my($table)=shift;
    my(@crits)=@_;
    my($sql)="select count(*) sum, username from ".$table;
    $sql.=" group by username order by sum";
    my($sth)=$self->{dbh}->prepare($sql) or die;
    $sth->execute or die;
    $result=$sth->fetchall_arrayref;
    $sth->finish;
    $result;

}

sub select {
    my($self)=shift;
    my($table)=shift;
    my(@crits)=@_;
    my($sql)="select * from ".$table;
    $sql.=" where ".&where(@crits) if(@crits);
    #print $sql."\n";
    my($sth)=$self->{dbh}->prepare($sql) or die;
    $sth->execute or die;
    $sth->fetchall_arrayref;
}

sub hashref {
    ## select ausführen und daten in einem hash(ref) of hashrefs zurückgeben
    my($self)=shift;
    my($sql)=$self->tidy(shift);
    
#    $sql=~s/\n\s*\n/\n/g;
#    $sql=~s/where\s*and\s*/where\n            /g;
#    $sql=~s/,\s*from/\n        /g;
#    $sql=~s/\s*,\s*where/\n        where/g;
#    $sql=~s/\s*and\s*$//g;
#    $sql=~s/\s*where\s*$//g;
#    $sql=~s/where\s*order by/order by/g;
#    $sql=~s/\s*,\s*$//g;
    
    my($sth);
    unless($sth=$self->{dbh}->prepare($sql)) {
        warn(__PACKAGE__."->hashref: prepare failed. ".$self->{dbh}->errstr."\nSQL-Query: ".$sql."\n");
        return undef;
    }
    
    unless($sth->execute) {
        warn(__PACKAGE__."->hashref: prepare failed. ".$self->{dbh}->errstr."\nSQL-Query: ".$sql."\n");
        return undef;
    }
    
    my($rec,%data);
    while($rec=$sth->fetchrow_hashref) {
#        return undef unless $rec->{name};
#        next unless defined($rec) and ref($rec);
        if(defined($rec->{name})) {
            $data{$rec->{name}.$rec->{id}}=$rec;
        } elsif(defined($rec->{id})) {
            $data{$rec->{id}}=$rec;
        } else {
            warn(__PACKAGE__."->hashref: Record has no ID! (".join(",",keys(%$rec)).") (".join(",",values(%$rec)).")\n");
        }
    }

    $sth->finish;
    
    %data?\%data:{};
}

sub tidy {
    my($self)=shift;
    my($sql)=shift;

#    $sql=~s/\s+/ /g;
#    $sql=~s/       / /g;
#    $sql=~s/      / /g;
#    $sql=~s/     / /g;
#    $sql=~s/    / /g;
#    $sql=~s/   / /g;
#    $sql=~s/  / /g;
    $sql=~s/\n\s*\n/\n/g;
    $sql=~s/\s*,\s*$//g;                          ## kommas am ende der query
    $sql=~s/\s*group by\s*$//g;                   ## 'group by' ohne etwas dahinter
    $sql=~s/and\s*order by/order by/g;            ## 'and'      gefolgt durch 'order by'
    $sql=~s/\s*and\s*$//g;                        ## 'and'      ohne etwas dahinter
    $sql=~s/where\s*order by/order by/g;          ## 'where'    gefolgt durch 'order by'
    $sql=~s/where\s*and\s*/where\n            /g; ## 'where'    gefolgt durch 'and'
    $sql=~s/\s*where\s*$//g;                      ## 'where'    ohne etwas dahinter
    $sql=~s/\s*,\s*where/\n        where/g;       ## 'where' mit komma davor
    $sql=~s/,\s*left outer/\n                    left outer/g; ## 'join'  mit komma davor
    $sql=~s/,\s*join/ join /g;                    ## 'join'  mit komma davor
    $sql=~s/,\s*from/\n        from/g;            ## 'from'  mit komma davor
    $sql=~s/\s*,\s*$//g;
    
    return $sql;
}

sub update {
    my($self)=shift;
    my($table)=shift;
    my($set)=shift;
    my(@crits)=@_;
    $set=~s/=([^'])/='$1/;
    $set=~s/,([^'])/',$1/;
    $set=~s/([^'])$/$1'/;
#    print(STDERR __PACKAGE__."->update WARNING: Commas in the ")  ## warnen, wenn kommas innerhalb von hochkommas vorkommen...
    my($sql)="update ".$table." set ".$set." where ".&where(@crits);
    $debug && print(STDERR "SQL-Query: ".$sql."\n");

    my($sth)=$self->{dbh}->prepare($sql)
        or print(STDERR "dbh->prepare failed: ".$self->{dbh}->errstr."\n");
        
    $sth->execute or warn(__PACKAGE__."->update: SQL-Query failed: ".$sql."\n");

    if($@) {
        print(STDERR "sth->execute failed: ".$@."\n");
        return undef;
    }

    $sth->finish or print(STDERR "sth->finish failed: ".$sth->errstr);
    $self->{dbh}->commit;
    if(++$commcnt>$commit) {
#    if(++$commcnt>9) {
        $self->{dbh}->commit;
        $commcnt=0;
    }
    $debug && print(STDERR "Update done.\n");
}

sub createtable {
    $self=shift;
    $table=shift;
    $fields=shift;
    $fields=~s/\n//g;
    $fields=~s/\ +/\ /g;
    my($sql)="create table ".$table." (".$fields.")";
    $sth=$self->{dbh}->prepare($sql) or die;
    $sth->execute or die $sql;
    if(++$commcnt>$commit) {
#    if(++$commcnt>9) {
        $self->{dbh}->commit;
        $commcnt=0;
    }
    $sth->finish;
}

sub droptable {
    my($table)=shift;
    my($tablename)=shift;
    my($sth)=$table->{dbh}->prepare("drop table ".$tablename);
    $sth->execute or print STDERR "drop failed.\n";
}

sub where {
    #my($self)=shift;
    my(@pairs)=@_;
    return if(@pairs<1);
    my($where);
    foreach my $pair (@pairs) {
        my($n,$v)=split(/=/,$pair);
        if($v=~/^\d+$/ or $v eq "null" or $v=~/^'[^']*'$/) {
            $where.=$n."=".$v." and ";
        } else {
            $where.=$n."='".$v."' and ";
        }
    }
    $where=~s/and\ *$//g;
    $where;
}

sub sql_builder {
    # expects: \@select, \@from, \%where
    my($self)=shift;# if($_[0]->can("VERSION"));
    my($select)=shift;
    my($from)=shift;
    my($where)=shift;
    my(%arg)=@_;

    my($sql)="
        select
            ".join(",\n            ",@$select)."
        from
            ".join(",\n            ",@$from)."
        where
    ";
    
    while(my($attrib,$val)=each(%$where)) {
        my$pair;
        if($val=~/^\s*\-?\d+\s*$/ or $val eq "null") {
            $pair=$attrib."=".$val;
        } else {
            $val=~s/'/\\'/g;
            $pair=$attrib."='".$val."'";
        }
        $sql.="        and ";
        if($arg{"ornull"}) {
            $sql.="(".$pair." or ".$attrib." is null)"
        } else {
            $sql.=$pair
        }
        $sql.="\n    ";
    }
    
    return $self->tidy($sql);
}

sub trunctable {
    $self=shift;
    $table=shift;
    my($sth)=$self->{dbh}->prepare("truncate ".$table);
    $sth->execute or print STDERR "truncate failed!\n";
    $sth->finish;
}

sub close {
    my($self)=shift;
    #print "Close mit einem Inscnt von ".$inscnt."\n";
    if( defined($self->{cursql}) ) {
        #print "not yet executed: ".$self->{cursql}."\n";
        $self->exec_ins
    }
    if( defined( $commcnt and $commcnt>0 ) ) {
        #print "#transactions to commit: ".$commcnt."\n";
        $self->{dbh}->commit;
    }
    $self->{dbh}->disconnect;
    #print "DB disconnected.\n";
}



package main;

return 1;