package DBIShell::dr::Sybase;

#  dbishell: A generic database shell based on the Perl DBI layer
#  Copyright (C) 2000  Vivek Dasmohapatra (vivek@etla.org)

#  This program 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 2
#  of the License, or (at your option) any later version.

#  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 General Public License for more details.

#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.

use strict;

use DBI;
use constant;
use Exporter ();
use DBIShell::dr::DEFAULT qw(TGREP_FN HGREP_FN OGREP_FN SGREP_FN FGREP_FN);
use DBIShell::UTIL qw/:context :sql_types _NULLS/;

use vars qw($VERSION @EXPORT @EXPORT_OK %EXPORT_TAGS @ISA);

$VERSION     = 0.01_24;
@EXPORT      = ();
@EXPORT_OK   = ();
%EXPORT_TAGS = ();
@ISA         = qw(DBIShell::dr::DEFAULT);

#use subs qw(connect);

use constant DBI_ATTRIB => {
			    PrintError  => 0,
			    RaiseError  => 0,
			    AutoCommit  => 0,
			    ChopBlanks  => 0,
			    LongReadLen => 1024,
			    LongTruncOk => 1
			    };

use constant CMNDS =>
  qw(alter
     grant
     select
     insert
     update
     delete
     create
     drop
     show
     describe
     commit
     rollback
     sp_help
     read
     cd
    );

# should import this from DBD::Sybase, but that's tricky becaus it
# might not be there and we don't want to impede the build process
# for other drivers if it isn't... maybe fix this later...
use constant STATUS_NULLABLE => 0x8;

use constant KEYWDS => qw^
into    from where     like    in  and       tables
null    is   order     group   by  distinct  table   
varchar char numeric   integer or  between   
object_name  user_name user_id not object_id 
^;

use constant COMPLETION_MAP =>
  (
   select   => [ KEYWDS ],
   from     => TGREP_FN,
   table    => TGREP_FN,
   update   => TGREP_FN,
   into     => TGREP_FN,
   describe => OGREP_FN,
   join     => TGREP_FN,
   help     => HGREP_FN,
   read     => FGREP_FN,
   cd       => FGREP_FN,
   create   => [ qw(table index) ],
   drop     => [ qw(table index) ],
   alter    => [ 'table' ],
   delete   => [ 'from'  ],
   insert   => [ 'into'  ],
   is       => [ qw(null not) ],
   not      => [ 'null'  ],
   show     => SGREP_FN
  );

use constant  TYPEQ => <<TypeQuery;
select type from sysobjects where id = object_id(?)
TypeQuery

use constant COMMENTQ => <<CommentQuery;
select text from syscomments
where  id = object_id(?)
order  by colid asc
CommentQuery

use constant  DESCQ => sprintf(<<DescTable, STATUS_NULLABLE);
select   c.name, t.name as type, c.length, c.prec, c.scale, c.status & %d
from     syscolumns c,
         systypes   t
where    c.id       = object_id(?)
and      t.usertype = c.usertype
order by c.colid
DescTable

use constant TABLES_QUERY => <<TableQuery;
select rtrim(user_name(uid) + '.' + name)
from   sysobjects
where  type in ('U ','S ')
TableQuery

use constant VIEWS_QUERY => <<ViewQuery;
select rtrim(user_name(uid) + '.' + name)
from   sysobjects
where  type = 'V '
ViewQuery

use constant PROCS_QUERY => <<ProcsQuery;
select rtrim(user_name(uid) + '.' + name)
from   sysobjects
where  type = 'P '
ProcsQuery

use constant D_NAME  => 0;
use constant D_TYPE  => 1;
use constant D_SIZE  => 2;
use constant D_PREC  => 3;
use constant D_SCALE => 4;
use constant D_NULL  => 5;

BEGIN
{
    eval { require DBD::Sybase; };
    if($@)
    {
	package DBD::Sybase;
	constant->import(CS_ROW_RESULT     => 0);
	constant->import(CS_CURSOR_RESULT  => 1);
	constant->import(CS_PARAM_RESULT   => 2);
	constant->import(CS_STATUS_RESULT  => 3);
	constant->import(CS_MSG_RESULT     => 4);
	constant->import(CS_COMPUTE_RESULT => 5);
    }
}

sub _is_table       ($) { { 'U ',1, 'S ',1, 'V ',1         }->{$_[0]} }
sub _is_describable ($) { { 'U ',1, 'S ',1, 'V ',1, 'P ',1 }->{$_[0]} }
sub _needs_comment  ($) { { 'P ',1, 'V ',1, 'TR',1         }->{$_[0]} }

sub new ($$$)
{
    my $package = ref($_[0]) ? ref(shift()) : shift();
    my $driver  = shift() || 'Sybase';
    my $engine  = $package->DBIShell::dr::DEFAULT::new($driver, @_);

    $engine->_var(COMP_MAP   => {(COMPLETION_MAP)}) || warn($engine->{ERROR});
    $engine->_var(KEYWORDS   => [(KEYWDS)        ]) || warn($engine->{ERROR});
    $engine->_var(COMMANDS   => [(CMNDS)         ]) || warn($engine->{ERROR});
    $engine->_var(DBI_ATTRIB => DBI_ATTRIB)         || warn($engine->{ERROR});

    return $engine;
}

sub set_initvars ($$)
{
    my $engine = shift(@_);
    my $sh     = shift(@_);

    $engine->DBIShell::dr::DEFAULT::set_initvars($sh);
    $sh->setvar("CASE_SENSITIVE=1");
}

sub _tables ($)
{
    my @tables;
    my $engine = $_[0];
    my $dbh    = $engine->dbh();

    eval
    {
	my $cols;
	my @data;
	my $sth = $dbh->prepare(TABLES_QUERY)
	  || die("prepare(TABLES_QUERY) failed: ",$dbh->errstr(),"\n");
	$sth->execute()
	  || die("execute(TABLES_QUERY) failed: ",$sth->errstr(),"\n");
	$cols = $#{ $sth->{NAME} };
	$sth->bind_columns(undef, \@data[0 .. $cols])
	  || die("bind_cols(TABLES_QUERY) failed: ",$sth->errstr(),"\n");
	while($sth->fetchrow_arrayref()){ push(@tables, $data[0]) }
	$sth->finish();
    };

    if($@)
    {
	chomp($engine->{ERROR} = $@);
	return ();
    }

    return @tables;
}

sub _views ($)
{
    my @views;
    my $engine = $_[0];
    my $dbh    = $engine->dbh();

    eval
    {
	my $cols;
	my @data;
	my $sth = $dbh->prepare(VIEWS_QUERY)
	  || die("prepare(VIEWS_QUERY) failed: ",$dbh->errstr(),"\n");
	$sth->execute()
	  || die("execute(VIEWS_QUERY) failed: ",$sth->errstr(),"\n");
	$cols = $#{ $sth->{NAME} };
	$sth->bind_columns(undef, \@data[0 .. $cols])
	  || die("bind_cols(VIEWS_QUERY) failed: ",$sth->errstr(),"\n");
	while($sth->fetchrow_arrayref()){ push(@views, $data[0]) }
	$sth->finish();
    };

    if($@)
    {
	chomp($engine->{ERROR} = $@);
	return ();
    }

    return @views;
}

sub _procs ($)
{
    my @procs;
    my $engine = $_[0];
    my $dbh    = $engine->dbh();

    eval
    {
	my $cols;
	my @data;
	my $sth = $dbh->prepare(PROCS_QUERY)
	  || die("prepare(PROCS_QUERY) failed: ",$dbh->errstr(),"\n");
	$sth->execute()
	  || die("execute(PROCS_QUERY) failed: ",$sth->errstr(),"\n");
	$cols = $#{ $sth->{NAME} };
	$sth->bind_columns(undef, \@data[0 .. $cols])
	  || die("bind_cols(PROCS_QUERY) failed: ",$sth->errstr(),"\n");
	while($sth->fetchrow_arrayref()){ push(@procs, $data[0]) }
	$sth->finish();
    };


    if($@)
    {
	chomp($engine->{ERROR} = $@);
	return ();
    }
    
    return @procs;
}

sub showables ($)
{
    return (qw(tables procs views), $_[0]->procs(), $_[0]->views());
}

sub _resolve_type ($$)
{
    my $engine = $_[0];
    my $target = $_[1];

    my($type);

    my $dbh = $engine->dbh();
    
    eval
    {
	my $sth;
	$sth = $dbh->prepare(TYPEQ)
	  || die($dbh->errstr,"\n");
	$sth->{ChopBlanks} = 0;
	$sth->bind_param(1, $target, SQL_VARCHAR_T)
	  || die($sth->errstr,"\n");
	$sth->execute()
	  || die($sth->errstr,"\n");
	$sth->bind_columns(undef, \$type);
	$sth->fetchrow_arrayref();
	$sth->finish();
    };

    if    ($@)     { chomp($engine->{ERROR} = $@) }
    elsif (!$type)
    {
	$engine->{ERROR} = sprintf("No such object %s found",$target);
    }
    
    return $type;
}

sub describe ($$$)
{
    my @l;
    my $engine = shift(@_);
    my $sh     = shift(@_);
    my $target = shift(@_);

    my $csep;
    $csep = $sh->getvar('FIELD_SEPARATOR');
    $csep = defined($csep) ? $csep : '|';

    my $dbh = $engine->dbh();

    my $type = $engine->_resolve_type($target);

    if(!$type) { return 0 }

    if(_is_describable($type))
    {
	my($sth,$dqd);

	eval
	{
	    $sth = $dbh->prepare(DESCQ)
	      || die($dbh->errstr,"\n");

	    $sth->bind_param(1, $target, SQL_VARCHAR_T)
	      || die($sth->errstr,"\n");

	    $sth->execute()
	      || die($sth->errstr,"\n");

	    $dqd = $sth->fetchall_arrayref()
	      || die($sth->errstr,"\n");
	};

	if ($@)
	{
	    $engine->{ERRNO} = $!;
	    $engine->{ERROR} = $@;
	    $sth && $sth->finish();
	    return 0;
	}

	unless (@$dqd)
	{
	    $engine->{ERRNO} = 0;
	    $engine->{ERROR} = "No such object [$target] found to describe";
	    $sth && $sth->finish();
	    return 0;
	}

	foreach my $r (@$dqd)
	{
	    my $type_decl =
	      ($$r[D_TYPE] =~ /date|time/) ? $$r[D_TYPE] :
		$$r[D_SCALE] ?
		  sprintf('%s(%d,%d)',$$r[D_TYPE], $$r[D_PREC],$$r[D_SCALE]) :
		    ($$r[D_PREC] || $$r[D_SIZE]) ?
		      sprintf('%s(%d)',$$r[D_TYPE],$$r[D_PREC]||$$r[D_SIZE]):
			$$r[D_TYPE];

	    $$r[D_NULL] = $$r[D_NULL] ? 'NOT NULL' : '        ';

	    splice(@$r, D_TYPE, 4, $type_decl);

	    for (my $p = 0; $p <= $#$r; $p++)
	    {
		my $l = defined($$r[$p]) ? length($$r[$p]) : 4;
		($l > $l[$p]) && ($l[$p] = $l);
	    }
	}

	my $format = join('',join($csep,(map { " %-$_.${_}s " } @l)),"\n");

	$sh->errputf(CONTEXT_NIL, " \n");
	$sh->start_pager($#{$dqd}+2);
	$sh->outputf(CONTEXT_NIL, $format, qw(NAME TYPE NULLABLE));
	foreach (@$dqd) { $sh->outputf(CONTEXT_NIL, $format, _NULLS(@$_)) }
	$sh->stop_pager();
	$sth->finish();
    }
    else
    {
	$engine->{ERROR} =
	  sprintf("%s cannot describe type '%s' objects", __PACKAGE__, $type);
	return 0;
    }
    
    return 1;
}

sub dump_def ($$$)
{
    my $engine = shift(@_);
    my $sh     = shift(@_);
    my $target = shift(@_);

    my $dbh   = $engine->dbh();
    my $type  = $engine->_resolve_type($target);

    if(!$type) { return 0 }
    
    if(_needs_comment($type) || !_is_table($type))
    {
	eval
	{
	    my $sth;
	    my $comment;
	    $sth = $dbh->prepare(COMMENTQ)
	      || die($dbh->errstr,"\n");
	    $sth->bind_param(1, $target, SQL_VARCHAR_T)
	      || die($sth->errstr,"\n");
	    $sth->execute()
	      || die($sth->errstr,"\n");
	    $sth->bind_columns(undef, \$comment)
	      || die($sth->errstr,"\n");

	    $sh->errputf(CONTEXT_NIL, " \n");
	    if($sh->getvar('PRESCAN_ROWS',0))
	    {
		my $nl = 0;
		my $data = $sth->fetchall_arrayref();
		
		foreach my $t (@$data)
		{
		    chomp($t->[0]);
		    $nl += ($t->[0] =~ tr/\n/\n/);
		}
		
		$sh->start_pager($nl);
		foreach my $row (@$data)
		{
		    $sh->outputf(CONTEXT_NIL, '%s', $row->[0]);
		}
		$sh->stop_pager();
	    }
	    else
	    {
		$sh->start_pager($sth->rows());
		while($sth->fetchrow_arrayref())
		{
		    chomp($comment);
		    $sh->outputf(CONTEXT_NIL, "%s", $comment);
		}
		$sh->stop_pager();
	    }

	    $sth->finish();
	};

	if ($@)
	{
	    $engine->{ERRNO} = $!;
	    $engine->{ERROR} = $@;
	    return 0;
	}

	return 1;
    }
    else
    {
	$engine->{ERROR} =
	  sprintf("%s cannot show definition of %s type objects",
		  __PACKAGE__, $type
		 );
	return 0;
    }
}

# bitch. Sybase won't use in out parameters to return parameters.
# it uses magic-type return rows instead, forcing us to know the
# magic numbers. Qabbalistic programming here we come...
sub fetch_results ($$$;)
{
    my $i      = undef;
    my $engine = $_[0];
    my $sh     = $_[1];
    my $sth    = $_[2];

    my $continue = 1;

    while($continue)
    {
	my $rtype = $sth->{syb_result_type};

	#warn("CS_ROW_RESULT    ==", DBD::Sybase::CS_ROW_RESULT(),   "\n");
	#warn("CS_STATUS_RESULT ==", DBD::Sybase::CS_STATUS_RESULT(),"\n");
	#warn("CS_PARAM_RESULT  ==", DBD::Sybase::CS_PARAM_RESULT(), "\n");

	if ($rtype == DBD::Sybase::CS_PARAM_RESULT())
	{
	    my $maxl;
	    my @label = @{ $sth->{NAME} };
	    my $value;

	    for(my $n = 0; $n < @label; $n++)
	    {
		($maxl < length($label[$n])) &&
		  ($maxl = length($label[$n]))
	    }

	    my $fmt = sprintf("%%%d.%ds = %%s\n", $maxl, $maxl);
	    $sh->errputf(CONTEXT_NIL, " \n");
	    while($value = $sth->fetchrow_arrayref())
	    {
		for (my $n = 0; $n <= $#label; $n++)
		{
		    $sh->outputf(CONTEXT_NIL, $fmt, $label[$n], $value->[$n]);
		}
	    }
	}
	elsif ($rtype == DBD::Sybase::CS_STATUS_RESULT())
	{
	    my $status;
	    $sh->errputf(CONTEXT_NIL, " \n");
	    while($status = $sth->fetchrow_arrayref())
	    {
		$sh->outputf(CONTEXT_NIL,
			     "STATUS = [%s]\n",
			     join( '][', @{ $status } )
			    );
	    }
	}
	else
	{
	    $i = $engine->DBIShell::dr::DEFAULT::fetch_results($sh, $sth);
	}

	$continue = $sth->{syb_more_results};
    }
    # return the number of rows fetched, but make it always true:
    return int($i) ? $i : '0E0';
}

__END__

# TLF: Nikola Tesla died for you....