#!/devtool/local/bin/perl
#
# $DateTime: 2002/06/10 14:15:26 $
# $Change: 22128 $
#
# Desc:
#
#    ========== licence begin LGPL
#    Copyright (C) 2002 SAP AG
#
#    This library 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; either
#    version 2.1 of the License, or (at your option) any later version.
#
#    This library 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.
#
#    You should have received a copy of the GNU Lesser General Public
#    License along with this library; if not, write to the Free Software
#    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
#    ========== licence end
#

package qadb;

@ISA = ('Exporter');
@EXPORT = ('new', 'new_test', 'lock', 'unlock');


use DBI;
use Net::SMTP;
use Net::HTTP;
use Sys::Hostname;

sub new_test {
    my $name = shift;
    my $args = shift;
    my $self = {};
    my %fields;

    my @required_fields = ('IDPLATFORM', 'VERSION', 'IDQASTATUS');
    #
    # Initaialize Error-Handlers
    $self->{error_code} = 0;
    $self->{error_text} = "";

    #
    # Initialize the DBI
    my %dbi_attr = ( PrintError => 0, Raise_error => 0);

    $self->{dbh} = DBI->connect('DBI:Proxy:hostname=10.31.165.32;port=6666;dsn=DBI:ODBC:10.17.74.60:PTS', 'TESTER', 'TESTER', \%dbi_attr) or
        $self->{error_code} = 1;

    if ($self->{error_code} == 1) {
        my $outstr = "########################################################\nARGUMENTS:\n";
        foreach $y (keys(%$args)) {
            $outstr .= "$y = $$args{$y} \n";
        }
        $self->{error_text} = &throw_err("Could not connect to Database:\n $outstr \n $DBI::errstr");
        return bless $self;
    }

    my $x; # Loop-Helpers
    my $y; #
    my $match_count = 0; # Counts the matches of given arguments with required db-fields
    @required_fields = sort(@required_fields);
    foreach $x (@required_fields) {
        print $x . "\n";
        foreach $y (keys(%$args)) {
            if ($x  =~ /^$y$/i) {
                print "Match! $x \n";
                $match_count++;
                $fields{$x} = $$args{$y};
                delete($$args{$y});
                last;
            }
        }
    }

    #
    # Check how to fill out the SQL-Statement correctly
    if ($match_count != @required_fields) {
        #
        # First: Check the platform
        if (!scalar(grep /^IDPLATFORM$/i, keys(%fields))) {
            if (scalar(grep /^PLATFORM$/i, keys(%$args)) == 1) {
                my $sth = $self->{dbh}->prepare("SELECT COUNT(id) FROM platforms WHERE DESCTEXT = '" . $$args{'PLATFORM'} . "'");
                $sth->execute();
                if (($sth->fetchrow_array)[0] != 1) {
                    $self->{error_code} = 1;
                    $self->{error_text} = &throw_err("Counld not find you which platform you wanted: $$args{'PLATFORM'} \n");

                    $sth->finish();
                    $self->{'dbh'}->disconnect();
                    delete $self->{'dbh'};
                    return bless $self;
                }

                my $sth = $self->{dbh}->prepare("SELECT id FROM platforms WHERE DESCTEXT = '" . $$args{'PLATFORM'} . "'");
                $sth->execute();
                $fields{'IDPLATFORM'} = (($sth->fetchrow_array)[0]);
                $sth->finish();
            }
            else {
                my $sth = $self->{dbh}->prepare("SELECT COUNT(id) FROM platforms WHERE perltext = '" . $^O . "'");
                $sth->execute();
                my $platform_count =  ($sth->fetchrow_array)[0];
                if ($platform_count != 1) {
                    $self->{error_code} = 1;
                    $self->{error_text} = &throw_err("Error while trying to figure out the platform we were running on:\n $^O occurs $platform_count in the Database.\n");

                    $sth->finish();
                    $self->{'dbi'}->disconnect();
                    delete $self->{'dbh'};

                    return bless $self;
                }
                my $sth = $self->{dbh}->prepare("SELECT id FROM platforms WHERE perltext = '" . $^O . "'");
                $sth->execute();
                $d = ($sth->fetchrow_array)[0];
                $sth->finish();
                $fields{'IDPLATFORM'} = $d;
            }
            $match_count++;
        }
        # second: check the QAStatus
        if (!scalar(grep /^IDQASTAUS$/i, keys (%fields)) and (scalar(grep/^QASTATUS$/, keys(%$args)) == 1)) {
            $$args{QASTATUS} =~ tr/[a-z]/[A-Z]/;

            my $sth = $self->{dbh}->prepare("SELECT COUNT(id) FROM qastatus WHERE desctext = '" . $$args{'QASTATUS'} . "'");
            $sth->execute();

            if (($sth->fetchrow_array)[0] != 1) {
                $self->{error_code} = 1;
                $self->{error_text} = &throw_err("Could not find out whiche QASTATUS could me ment with $$args{'QASTATUS'}\n");

                $sth->finish();
                $self->{'dbh'}->disconnect();
                delete $self->{'dbh'};

                return bless $self;
            }

            my $sth = $self->{dbh}->prepare("SELECT id FROM qastatus WHERE desctext = '" . $$args{'QASTATUS'} . "'");
            $sth->execute();

            $fields{'IDQASTATUS'} = ($sth->fetchrow_array)[0];
            $match_count++;
        }

        if ($match_count != @required_fields) {
                $self->{error_code} = 1;
                $self->{error_text} = &throw_err("The arguments given do not match the needed arguments\n");

                $self->{'dbh'}->disconnect();
                delete $self->{'dbh'};

                return bless $self;
        }

    }
    print "SELECT * FROM makes WHERE idobjstatus > 999 AND idplatform = $fields{'IDPLATFORM'} AND idqastatus = $fields{'IDQASTATUS'} AND version = '$fields{'VERSION'}' ORDER BY id DESC ";
    my $sth = $self->{dbh}->prepare("SELECT * FROM makes WHERE idobjstatus > 999 AND idplatform = $fields{'IDPLATFORM'} AND " .
                " idqastatus = $fields{'IDQASTATUS'} AND version = '$fields{'VERSION'}' ORDER BY id DESC ");
    $sth->execute();

    %field = %{$sth->fetchrow_hashref};


    while (($key, $value) = each (%field)) {
        print "$key = $value\n";
        $self->{$key} = $value;
    }

    my $sth = $self->{'dbh'}->prepare("SELECT relevance, all_ptl, lc_ptl, oltp_ptl FROM to_test WHERE version = '$fields{'VERSION'}' and buildpfx = '$self->{'BUILDPFX'}' and idplatform = $fields{'IDPLATFORM'}");
    $sth->execute();

    my %relevant = %{$sth->fetchrow_hashref};


    my $cmdstring = "SELECT count(idobjstatus) FROM makes WHERE id = $self->{'ID'} AND idobjstatus > 2900";
    my $sth = $self->{'dbh'}->prepare($cmdstring);
    $sth->execute();
    my $tested = ($sth->fetchrow_array)[0];

    my $parseme = (split('@', $relevant{$relevant{'RELEVANCE'}}))[$tested];

    $self->{'worktests'}    = [];
    $self->{'weekendtests'} = [];
    $self->{'lowtests'}     = [];
    $self->{'lowtests_we'}  = [];

    foreach $i (split('&', $parseme)) {
        my @variants = split(/\|/, $i);

        my $workday  = ((split(/%/, $variants[0]))[0]);
        my $weekend  = ((split(/%/, $variants[-1]))[0]);


        if ($workday =~ /^sut/) {
            push(@{$self->{'lowtests'}}, $workday);
	    push(@{$self->{'lowtests_we'}}, $weekend);
        }
        else {
            push(@{$self->{'worktests'}},    $workday);
            push(@{$self->{'weekendtests'}}, $weekend);
        }
    }

    my $sth = $self->{'dbh'}->prepare("SELECT seqname, instpfx FROM testnames");
    $sth->execute();

    my $namesref = $sth->fetchall_arrayref();

    $self->{'testnames'} = {};
    foreach my $namerow (@$namesref) {
        $self->{'testnames'}->{(@$namerow)[0]} = (@$namerow)[1];
    }

    $self->{dbh}->disconnect();
    delete $self->{'dbh'};

    return bless $self;
}

sub new {
    #
    # Lets get initialized
    #
    my $name = shift;
    my $args = shift;
    my $self = {};
    my %fields;

    my %dbi_attr = ( PrintError => 0, Raise_error => 0);
    #
    # Initaialize Error-Handlers
    if ($^O =~ /MSWin32/i) {
        $self->{'delimit'}       = "\\"; # As we know, Windows uses backslashes
        $self->{'pathsep'}       = ";";
    }
    else {
        $self->{'delimit'}       = "/";
        $self->{'pathsep'}       = ":";
    }

    $self->{error_code} = 0;
    $self->{error_text} = "";
    $self->{dbh} = DBI->connect('DBI:Proxy:hostname=10.31.165.32;port=6666;dsn=DBI:ODBC:10.17.74.60:PTS', 'TESTER', 'TESTER', \%dbi_attr) or
        $self->{error_code} = 1;

    if ($self->{error_code} == 1) {
        $self->{error_text} = &throw_err("Could not connect to Database:\n $DBI::errstr");
        return bless $self;
    }
    if (keys (%$args) == 1) {
        my ($id_name, $id_value) = each (%$args);
        if ($id_name =~ /ID/i) {
            $fields{'ID'} = $id_value;
        }
        else {
            $self->{error_code} = 1;
            $self->{error_text} = &throw_err("The given parameters was not correct - I need an ID.s\n");

            $self->{'dbh'}->disconnect();
            delete $self->{'dbh'};

            return bless $self;
        }
    }
    else {
        my @required_fields;
        my $sth = $self->{dbh}->prepare("SELECT columnname FROM columns WHERE mode = 'MAN' AND tablename = 'MAKES'");
        $sth->execute();
        while (my $row = $sth->fetchrow_arrayref) {
            push(@required_fields, @$row[0]);
        }
        @required_fields = sort (@required_fields);
        $sth->finish();

        my $x; # Loop-Helpers
        my $y; #
        my $match_count = 0; # Counts the matches of given arguments with required db-fields
        foreach $x (@required_fields) {
            foreach $y (keys(%$args)) {
                if ($x  =~ /^$y$/i) {
                    $match_count++;
                    $fields{$x} = $$args{$y};
                    delete($$args{$y});
                    last;
                }
            }
        }
        if ($match_count != @required_fields) {
            if (!scalar(grep /^IDPLATFORM$/i, keys(%fields))) {
                if (scalar(grep /^PLATFORM$/i, keys(%$args)) == 1) {
                    my $sth = $self->{dbh}->prepare("SELECT COUNT(id) FROM platforms WHERE DESCTEXT = '" . $$args{'PLATFORM'} . "'");
                    $sth->execute();
                    if (($sth->fetchrow_array)[0] != 1) {
                        $self->{error_code} = 1;
                        $self->{error_text} = &throw_err("Counld not find you which platform you wanted: $$args{'PLATFORM'} \n");

                        $sth->finish();
                        $self->{'dbh'}->disconnect();
                        delete $self->{'dbh'};

                        return bless $self;
                    }

                    my $sth = $self->{dbh}->prepare("SELECT id FROM platforms WHERE DESCTEXT = '" . $$args{'PLATFORM'} . "'");
                    $sth->execute();
                    $fields{'IDPLATFORM'} = (($sth->fetchrow_array)[0]);

                    $sth->finish();
                }
                else {
                    my $sth = $self->{dbh}->prepare("SELECT COUNT(id) FROM platforms WHERE perltext = '" . $^O . "'");
                    $sth->execute();
                    my $platform_count =  ($sth->fetchrow_array)[0];
                    if ($platform_count != 1) {
                        $self->{error_code} = 1;
                        $self->{error_text} = &throw_err("Error while trying to figure out the platform we were running on:\n $^O occurs $platform_count in the Database.\n");

                        $sth->finish();
                        $self->{'dbh'}->disconnect();
                        delete $self->{'dbh'};

                        return bless $self;
                    }
                    my $sth = $self->{dbh}->prepare("SELECT id FROM platforms WHERE perltext = '" . $^O . "'");
                    $sth->execute();
                    $fields{'IDPLATFORM'} = ($sth->fetchrow_array)[0];

                    $sth->finish();
                }
                $match_count++;
            }

            if (!scalar(grep /^IDQASTAUS$/i, keys (%fields)) and (scalar(grep/^QASTATUS$/, keys(%$args)) == 1)) {
                $$args{QASTATUS} =~ tr/[a-z]/[A-Z]/;

                my $sth = $self->{dbh}->prepare("SELECT COUNT(id) FROM qastatus WHERE desctext = '" . $$args{'QASTATUS'} . "'");
                $sth->execute();

                if (($sth->fetchrow_array)[0] != 1) {
                    $self->{error_code} = 1;
                    $self->{error_text} = &throw_err("Could not find out whiche QASTATUS could me ment with $$args{'QASTATUS'}\n");

                    $sth->finish();
                    $self->{'dbh'}->disconnect();
                    delete $self->{'dbh'};

                    return bless $self;
                }

                my $sth = $self->{dbh}->prepare("SELECT id FROM qastatus WHERE desctext = '" . $$args{'QASTATUS'} . "'");
                $sth->execute();

                $fields{'IDQASTATUS'} = ($sth->fetchrow_array)[0];
                $match_count++;
            }

            if ($match_count != @required_fields) {
                    $self->{error_code} = 1;
                    $self->{error_text} = &throw_err("The arguments given do not match the needed arguments\n");

                    $sth->finish();
                    $self->{'dbh'}->disconnect();
                    delete $self->{'dbh'};

                    return bless $self;
            }

        }


        ######
        ## Now, start to check if the there are already entries in BUILD_PURPOSE and RELEVANT_TESTS


        #
        # 1. Dateien lesen
        #

        my $hits = 0;

        my %profiles;
        foreach $vmake_entry (split(",", $ENV{'VMAKE_PATH'})) {
            $pathname = "${vmake_entry}$self->{'delimit'}sys"
                . "$self->{'delimit'}src$self->{'delimit'}jtest"
                . "$self->{'delimit'}tests$self->{'delimit'}";

            foreach $pflname ('all', 'lc', 'oltp') {
                if (-e ($pathname . $pflname . ".pfl")) {

                    open (IFH, ($pathname . $pflname . ".pfl"));
                    while (<IFH>) {
                        if ($_ =~ /^[^\#].*@/) {
                            chomp $_;
                            $profiles{$pflname} = &quote_sql2($_);
                            $hits++;
                            last;
                        }
                    }
                }
            }
        }

        if ($hits != 3) {
            print &throw_err("I could not open one or more profile-files");
        }
        else {
            my $sth = $self->{dbh}->prepare("SELECT COUNT(version) FROM relevant_tests WHERE version = '$fields{'VERSION'}' AND buildpfx = '$fields{'BUILDPFX'}'");
            $sth->execute();

            if (($sth->fetchrow_array)[0] != 1) {
                $self->{dbh}->do("INSERT INTO relevant_tests (version, buildpfx, all_ptl, lc_ptl, oltp_ptl) VALUES ('$fields{'VERSION'}', '$fields{'BUILDPFX'}', " .
                "$profiles{'all'}, $profiles{'lc'}, $profiles{'oltp'})") or
                    &throw_err("INSERT INTO relevant_tests (version, buildpfx, all_ptl, lc_ptl, oltp_ptl) VALUES ('$fields{'VERSION'}', '$fields{'BUILDPFX'}', " .
                        "$profiles{'all'}, $profiles{'lc'}, $profiles{'oltp'}" . "\n" .
                        $self->{'dbh'}->errstr);
            }
            else {
                $self->{dbh}->do("UPDATE relevant_tests set all_ptl = $profiles{'all'}, lc_ptl = $profiles{'lc'}, oltp_ptl = $profiles{'oltp'}" .
                    " WHERE version = '$fields{'VERSION'}' AND buildpfx = '$fields{'BUILDPFX'}'")  or
                    &throw_err("UPDATE relevant_tests set all_ptl = $profiles{'all'}, lc_ptl = $profiles{'lc'}, oltp_ptl = $profiles{'oltp'}" .
                        " WHERE version = '$fields{'VERSION'}' AND buildpfx = '$fields{'BUILDPFX'}'" . "\n" .
                        $self->{'dbh'}->errstr);
            }
        }

        my $sth = $self->{dbh}->prepare("SELECT COUNT(version) FROM build_purpose WHERE version = '$fields{'VERSION'}' AND buildpfx = '$fields{'BUILDPFX'}' AND idplatform = $fields{'IDPLATFORM'}");
        $sth->execute();
        if (($sth->fetchrow_array)[0] != 1) {
            $self->{dbh}->do("INSERT INTO build_purpose (version, buildpfx, idplatform, relevance) VALUES ('$fields{'VERSION'}', '$fields{'BUILDPFX'}', $fields{'IDPLATFORM'}, 'ALL_PTL')") or
                &throw_err("INSERT INTO build_purpose (version, buildpfx, idplatform, relevance) VALUES ('$fields{'VERSION'}', '$fields{'BUILDPFX'}', $fields{'IDPLATFORM'}, 'ALL_PTL')" . "\n" .
                    $self->{'dbh'}->errstr);
        }

        $self->{dbh}->{AutoCommit} = 0;
        $self->{dbh}->do("INSERT INTO makes (" . join(", ", keys(%fields)) . ") VALUES ('" . join("', '", values(%fields)) . "')") or
                &throw_err("IMPORTANT:\nINSERT INTO makes (" . join(", ", keys(%fields)) . ") VALUES ('" . join("', '", values(%fields)) . "')" . "\n" .
                    $self->{'dbh'}->errstr);
        my $sth = $self->{dbh}->prepare("SELECT makes_id.CURRVAL FROM DUAL");
        $sth->execute();
        $fields{'ID'} = ($sth->fetchrow_array)[0];
        $self->{dbh}->commit();
        $self->{dbh}->{AutoCommit} = 1;

    } # End of else

    my $sth = $self->{dbh}->prepare("SELECT * FROM makes WHERE id = $fields{'ID'}");
    $sth->execute();
    foreach $x (keys(%fields)) {
        print "$x\t = $fields{$x}\n";
    }


    %field = %{$sth->fetchrow_hashref};
    while (($key, $value) = each (%field)) {
        print "$key \t = $value\n";
        $self->{$key} = $value;
    }

    $sth->finish();
    $self->{dbh}->disconnect();
    delete $self->{'dbh'};

    return bless $self;
}

#
# Make qadb(lca) fork save
#
# Release the current DB-connection
sub unlock {
    $self = shift;

    $rc = $self->{'dbh'}->disconnect;
    delete $self->{'dbh'};

    return $rc;
}

# And re-create it
sub lock {
    $self = shift;

    $self->{dbh} = DBI->connect('DBI:Proxy:hostname=10.31.165.32;port=6666;dsn=DBI:ODBC:10.17.74.60:PTS', 'TESTER', 'TESTER', \%dbi_attr) or
    $self->{error_code} = 1;

    if ($self->{error_code} == 1) {
        $self->{error_text} = &throw_err("Could not connect to Database:\n $DBI::errstr");
    }

    my $sth = $self->{dbh}->prepare("SELECT * FROM makes WHERE id = $self->{'ID'}");
    $sth->execute();

    %field = %{$sth->fetchrow_hashref};
    while (($key, $value) = each (%field)) {
        $self->{$key} = $value;
    }
    $sth->finish();
    return $self->{'error_code'};
}
####
#### end of fork-saving methods

###
### Check the status of passed tests and update lcok

sub check_lcok {
    my $self = shift;
    lock($self);
    # Find out if all the tests happend meanwhile were okay
    my $cmdstring = "SELECT COUNT(*) FROM javatestinfo WHERE makekey  = " . $self->{'ID'} . " AND driverendstatus <> 'OK'";

    my $sth = $self->{'dbh'}->prepare($cmdstring);
    $sth->execute();

    if (($sth->fetchrow_array)[0] == 0) {
        $cmdstring = "UPDATE makes SET lcok = TRUE WHERE id = $self->{'ID'}";
        }
    else {  # Wow, no errors occured while testing
        $cmdstring = "UPDATE makes SET lcok = FALSE WHERE id = $self->{'ID'}";
        }



    $self->{'dbh'}->do($cmdstring) or
                $self->{error_code} = 1;

    if ($self->{error_code} == 1) {
                $self->{error_text} = &throw_err("check_lcok: Could not execute Database-SQL-Statement $cmdstring:\n $DBI::errstr");
        }
    unlock($self);
    return $self->{'error_code'}
}
###################

sub get_last_lcapp {
    my $self = shift;
    my $lca_version = shift;
    my $lca_status  = shift;


}

sub has_been_tested {
    my $self = shift;

    lock($self);
    my $cmdstring = "SELECT count(idobjstatus) FROM makes WHERE id = $self->{'ID'} AND idobjstatus > 3000";
    my $sth = $self->{'dbh'}->prepare($cmdstring);
    $sth->execute();

    $rv = ($sth->fetchrow_array)[0];
    unlock($self);

    return $rv;
}


sub update_columns{
    my $self = shift;
    my $args = shift;

    my $key;
    my $value;

    my $cmdstring = "UPDATE makes SET ";

    while (($key, $value) = each(%$args)) {
        $cmdstring .= " $key = '$value',";
    }
    chop $cmdstring; # Das , wegschneiden

    $cmdstring .= " WHERE id = " . $self->{'ID'};
    $self->execDML($cmdstring);

        if ($self->{error_code} == 1) {
                $self->{error_text} = &throw_err("update_columns: Could not execute Database-SQL-Statement $cmdstring:\n $DBI::errstr");
        }

    return $self->{error_code};
}

sub write_log {

    my $self = shift;
    my $log_text = shift;

    my $quoted_text = "";
    if (!defined $log_text) {
        $self->{error_code} = 1;
        $self->{error_text} = &throw_err("write_log: Got wrong parameters");
        return 1;
    }

    if (length($log_text) > 1000) { # Take care. The value of 1000 is hard-coded, but may need to be changed according to the DB-Dimension.
        $self->{error_code} = 1;
        $self->{error_text} = &throw_err("write_log: I got a too log log-text:\n$log_text");
        return 1;
    }


    $quoted_text = &quote_sql2($log_text);

    ###### DEBUG ######
    #if (length($log_text) > 900) {
    #   &throw_err("ExecDML-Aufruf: INSERT INTO makelog (idmake, info) VALUES ($self->{ID}, ${quoted_text})");
    #}

    $self->execDML("INSERT INTO makelog (idmake, info) VALUES ($self->{ID}, ${quoted_text})");

    return $self->{error_code};
}


sub write_prot {
    my $self = shift;
    my $protname = shift;
    my $prot = shift;
    my $info_text = shift;
    my %head_content;

    # Config-Parameters
    # Should mabye be store elsewhere.
    my $httpmachine = "pgwdf160.wdf.sap.corp";
    my $httpport    = 1080;
    my $webroot     = "/exchange/lcmakes/";

    if (!defined($prot)) {
        $self->{error_code} = 1;
        $self->{error_text} = &throw_err("write_prot: Got wrong parameters");
        return 1;
    }

    if (!defined($info_text)) {
        $info_text = $protname;
    }

    my $hostname    = hostname();
    my $day   = ((localtime())[3]);
    my $month = ((localtime())[4] + 1);
    my $year  = ((localtime())[5] + 1900);


    $head_content{'User-Agent'} = "LCqaCLI/1.0";

    ##### CREATE THE SUBDIRECTORY FOR THE HOST ON THE WEBDAV-SERVER ###################################################################
    my $current_path = $webroot . $hostname;
    my $dav_req = Net::HTTP->new('Host' => $httpmachine, 'PeerPort' => $httpport) || ($self->{error_code} = 1);
    if ($self->{error_code} == 1) {
        $self->{error_text} = &throw_err("write_prot: Could not open Request for creating the host-directory $current_path :\n$@");
        return 1;
    }
    $dav_req->write_request('MKCOL', $current_path, %head_content);
    ($code, $mess, %headers) = $dav_req->read_response_headers();


    ##### CREATE THE SUBDIRECTORY FOR THE YEAR ON THE WEBDAV-SERVER ###################################################################
    $current_path .= "/$year";
    $dav_req = Net::HTTP->new('Host' => $httpmachine, 'PeerPort' => $httpport) || ($self->{error_code} = 1);
    if ($self->{error_code} == 1) {
        $self->{error_text} = &throw_err("write_prot: Could not open Request for creating the year-directory $current_path :\n$@");
        return 1;
    }
    $dav_req->write_request('MKCOL', $current_path, %head_content);
    ($code, $mess, %headers) = $dav_req->read_response_headers();


    ##### CREATE THE SUBDIRECTORY FOR THE MONTH ON THE WEBDAV-SERVER ###########################################################
    $current_path .= "/$month";
    $dav_req = Net::HTTP->new('Host' => $httpmachine, 'PeerPort' => $httpport) || ($self->{error_code} = 1);
    if ($self->{error_code} == 1) {
        $self->{error_text} = &throw_err("write_prot: Could not open Request for creating the month-directory $current_path :\n$@");
        return 1;
    }
    $dav_req->write_request('MKCOL', $current_path, %head_content);
    ($code, $mess, %headers) = $dav_req->read_response_headers();


    ##### CREATE THE SUBDIRECTORY FOR THE DAY OF THE MONTH ON THE WEBDAV-SERVER #########################################################
    $current_path .= "/$day";
    $dav_req = Net::HTTP->new('Host' => $httpmachine, 'PeerPort' => $httpport) || ($self->{error_code} = 1);
    if ($self->{error_code} == 1) {
        $self->{error_text} = &throw_err("write_prot: Could not open Request for creating the day-directory $current_path :\n$@");
        return 1;
    }
    $dav_req->write_request('MKCOL', $current_path, %head_content);
    ($code, $mess, %headers) = $dav_req->read_response_headers();


    ##### CREATE THE SUBDIRECTORY FOR THE MAKE-ID ON THE WEBDAV-SERVER ###################################################################
    $current_path .= "/" . $self->{ID};
    $dav_req = Net::HTTP->new('Host' => $httpmachine, 'PeerPort' => $httpport) || ($self->{error_code} = 1);
    if ($self->{error_code} == 1) {
        $self->{error_text} = &throw_err("write_prot: Could not open Request for creating the day-directory $current_path :\n$@");
        return 1;
    }

    $dav_req->write_request('MKCOL', $current_path, %head_content);
    ($code, $mess, %headers) = $dav_req->read_response_headers();
    ##### ENOUGH DIRECTORIES FOR TODAY ;-)) ###############################################################################################

    ##### WRITEING THE FILE ITSELF ########################################################################################################

    $current_path .= "/$protname";
    $dav_req = Net::HTTP->new('Host' => $httpmachine, 'PeerPort' => $httpport) || ($self->{error_code} = 1);
    if ($self->{error_code} == 1) {
        $self->{error_text} = &throw_err("write_prot: Could not open Request for creating the the file itself $current_path :\n$@");
        return 1;
    }

    $head_content{'Content-type'} = 'text/plain';
    $dav_req->write_request('PUT', $current_path, %head_content, $prot);

    ($code, $mess, %headers) = $dav_req->read_response_headers();

    if ($code ne "201") {
        $self->{error_code} = 1;
        $self->{error_text} = &throw_err("write_prot: Could not create $current_path on the server:\nHTTP-Statuscode: $code \nMessage: $mess \n");
        return 1;
    }

    #### Okay, it seems that we have succefully created a file on the WebDAV-Server. Let's go on and put a new entry into the Table:

    my $url         = quote_sql2("http://$httpmachine:$httpport" . "$current_path");
    my $url_plain   = "http://$httpmachine:$httpport" . "$current_path";
    my $quoted_text = quote_sql2($info_text);
    my $cmdstring = "INSERT INTO makeprot (idmake, info, url) VALUES ($self->{ID}, $quoted_text, $url)";
    $self->execDML($cmdstring);

        if ($self->{error_code} == 1) {
                $self->{error_text} = &throw_err("write_prot: Could not execute Database-SQL-Statement $cmdstring:\n $DBI::errstr");
        return $self->{'error_code'}
    }

    return $url_plain;
}


sub execDML {
	$self = shift;
	my $sqlstmt = shift;
	
	my $httpmachine = "pgwdf160.wdf.sap.corp";
	my $httpport    = 1080;
	my $webroot     = "SQLService?action=DirectExecute";
	my %head_content;
	
	$head_content{'User-Agent'} = "LCqaCLI/1.0";
	
	my $dav_req = Net::HTTP->new('Host' => $httpmachine, 'PeerPort' => $httpport) || ($self->{error_code} = 1);
	if ($self->{error_code} == 1) {
		$self->{error_text} = &throw_err("execDML: could not open request for executing SQL: $sqlstmt :\n$@");
		return 1;
	}
	
	$dav_req->write_request('PUT', $webroot, %head_content, $sqlstmt);
	($code, $mess, %headers) = $dav_req->read_response_headers();
}


sub quote_sql2 {
	$qstr = shift;
	return "NULL" unless defined $qstr;
	$qstr =~ s/'/''/g;           # ISO SQL2 # '
	
	return "'$qstr'";
}



sub throw_err {
    my $errortext = shift;

    $errortext .= "\n########################################################\nENVIRONMENT:\n";
    for $x (keys(%ENV)) {
        $errortext .= "\n${x} = $ENV{$x}";
    }

    $errortext .= "\n";

    my $smtp = Net::SMTP->new("mail.sap-ag.de");
    if (!(defined $smtp)) {
	    print "#############################################################################\n";
	    print "################################### ERROR ###################################\n";
	    print "######## COULD NOT CONNECT TO mail.sap-ag.de                         ########\n";
	    print "######## Wanted to send the following by mail:                       ########\n";
	    print $errortext . "\n";
	    print "################################ END OF ERROR ###############################\n";
	    print "#############################################################################\n";
    }
    else {
	    $smtp->mail("remuser\@is0025.wdf.sap-ag.de");
	    $smtp->to("falko.flessner\@sap.com");
	    $smtp->data();
	    $smtp->datasend("To: falko.flessner\@sap.com\n");
	    $smtp->datasend("Subject: Error during qadb-run \n");
	    $smtp->datasend("Priority: Urgent\nX-Priority: 1 (Highest)\n");
	    $smtp->datasend("\n");
	    $smtp->datasend($errortext);
	    $smtp->dataend();
	    $smtp->quit;
    }
    return $errortext;
}


__END__

=head1 NAME

qadb - A perl Module for creating and updateing entries in
the SAP DB/liveCache QA-Database.

=head1 NOTE

This module is intended for internal use only.
Although it is free software, it won't be very usefull for the wide world

=head1 SYNOPSIS OF CREATING A NEW ENTRY

 use qadb;
 $qah =  qadb->new({'VERSION' => '7403',
    'BUILDPFX'   => '07',
    'QASTATUS'   => 'DEV',
    'CHANGELIST' => '12345'}) ;

 if ($qah->{error_code} != 0) {
    print "Error:\n$qah->{error_text}\n";
    return -1;
 }

=head1 SYNOPSIS OF LOADING A OLD ENTRY

 use qadb;
 $qah =  qadb->new({'ID' => 1234}) ;

 if ($qah->{error_code} != 0) {
    print "Error:\n$qah->{error_text}\n";
    return -1;
 }

=head1 SYNOPSIS OF LOADING AN ENTRY FOR TESTS

 use qadb;
 $qah = qadb->new_test({'PLATFORM' => 'alphaosf', 'VERSION' => 7404, 'QASTATUS' => 'DEV'});

 if ($qah->{error_code} != 0) {
    print "Error:\n$qah->{error_text}\n";
    return -1;
 }

=head1 DESCRIPTION

The C<qadb> class is a interface to the SAP-internal QA-System for SAP DB
and liveCache.

Each instance of C<qadb> represents a complete make in the sense of making
programs out of sourcecode. Aditionaly, it can carry informations about
the status of the programs made - test results for example.

A new instance of C<qadb> can be created in two ways:

=over 4

=item Creating a new entry

A couple of informations are required to create a new entry. Following
the perl standards, the constructor of the class is named C<new>. It
requires a hash-reference with the following entries:

  Name          Description                   Example value

 VERSION       4-digit Version              '7402'
 BUILDPFX      2-digit Build-prefix         '02'
 QASTATUS      The quality-status           'DEV'
 CHANGELIST    The CL-Number                '32456'

For AIX-Machines, the aditional "PLATFORM"-entry is required. This is
necssary becase the perl-interpreter does not make a difference between
AIX 4.x and AIX 5.x as we do it.

Currently, the followning values are accepted for PLATFORM:

    - sun_64
    - alphaosf
        - rs6000_51_64
    - rs6000_64
    - hp_64

Please keep in mind that a C<qadb>-instance normaly contains a variable
called C<ID> (you can access it with B<$qah-E<gt>{'ID'}>. This C<ID> identifies
a make-entry and will be needed later. So, I suggest to write this C<ID>
to the harddisk.

=item Loading a old entry

For loading a previously created entry, you need to call the contructor with
a hash-refernece, containing the ID generated by the inital creation of
the entry.

  Name          Description                   Example value

 ID            The ID taken from inital      5739
               creation

=back

=head1 METHODS

C<qadb> provides the following methods:

=over 4

=item $rv = update_columns({name1 => value1, ... , nameN => valueN});

Performs a update-statement on the main table. This should only be used
for updating IDOBJSTATUS, LCPOOLID, LC_OK and LCOK_TRANS.

It takes a hash-reference as arguement, filled with columnnames and the
corresponing values.

The "VARIABLES"-Section of this manual contains a complete description of all
fields.

Returns 0 on success.

=item $rv = write_log($log_text);

This adds a comment to the entry. The log-Text must not contain more than
1000 characters.

Returns 0 on success.

=item $rv = write_prot($prot_name, $prot  [, $info_text]);

Writes a protocoll to the WebDAV-server and creates a entry in the
appropriate table in the database.

It takes a protocolname, the protocol itself and a optional info text as
arguments.

If the info text is not provieded, the protocolname will be used for it.

Returns 0 on success.

=item $rv = unlock();

Releases the current DB-Connection, but don't forget about the Values.

This becomes necessary when the program forkes. See B<lock> for
further informations

Returns 0 on success.

=item $qah = lock();

Re-Creates the DB-Connection. This becomes necessary after performing
an B<unlock> in forking situations.

B<TAKE CARE:> this method will return a new instance. Overwrite the current one
with it. The following example will give you an idea how to do this:

   $qah->unlock();
   $pid = fork();
   $qah = $qah->lock();

   if ($pid) {
       #
       # go on here


=back

=head1 VARIABLES

C<qadb> contains the following variables. Variables corresponding with
fields in the database are marked with a X.

Please note that B<IDQASTATUS> and B<IDPLATFORM> differ from the
parameters B<QASTATUS> and B<PLATFORM> for the C<new>-constructor. The values stored in the
database are simple numeric representations of their alphanumeric
assignments. These assignments are stored in the tables B<PLATFORMS>
and B<QASTATUS>.

  Name         DB-Variable       Description

 ID                X            Identifies the complete build-process
 LCPOOLID          X            The number in the LC_POOL-directory
 VERSION           X            A four-digit version, eg. "7402"
 BUILDPFX          X            A two-digit buildprefix, eg. "05"
 IDPLATFORM        X            The numeric id of the platform
 IDQASTATUS        X            The numeric id if the QA-status
 IDOBJSTATUS       X            The numeric id of the make-status
 CHANGELIST        X            The Changelist-number
 TS                X            The timestamp of the last modification
 LCOK              X            Will be set when the tests are finished
                                successfully.
 LCOK_TRANS        X            Will be set after the LCOK-bit is
                                transfered into the appropriate structures
                in the filesystem.
 HISTCOUNT         X            Counts the number of changes in on these
                                informations. Will be updated automaticaly.
 error_code                     Conains the last error code set. After
                                successfull opterations it will be set to
                0.
 error_text                     Contains a human-readable description of
                                the last error.

=head1 ERROR HANDLING

Beneath the already introduced variables B<error_code> and B<error_text>
for error handling, a email will be sent in each case of a detected error.

The recipients of these Mails are currently hard-coded.

=head1 DBI INSTANCE

C<qadb> contains a ready-to-use DBI instance. It can be accessed by
B<$qah-E<gt>{dbh}>. Please use this with extreme care and use it
only if you can not avoid it.

The DBI documentation describes it in depth.

=head1 EXAMPLE

 use qadb;
 my $qah =  qadb->new({'VERSION' => '7403',
    'BUILDPFX'   => '07',
    'QASTATUS'   => 'DEV',
    'CHANGELIST' => '12345'}) ;

 if ($qah->{error_code} != 0) {
    print "Fehler:\n$qah->{error_text}\n";
    return -1;
 }

 if ($qah->update_columns({'LCPOOLID' => '012'}) != 0 ) {
     print "Error while update:\n$qah->{error_text}\n";
     return -1;
 }

 if ($qah->write_log("Hallo Welt, dies ist ein Test")) {
     print "Error while writing a log:\n$qah->{error_text}\n";
     return -1;
 }

 my $protocol = "";
 open (PROTOFILE, "/path/to/protocol") or die "Error reading protocol\n";

 while (<PROTOFILE>) {
     $protocol .= $_;
 }

 if ($qah->write_prot("make.log", $protocol, "This protocol contains the make-output.\n")) {
     print "Error while writing protocol make.log:\n$qah->{error_text}\n";
 }

=head1 COPYRIGHT

Copyright 2002 SAP AG

=cut

