package DBIShell::Readline;

#  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 Exporter           ();
use Term::ReadLine     ();
use DBIShell::Fixup    ();
use DBIShell::Term_CTL ();
use DBIShell::UTIL  qw(FALSE TRUE ZERO_TRUE DEOL);

use vars qw($VERSION @EXPORT @EXPORT_OK %EXPORT_TAGS @ISA);
use vars qw($AUTOLOAD %MCACHE *MAP *ADVISE *LB);

use constant TRL_PERL => 'Term::ReadLine::Perl';
use constant TRL_GNU  => 'Term::ReadLine::Gnu';

use constant TRL_HISTORY_ADVICE_LIST =>
  qw( beginning-of-history
      end-of-history
      forward-search-history
      reverse-search-history
      next-history
      previous-history
      non-incremental-forward-search-history
      non-incremental-reverse-search-history
      non-incremental-forward-search-history-again
      non-incremental-reverse-search-history-again
      history-search-backward
      history-search-forward
      vi-fetch-history
    );

use subs qw|readline($;$)|;

use constant READLINE_WARNING => <<ReadlineWarning;
Command History Not available - Install one of:

  Term::ReadLine::Perl
  Term::ReadLine::Gnu

Or equivalent,
Current module is: %s
ReadlineWarning

use constant RLLIBVER_WARNING => <<RLLIB_Warning;

Your readline library [%.2f] is older than 4.00,
SIGWINCH may not be handled by Term::ReadLine::GNU

RLLIB_Warning

  use constant COMPLETION_WARNING => <<CompletionWarning;
Tab completion not available - Install one of:

  Term::ReadLine::Perl
  Term::ReadLine::Gnu

Or equivalent,
Current module is: %s
CompletionWarning

$VERSION     = 0.01_07;
@EXPORT      = qw();
@EXPORT_OK   = qw();
%EXPORT_TAGS = qw();
@ISA         = qw(Exporter);

# despatch requests to whichever class we were actually asked to wrap:
# cannot use the ISA array, because then we wouldn't be able to have different
# instances of DBIShell::Readline wrapping different Term::ReadLine::* classes
# in existence at the same time, or possibly even during the same execution
# environment's existence. Basically, we need the base-class to be dynamic
# on at least a per-instance basis:
sub AUTOLOAD
{
    my $meth;
    my $code;
    my $self = shift(@_);

    warn("$self \-\> $AUTOLOAD\n");

    my $trlo = $self->{OBJ};
    my $rlim = $self->{ISA};

    $meth = $AUTOLOAD;
    $meth =~ s/.*:://;
    warn("AUTLOADING $meth\n");
    $code = $MCACHE{$rlim}{$meth} ||= UNIVERSAL::can($rlim, $meth);
    $code ? return $code->($trlo, @_) : die("->$meth not found in $rlim\n");
}

sub new ($;$$$)
{
    my $self;
    my($pack) = map { ref() || $_ } shift(@_);
    my $trlo  = Term::ReadLine->new(@_);
    my $rlim  = $trlo->ReadLine();

    if( !$trlo->Features()->{autohistory} )
    {
	printf(STDERR READLINE_WARNING, $rlim);
    }

    DBIShell::Fixup::patch( $rlim );
    $MCACHE{$rlim} ||= {};

    $self = bless({ OBJ => $trlo, ISA => $rlim, HHK => 0 }, $pack);
    $self->advise_history_defuns();

    return $self;
}

sub auto_history ($;$)
{
    my $rv;
    my $mpar;
    my $self = $_[0];
    my $auto = $_[1];
    my $rlim = $self->{ISA};

    if( !$self->{OBJ}->Features()->{minline} )
    {
	warn("$rlim does not support enough features, sorry\n");
	return undef();
    }

    if(@_ == 2)
    {
	if( $rlim eq TRL_PERL ) { $mpar = $auto ? 0 : 65535   }
	else                    { $mpar = $auto ? 0 : undef() }
    }

    $self->{OBJ}->MinLine( $mpar );

    # NOTE: we can only do this because in Fixup, we patch TRL_PERL:
    $rv = $self->{OBJ}->MinLine();

    return defined($rv) ? (($rv > 0) ? FALSE : TRUE) : FALSE;
}

sub set_signal_handlers ($)
{
    my $self = $_[0];

    my $rlim = $self->{ISA};
    my $trlo = $self->{OBJ};

    if( $rlim eq TRL_GNU )
    {
	no integer;

	my $a = $trlo->Attribs();
	my $v = $a->{library_version};

	$a->{catch_signals}  = 1;
	$a->{catch_sigwinch} = 1;

	if($v < 4.0) { printf(STDERR RLLIBVER_WARNING, $v) }
	else         { $trlo->clear_signals()              }

	# hmm... OK: seem to work(ish), but readline seems to
	# block all except WINCH until I leave the read/dispatch loop.
	# which means that signals just stack up till we exit,
	# then all happen at once. grrrrh.

	# also readline earlier than v 2.0 doesn't seem to catch WINCH
	# at all, even though the docs say it should. bah. I'm probably
	# doing somethng wrong, but I have no idea what....
	# grumble grumble bloody human interfaces grumble bloody humans...

	$SIG{TSTP} =
	  sub
	  {
	      package Term::ReadLine::Gnu::XS;
	      rl_cleanup_after_signal();
	      DBIShell::Term_CTL::iconify();
	      rl_reset_after_signal();
	  };

	$SIG{TTIN} =
	  sub
	  {
	      package Term::ReadLine::Gnu::XS;
	      rl_cleanup_after_signal();
	      DBIShell::Term_CTL::deiconify();
	      rl_reset_after_signal();
	  };

	$SIG{WINCH} =
  	  sub
  	  {
  	      package Term::ReadLine::Gnu::XS;
  	      rl_cleanup_after_signal();
	      rl_resize_terminal();
  	      rl_reset_after_signal();
  	  };
    }
    elsif ( $rlim eq TRL_PERL )
    {
	# nothing much to do here, there's already a hook and it's on
	# by default....
	$SIG{TSTP} = \&DBIShell::Term_CTL::iconify;
	$SIG{TTIN} = \&DBIShell::Term_CTL::deiconify;
    }
    else
    {
	die(sprintf(COMPLETION_WARNING, $rlim));
    }

    return TRUE;
}

sub set_completion_function ($$)
{
    my $self = $_[0];
    my $func = $_[1];
    my $rlim = $self->{ISA};

    if( $rlim eq TRL_GNU )
    {
	$self->{OBJ}->Attribs()->{completion_function} = $func;
	return TRUE;
    }
    elsif ( $rlim eq TRL_PERL )
    {
	#1: there's a studLycaPs typo in readline.pm:
	#   I hate studlycaps, they suck. A lot. And they're unreadable
	#2: the M- mappings don't seem to get through with
	#   Term::ReadLine::Perl, I don't know why. Bleah.
	$func && warn( <<Bastard );

 Damn! Term::Readline::Perl seems to zap the terminal\'s ability
 to recognise Meta-<foo>: Have to use Esc-<foo> instead....

Bastard
	# This is documented(ish): You have to read the comments in
	# <PERL5LIB>/site_perl/5.005/Term/ReadLine/readline.pm
	# or your equivalent, modulo your perl lib layout:
	$readline::rl_completion_function = $func;
	return TRUE;
    }
    else
    {
	die(sprintf(COMPLETION_WARNING, $rlim));
    }
}

sub preexec ($)
{
    my $self = $_[0];
    my $rlim = $self->{ISA};
    my $trlo = $self->{OBJ};

    # not needed, I think.
    # if( $rlim eq TRL_GNU ) { _trl_gnu_preexec( $trlo ) }
}

sub DESTROY ($)
{
    my $self = $_[0];
    my $rlim = $self->{ISA};

    if( $rlim eq TRL_GNU  ) { $self->_trl_gnu_history_unhook()  }
    if( $rlim eq TRL_PERL ) { $self->_trl_perl_history_unhook() }
}

# Argh. Term::ReadLine::Gnu refilters your completion list
# and throws away the ones where case doesn't match.
sub fussy_completion ($) { ($_[0]->{ISA} eq TRL_GNU) ? TRUE : FALSE }

# these are called often enough that we don't want to be diverted
# through the magic autoloader every time:
sub set_history ($;@) { shift(@_)->{OBJ}->SetHistory(@_)  }
sub add_history ($;@) { shift(@_)->{OBJ}->AddHistory(@_)  }
sub get_history ($)   { $_[0]->{OBJ}->GetHistory()        }
sub readline    ($;$) { $_[0]->{OBJ}->readline($_[1])     }
sub OUT         ($)   { $_[0]->{OBJ}->OUT()               }
sub IN          ($)   { $_[0]->{OBJ}->IN()                }
sub attr        ($)   { $_[0]->{OBJ}->Attribs()           }
sub features    ($)   { $_[0]->{OBJ}->Features()          }

# install the appropriate functions in the pseudo-base class
# so that the current EOL sequence is appended after fetching each line
# from the history. Unfortunately, there is no generic post-history-fetch
# hook, so we have to do this on a per function basis. Also, the functions in
# question are all either native c functions or self-loaded AUTOLOAD functions,
# and therefore not available via any of the dynamic introspection/symbol table
# manipulation methods available to us, so instead, we will inspect the keymaps
# in effect, and replace each keymap binding for a function we want to
# intercept with a binding that activates one of our wrapper functions.
sub advise_history_defuns ($)
{
    my $self = $_[0];
    my $trlo = $self->{OBJ};
    my $rlim = $self->{ISA};

    if    ( $rlim eq TRL_GNU  ) { $self->_trl_gnu_history_hook()  }
    elsif ( $rlim eq TRL_PERL ) { $self->_trl_perl_history_hook() }
}

# the rest of this is private, and should not be called from outside:

# line terminated already or not?
# return position of EOL sequence (ZERO_TRUE if seq at beginning-of-line)
sub _terminated ($$)
{
    my $line = $_[0];
    my $ceol = $_[1];

    chomp( $ceol );
    ($ceol eq '/') && ($ceol = undef());

    if( defined($ceol) )
    {
	my $ep = rindex( $line, $ceol );
	if( $ep > -1 )
	{
	    return
	      ( substr($line, $ep + length($ceol)) =~ /^\s*$/ ) ?
		( $ep || ZERO_TRUE ) :
		  FALSE;
	}
	return FALSE;
    }

    if( ($line =~ m(^/\s*$)) || ($line =~ m([^*\\]/\s*$)) )
    {
	return rindex( $line, DEOL ) || ZERO_TRUE;
    }
    return FALSE;
}

sub _trl_gnu_swap_eol ($$$)
{
    my $trlo = $_[0];
    my $oeol = $_[1];
    my $neol = $_[2];
    my $lb   = $trlo->Attribs()->{line_buffer};

    if( $lb )
    {
	my $ep;

	if( $ep = _terminated($lb, $oeol) )
	{
	    $trlo->delete_text( $ep, length($lb) );
	    $trlo->Attribs()->{point} = ( $ep );
	    $trlo->insert_text( $neol );
	}
    }
}

# This appears to be unneccesary - it's only when we fetch a line from the
# TRL_GNU history and then alter and discard it _without_ using it that
# the recorded line gets altered.
sub _trl_gnu_preexec ($)
{
    my $trlo = $_[0];

    if( $DBIShell::CUR_EOL ne DEOL )
    {
	_trl_gnu_swap_eol( $trlo, $DBIShell::CUR_EOL, DEOL );
    }
}

# insert dynamic EOL hooks into TRL_GNU (causes circularity, I think)
sub _trl_gnu_history_hook ($)
{
    my $self = $_[0];
    my $trlo = $self->{OBJ};

    foreach ( TRL_HISTORY_ADVICE_LIST )
    {
	my $lfunc = undef();
	my $nfunc = undef();
	my $ofunc = $trlo->named_function( $_ );
	my @keys  = $trlo->invoking_keyseqs( $ofunc );
	my $wname = join('-','advised', $_);

	$self->{HHK}     ||= {};
	$self->{HHK}{$_}   = \@keys;

	# replace any keymap entries for history-fetch functions with
	# our EOL-mangling versions. Don't bother adding an advised defun
	# if a function has no keymap entries - remember, we only have 16
	# slots in the default version - if we want more, we may have to
	# import the TRL_GNU source, munge it to add more slots, and install
	# our own private copy. As it is there are ~13 entries of which 5
	# are unbound, giving us a headroom of 8, so we should be Ok.
	# a user with a baroque keymap might be in trouble here though.
	foreach my $key ( @keys )
	{
	    $lfunc ||=
	      sub
	      {
		  my $lb;

		  # restore the previous state of the old line before
		  # discarding it. ( poss bug in TRL_GNU? )
		  if( $DBIShell::CUR_EOL ne DEOL )
		  {
		      _trl_gnu_swap_eol( $trlo, $DBIShell::CUR_EOL, DEOL );

		      $trlo->call_function( $ofunc );

		      _trl_gnu_swap_eol( $trlo, DEOL, $DBIShell::CUR_EOL );
		  }
		  else
		  {
		      $trlo->call_function( $ofunc );
		  }
	      };

	    $nfunc ||=
	      $trlo->named_function( $wname ) ||
		$trlo->add_defun( $wname, $lfunc );

	    $trlo->set_key( $key, $nfunc );
	}
    }
}

# remove dynamic EOL hooks from TRL_GNU (breaks circular reference)
sub _trl_gnu_history_unhook ($)
{
    my $self = $_[0];
    my $trlo = $self->{OBJ};
    my $hook = $self->{HHK};

    foreach my $name ( keys(%$hook) )
    {
	foreach my $key ( @{$hook->{$name}} )
	{
	    $trlo->set_key( $key, $trlo->named_function($name) );
	}
    }
}

# TRL_PERL uses evil StuDlyCappEd function names:
sub _TRL_PERL_StuDlyCap ($)
{
    my $s = $_[0];
    $s =~ s/^(.)|-(.)/\U${+}/g;
    return 'F_' . $s;
}

TRL_PERL_ADVICE_CACHE:
{
    my %cache; # private function cache

    # create the following, if they don't exist:
    # a) A Symbol table entry in the readline package (1 per target function)
    # b) A wrapper function                           (1 per target function)
    # install (b) in (a)
    # return the name of (a), as this is what is stored in TRL_PERL keymaps.
    sub _trl_perl_advise ($)
    {
	use Symbol ();

	my $ofn = $_[0];
	my $nfn = join( '_', 'advised', $ofn );

	if( !$cache{$ofn} )
	{
	    *{ Symbol::qualify_to_ref($nfn, 'readline') } =
	      $cache{$ofn} = 
		sub
		{
		    no strict 'refs';
		    &{"readline::$ofn"}(@_);
		    use strict 'refs';

		    if( $DBIShell::CUR_EOL ne DEOL )
		    {
			local(*LB) = *readline::line;

			if( $LB && !_terminated($LB, $DBIShell::CUR_EOL) )
			{
			    $LB =~ s/\s*$//g;
			    substr( $LB, -length(DEOL), length(DEOL), '' );
			    $LB .= $DBIShell::CUR_EOL;
			    readline::redisplay();
			}
		    }
		};
	}

	return $nfn;
    }

    TRUE;
};

# traverse a TRL_PERL keymap: if a binding points to a function in
# our functions-to-advise hash, install a wrapper function in the
# place of the currently installed function
sub _trl_perl_mapcar (*\%);
sub _trl_perl_mapcar (*\%)
{
    local(*MAP)    = $_[0];
    local(*ADVISE) = $_[1];

    for (my $x = 0; $x < @MAP; $x++)
    {
	if( $MAP[$x] eq 'F_PrefixMeta')
	{
	    my $mname = join('_', $MAP{name}, $x);
	    _trl_perl_mapcar(*{$::{'readline::'}{$mname}}, %ADVISE);
	}
	elsif ( $ADVISE{ $MAP[$x] } )
	{
	    #warn("found #$x == $MAP[$x] <$MAP{name}>\n");
	    $MAP[$x] = _trl_perl_advise( $MAP[$x] );
	}
    }
}

# install the dynamic EOL hooks in TRL_PERL
# note that unlike the TRL_GNU version, this does not create
# a circular reference.
sub _trl_perl_history_hook ($)
{
    my %hmap = ();
    my $self = $_[0];

    foreach ( TRL_HISTORY_ADVICE_LIST )
    {
	my $fname = _TRL_PERL_StuDlyCap( $_ );
	$hmap{$fname} = TRUE;
    }

    _trl_perl_mapcar(*readline::KeyMap,%hmap);
}

# uninstall the dynamic EOL hooks. not implemented yet.
sub _trl_perl_history_unhook ($)
{

}

__END__

# this does some TRL_ hook installation type stuff...
# hopefully we need never do  > 16 of these, because that's all
# TRL_GNU will allow us to do...


# this would be a better way to do things, if I could figure out a way to
# make it trigger only when the last command was a history fetch command...
use constant WRAPPED_FN => 'redisplay';
use constant WRAPPER_FN => 'dbishell-redisplay';


sub _trl_gnu_history_hook ($)
{
    my $self = $_[0];
    my $trlo = $self->{OBJ};
    my $attr = $trlo->Attribs();
    my %hmap = ();

    foreach (TRL_GNU_HISTORY_ADVICE_LIST)
    {
	my $key = $trlo->named_function($_);
	$hmap{$key} = TRUE;
    }

    warn(keys(%hmap),"\n");
    #  $trlo->named_function( WRAPPED_FN );
    #warn("making wrapper <$ofunc>\n");
    my $lfunc =
      sub
      {
	  my $k = $trlo->Attribs()->{last_func};
	  warn("$k\n");
	  if( $hmap{$k} )
	  {
	      $trlo->insert_text( $DBIShell::CUR_EOL );
	  }
	  $trlo->redisplay();
      };

    #warn("add_defun()\n");
    #my $nfunc = $trlo->add_defun( WRAPPER_FN, $lfunc );

    $self->{HHK}                = $attr->{redisplay_function};
    $attr->{redisplay_function} = $lfunc;
}

sub _trl_gnu_history_unhook ()
{
    my $self = $_[0];
    my $trlo = $self->{OBJ};
    $trlo->Attribs()->{redisplay_function} = $self->{HHK};
}