package DBIShell::Fixup;

#  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 Getopt::Long;
use vars qw($VERSION @EXPORT @EXPORT_OK %EXPORT_TAGS @ISA);

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

use constant FIXLIST =>
  {
   'Term::ReadLine::Perl' => *term_readline_perl ,
   'Getopt::Long'         => *getopt_long        ,
  };

# user-visible function:

sub patch ($)
{
    my $patch;
    my $target = $_[0];

    if( $patch = (FIXLIST)->{$target} ) { $patch->() }
}

# FIXUP: Getopt::Long
# fixup for old versions (cf solaris 2.5/2.6 or so, iirc):

use constant GETOPT_WARNING =>
  "Old version of Getopt::Long [%d] detected: trying to kludge it...\n";

sub getopt_long ()
{
    if($::{'Getopt::'} && $::{'Getopt::'}{'Long::'})
    {
	my $sym_tab = $::{'Getopt::'}{'Long::'};

	if(!exists($sym_tab->{Configure}))
	{
	    warn(sprintf(GETOPT_WARNING, $Getopt::Long::VERSION));

	    if(exists($sym_tab->{config}))
	    {
		$sym_tab->{Configure} = *{ $sym_tab->{config} };
	    }
	}
    }
}

# FIXUP: Term::ReadLine::Perl
# fix package so it meets the TIEHASH criteria: this is so we can access
# its attributes in a Term::ReadLine::Gnu compatible way:

package Term::ReadLine::Perl::Tie;

use vars qw(*DBISHELL_GLOB);

package DBIShell::Fixup;

TRL_PERL_PRIVATE:
{
    my @rlh_keys = ();

    sub _trl_perl_tie_firstkey
    {
	package Term::ReadLine::Perl::Tie;

	my $symt;
	if( $symt = $::{'readline::'} )
	{
	    my $key0;
	    (@rlh_keys) = map { s/^rl_//; $_} grep { /^rl_/ } keys( %{$symt} );

	    if( @rlh_keys && ($key0 = $rlh_keys[0]) )
	    {
		local(*DBISHELL_GLOB) = $symt->{ join('_', 'rl_', $key0) };
		return wantarray ? ($key0, $DBISHELL_GLOB) : $key0;
	    }
	}
	return ();
    }

    sub _trl_perl_tie_nextkey
    {
	package Term::ReadLine::Perl::Tie;

	my $symt;
	my $self = shift(@_);
	my $last = shift(@_);

	if( $symt = $::{'readline::'} )
	{
	    my $seen = 0;
	    foreach (@rlh_keys)
	    {
		if( !$seen ){ $seen = ($_ eq $last); next }
		local(*DBISHELL_GLOB) = $symt->{ join('_', 'rl_', $_) };
		return wantarray ? ($_, $DBISHELL_GLOB) : $_;
	    }
	}
	return ();
    }

    1;
};

sub _trl_perl_minline ($;$)
{
    my $rv = $readline::minlength;
    if(@_ == 2) { $readline::minlength = $_[1] }
    return $rv;
}

sub term_readline_perl ()
{
    my $st;

    if( $st =
	$::{'Term::'}                         &&
	$::{'Term::'}{'ReadLine::'}           &&
	$::{'Term::'}{'ReadLine::'}{'Perl::'} )
    {
	$st->{MinLine} = *_trl_perl_minline;
    }

    if( $st = $st && $st->{'Tie::'} )
    {
	$st->{FIRSTKEY} ||= *_trl_perl_tie_firstkey;
	$st->{NEXTKEY}  ||= *_trl_perl_tie_nextkey;
    }
}

__END__