PC Professionell 2004 December/PCpro_2004_12.ISO/files/webserver/xampp/xampp-perl-addon-1.4.9-installer.exe/DBIODBC.pm

Perl POD Document | 2001-07-13 | 4.7 KB | 249 lines

package            # hide this package from CPAN indexer
    Win32::ODBC;

#use strict;

use DBI;

# once we've been loaded we don't want perl to load the real Win32::ODBC
$INC{'Win32/ODBC.pm'} = $INC{'Win32/DBIODBC.pm'} || 1;

#my $db = new Win32::ODBC("DSN=$self->{'DSN'};UID=$self->{'UID'};PWD=$self->{'PWD'};");

#EMU --- my $db = new Win32::ODBC("DSN=$DSN;UID=$login;PWD=$password;");
sub new
{
    shift;
    my $connect_line= shift;

# [R] self-hack to allow empty UID and PWD
    my $temp_connect_line;
    $connect_line=~/DSN=\w+/;
    $temp_connect_line="$&;";
    if ($connect_line=~/UID=\w?/)
        {$temp_connect_line.="$&;";}
    else    {$temp_connect_line.="UID=;";};
    if ($connect_line=~/PWD=\w?/)
        {$temp_connect_line.="$&;";}
    else    {$temp_connect_line.="PWD=;";};
    $connect_line=$temp_connect_line;
# -[R]-

    my $self= {};


    $_=$connect_line;
     /^(DSN=)(.*)(;UID=)(.*)(;PWD=)(.*)(;)$/;

     #---- DBI CONNECTION VARIABLES

     $self->{ODBC_DSN}=$2;
     $self->{ODBC_UID}=$4;
     $self->{ODBC_PWD}=$6;


    #---- DBI CONNECTION VARIABLES
    $self->{DBI_DBNAME}=$self->{ODBC_DSN};
    $self->{DBI_USER}=$self->{ODBC_UID};
    $self->{DBI_PASSWORD}=$self->{ODBC_PWD};
    $self->{DBI_DBD}='ODBC';

    #---- DBI CONNECTION
    $self->{'DBI_DBH'}=DBI->connect($self->{'DBI_DBNAME'},
            $self->{'DBI_USER'},$self->{'DBI_PASSWORD'},$self->{'DBI_DBD'});

    warn "Error($DBI::err) : $DBI::errstr\n" if ! $self->{'DBI_DBH'};


    #---- RETURN

    bless $self;
}


#EMU --- $db->Sql('SELECT * FROM DUAL');
sub Sql
{
     my $self= shift;
     my $SQL_statment=shift;

 #    print " SQL : $SQL_statment \n";

    $self->{'DBI_SQL_STATMENT'}=$SQL_statment;

    my $dbh=$self->{'DBI_DBH'};

 #    print " DBH : $dbh \n";

    my $sth=$dbh->prepare("$SQL_statment");

 #    print " STH : $sth \n";

    $self->{'DBI_STH'}=$sth;

    if ($sth)
    {
        $sth->execute();
    }

    #--- GET ERROR MESSAGES
    $self->{DBI_ERR}=$DBI::err;
    $self->{DBI_ERRSTR}=$DBI::errstr;

    if ($sth)
    {
        #--- GET COLUMNS NAMES
        $self->{'DBI_NAME'} = $sth->{NAME};
    }

# [R] provide compatibility with Win32::ODBC's way of identifying erraneous SQL statements
     return ($self->{'DBI_ERR'})?1:undef;
# -[R]-
}


#EMU --- $db->FetchRow())
sub FetchRow
{
     my $self= shift;

     my $sth=$self->{'DBI_STH'};
     if ($sth)
    {
         my @row=$sth->fetchrow_array;
         $self->{'DBI_ROW'}=\@row;

         if (scalar(@row)>0)
         {
            #-- the row of result is not nul
            #-- return somthing nothing will be return else
            return 1;
         }
    }
    return undef;
}

# [R] provide compatibility with Win32::ODBC's Data() method.
sub Data
{
    my $self=shift;
    my @array=@{$self->{'DBI_ROW'}};
    foreach my $element (@array)
    {
        # remove padding of spaces by DBI
        $element=~s/(\s*$)//;
    };
    return (wantarray())?@array:join('', @array);
};
# -[R]-

#EMU --- %record = $db->DataHash;
sub DataHash
{
     my $self= shift;

     my $p_name=$self->{'DBI_NAME'};
     my $p_row=$self->{'DBI_ROW'};

     my @name=@$p_name;
     my @row=@$p_row;

     my %DataHash;
#print @name; print "\n"; print @row;
# [R] new code that seems to work consistent with Win32::ODBC
    while (@name)
    {
        my $name=shift(@name);
        my $value=shift(@row);

        # remove padding of spaces by DBI
        $name=~s/(\s*$)//;
        $value=~s/(\s*$)//;

        $DataHash{$name}=$value;
    };
# -[R]-

# [R] old code that didn't appear to work
#    foreach my $name (@name)
#    {
#        $name=~s/(^\s*)|(\s*$)//;
#        my @arr=@$name;
#        foreach (@arr)
#        {
#            print "lot $name  name  col $_   or ROW= 0 $row[0]  1 $row[1] 2 $row[2] \n ";
#            $DataHash{$name}=shift(@row);
#        }
#    }
# -[R]-

     #--- Return Hash
     return %DataHash;
}


#EMU --- $db->Error()
sub Error
{
     my $self= shift;

     if ($self->{'DBI_ERR'} ne '')
     {
        #--- Return error message
        $self->{'DBI_ERRSTR'};
     }

     #-- else good no error message

}

# [R] provide compatibility with Win32::ODBC's Close() method.
sub Close
{
    my $self=shift;

    my $dbh=$self->{'DBI_DBH'};
    $dbh->disconnect;
}
# -[R]-

1;

__END__

# [R] to -[R]- indicate sections edited by me, Roy Lee

=head1 NAME

Win32::DBIODBC - Win32::ODBC emulation layer for the DBI

=head1 SYNOPSIS

  use Win32::DBIODBC;     # instead of use Win32::ODBC

=head1 DESCRIPTION

This is a I<very> basic I<very> alpha quality Win32::ODBC emulation
for the DBI. To use it just replace

    use Win32::ODBC;

in your scripts with

    use Win32::DBIODBC;

or, while experimenting, you can pre-load this module without changing your
scripts by doing

    perl -MWin32::DBIODBC your_script_name

=head1 TO DO

Error handling is virtually non-existant.

=head1 AUTHOR

Tom Horen <[e-mail]>

=cut