package DBIShell::dr::MSSQL_A;

#  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 Exporter ();
use DBIShell::dr::Sybase  qw();
use DBIShell::UTIL qw/:context _NULLS/;

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

$VERSION     = 0.01_07;
@EXPORT      = ();
@EXPORT_OK   = ();
%EXPORT_TAGS = ();
@ISA         = qw(DBIShell::dr::Sybase);
@INHERIT     = qw(_is_table _is_describable _needs_comment);

sub _init ()
{
    my $target = $::{'DBIShell::'}{'dr::'}{'MSSQL_A::'};
    my $source = $::{'DBIShell::'}{'dr::'}{'Sybase::'};
    
    foreach my $sym (@INHERIT)
    {
	#warn("aliasing ",$target->{$sym}," to ",$source->{$sym},"\n");
	$target->{$sym} = $source->{$sym};
    }

    @INHERIT = ();
};

use constant STATUS_NULLABLE   => DBIShell::dr::Sybase::STATUS_NULLABLE;
use constant CS_ROW_RESULT     => DBD::Sybase::CS_ROW_RESULT;
use constant CS_CURSOR_RESULT  => DBD::Sybase::CS_CURSOR_RESULT;
use constant CS_PARAM_RESULT   => DBD::Sybase::CS_PARAM_RESULT;
use constant CS_STATUS_RESULT  => DBD::Sybase::CS_STATUS_RESULT;
use constant CS_MSG_RESULT     => DBD::Sybase::CS_MSG_RESULT;
use constant CS_COMPUTE_RESULT => DBD::Sybase::CS_COMPUTE_RESULT;

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

use constant COMMENTQ => <<CommentQuery;
select text from syscomments
where  id = object_id('%s')
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('%%s')
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 ','V ')
TableQuery

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;

sub new ($$$)
{
    _init();
    my $package = ref($_[0]) ? ref(shift()) : shift();
    my $driver  = shift();
    
    (!$driver || ($driver eq 'MSSQL_A')) && ($driver = 'Sybase');
    
    return $package->SUPER::new($driver, @_);
}

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

    my($type);

    my $dbh = $engine->dbh();
    
    eval
    {
	my $sth;
	my $TYPEQ = sprintf(TYPEQ, $target);
	$sth = $dbh->prepare($TYPEQ)
	  || die($dbh->errstr,"\n");
	$sth->{ChopBlanks} = 0;
	$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
	{
	    my $DESCQ = sprintf(DESCQ, $target);
	    
	    $sth = $dbh->prepare($DESCQ)
	      || die($dbh->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]) :
		    sprintf('%s(%d)', $$r[D_TYPE],
			    $$r[D_PREC] ? $$r[D_PREC]: $$r[D_SIZE]);

	    $$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;
	    my $COMMENTQ = sprintf(COMMENTQ, $target);
	    
	    $sth = $dbh->prepare($COMMENTQ)
	      || die($dbh->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;
    }
}


__END__

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