package DBIShell::Term_CTL;

#  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 POSIX;

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

# stuff we use for storing maps and so on:
# theoretically, this should all be properly wrapped up
# in its own objects, blah blah blah, but it just
# isn't worth it for this - maybe in its own project, but
# not here....

use vars qw/%XCTL @XCTL_SCH @XCTL_COM %XCTL_7 %XCTL_8 %OPT/;

@ISA         = qw(Exporter);
@EXPORT      = ();
@EXPORT_OK   =
  qw(CTL_SET_TITLE
     CTL_ICONIFY
     CTL_DEICONIFY
     CTL_GET_TITLE
     SEQUENCE_7BIT
     SEQUENCE_8BIT
    );

%EXPORT_TAGS = ();

use constant XCTL_ESC      => chr(0x1b);
use constant XCTL_7BIT     => '%s%c';
use constant XCTL_CTL_BASE => ord('A') - 1;

use constant CTL_SET_ITITLE     => qw(OSC 1; %s BEL);
use constant CTL_SET_TITLE      => qw(OSC 2; %s BEL);

use constant CTL_GET_TITLE      => qw(CSI 2 1 t);
use constant CTL_GET_ITITLE     => qw(CSI 2 0 t);

use constant CTL_GET_TITLE_RSP  => qw(OSC l %s ST);
use constant CTL_GET_ITITLE_RSP => qw(OSC L %s ST);

use constant CTL_ICONIFY        => qw(CSI 2 t);
use constant CTL_DEICONIFY      => qw(CSI 1 t);

use constant TC_IFLAG =>
  eval { package POSIX; IGNBRK|BRKINT|PARMRK|ISTRIP|INLCR|IGNCR|ICRNL|IXON };

use constant TC_LFLAG =>
  eval { package POSIX; ECHO|ECHONL|ICANON|ISIG|IEXTEN };

use constant TC_CFLAG => eval { package POSIX; CSIZE|PARENB };

sub _XCTL_ESC  ($) { sprintf(XCTL_7BIT, XCTL_ESC, ord($_[0]))  }
sub _XCTL_CTL  ($) { sprintf('%c', ord($_[0]) - XCTL_CTL_BASE) }

@XCTL_SCH = (
	     ESC   => XCTL_ESC,
	     ENQ   => _XCTL_CTL('E'),
	     BEL   => _XCTL_CTL('G'),
	     BS    => _XCTL_CTL('H'),
	     TAB   => _XCTL_CTL('I'),
	     LF    => _XCTL_CTL('J'),
	     VT    => _XCTL_CTL('K'),
	     FF    => _XCTL_CTL('L'),
	     CR    => _XCTL_CTL('M'),
	     SO    => _XCTL_CTL('N'),
	     SI    => _XCTL_CTL('O'),
	     SP    => ' ',
	    );

@XCTL_COM = (
	     DECREQTPARM => qq(CSI 0 x)
	    );

%XCTL_8 = (
	   @XCTL_SCH,
	   @XCTL_COM,
	   IND   => chr(0x84),
	   NEL   => chr(0x85),
	   HTS   => chr(0x88),
	   RI    => chr(0x8d),
	   SS2   => chr(0x8e),
	   SS3   => chr(0x8f),
	   DCS   => chr(0x90),
	   SPA   => chr(0x96),
	   EPA   => chr(0x97),
	   SOS   => chr(0x98),
	   DECID => chr(0x9a),
	   CSI   => chr(0x9b),
	   ST    => chr(0x9c),
	   OSC   => chr(0x9d),
	   PM    => chr(0x9e),
	   APC   => chr(0x9f)
	  );

%XCTL_7 = (
	   @XCTL_SCH,
	   @XCTL_COM,
	   IND   => _XCTL_ESC('D'),
	   NEL   => _XCTL_ESC('E'),
	   HTS   => _XCTL_ESC('H'),
	   RI    => _XCTL_ESC('M'),
	   SS2   => _XCTL_ESC('N'),
	   SS3   => _XCTL_ESC('O'),
	   DCS   => _XCTL_ESC('P'),
	   SPA   => _XCTL_ESC('V'),
	   EPA   => _XCTL_ESC('W'),
	   SOS   => _XCTL_ESC('X'),
	   DECID => _XCTL_ESC('Z'),
	   CSI   => _XCTL_ESC('['),
	   ST    => _XCTL_ESC('\\'),
	   OSC   => _XCTL_ESC(']'),
	   PM    => _XCTL_ESC('^'),
	   APC   => _XCTL_ESC('_')
	  );


$VERSION = 0.01_11;

sub tokenise   (@) { map { split(/\s+/) } @_ }
sub expand_tok ($) { $XCTL{$_[0]}            }

sub interpolate (@)
{
    my @token = @_;

  TOKEN:
    for(my $x = 0; $x < @token; $x++)
    {
	while (exists($XCTL{$token[$x]}))
	{
	    my @new_tok;
	    # special case! SP is our token breaker,
	    # so we can't/mustn't retokenise it:
	    if   ($token[$x] eq 'SP') { @new_tok = expand_tok($token[$x]) }
	    else
	    {
		@new_tok = tokenise(expand_tok($token[$x]))
	    }

	    if($OPT{DEBUG})
	    {
		printf(STDERR "replacing %s with %d token(s): '%s'\n",
		       $token[$x],
		       scalar(@new_tok),
		       join(' ', map { hexlify($_) } @new_tok)
		      );
	    }

	    # in case we have a self referential entry:
	    if($new_tok[0] eq $token[$x])
	    {
		printf(STDERR "Oops!: token 0x%2x recurses...\n",$token[$x]);
		next TOKEN;
	    }

	    splice(@token, $x, @new_tok, @new_tok);
	}
    }

    return @token;
}

# misc debugging stuff:

sub hexlify ($)
{
    my @hexstr;
    my $l = length($_[0]);
    for(my $y = 0; $y < $l; $y++)
    {
	push(@hexstr, sprintf('[%.2x]',ord(substr($_[0], $y, 1))));
    }
    return join('', '<', @hexstr, '>');
}


#incomplete...
sub getsize   () { print(STDOUT SEQUENCE_7BIT('CSI','18','t')) }
sub iconify   () { print(STDOUT SEQUENCE_7BIT(CTL_ICONIFY))    }
sub deiconify () { print(STDOUT SEQUENCE_7BIT(CTL_DEICONIFY))  }

sub set_title ($)
{
    my $newt = $_[0];
    my $oldt = get_title();

    if($newt ne $oldt)
    {
	printf(STDERR SEQUENCE_7BIT(CTL_SET_TITLE), $_[0]);
    }

    return $oldt;
}

sub set_ititle ($)
{
    my $newt = $_[0];
    my $oldt = get_ititle();

    if($newt ne $oldt)
    {
	printf(STDERR SEQUENCE_7BIT(CTL_SET_ITITLE), $_[0]);
    }

    return $oldt;
}

sub get_ititle ()
{
    use vars qw($GISEQ_EOS $GISEQ $GISEQ_PREV $GISEQ_POST $GI_REGEX);
    if(!$GI_REGEX)
    {
	$GISEQ                     = SEQUENCE_7BIT(CTL_GET_ITITLE_RSP);

	($GISEQ_PREV, $GISEQ_POST) = split(/%s/, $GISEQ);
	$GISEQ_EOS                 = substr($GISEQ, -1, 1);
	$GI_REGEX = join('',
			 quotemeta($GISEQ_PREV),
			 '(.*)',
			 quotemeta($GISEQ_POST)
			);
    }

    my $title_seq  = get_response($GISEQ_EOS, CTL_GET_ITITLE);
    $title_seq =~ m/$GI_REGEX/o;
    return $1;
}

sub get_title  ()
{
    use vars qw($GTSEQ_EOS $GTSEQ $GTSEQ_PREV $GTSEQ_POST $GT_REGEX $INIT);

    if(!$GT_REGEX)
    {
	$GTSEQ                     = SEQUENCE_7BIT(CTL_GET_TITLE_RSP);
	($GTSEQ_PREV, $GTSEQ_POST) = split(/%s/, $GTSEQ);
	$GTSEQ_EOS                 = substr($GTSEQ, -1, 1);
	$GT_REGEX = join('',
			 quotemeta($GTSEQ_PREV),
			 '(.*)',
			 quotemeta($GTSEQ_POST)
			);
    }

    #warn("GTSEQ: ", hexlify($GTSEQ),"\n");
    #warn("REGEX: ",
	# (map { !/\x1b/ ? $_ : hexlify($_) }
	#  split(//,$GT_REGEX)),
	# "\n");
    #return undef();
    my $title_seq  = get_response($GTSEQ_EOS, CTL_GET_TITLE);

    #warn((map { !/\x1b/ ? $_ : hexlify($_) } split(//,$title_seq)),"\n");
    $title_seq =~ m/$GT_REGEX/o;
    return $1;
}

sub get_response ($@)
{
    use POSIX qw(:termios_h);

    my $atto;
    my $attn;
    my $eor  = shift(@_);
    my $out  = SEQUENCE_7BIT(@_);
    my $termios;
    my $term_ca;
    my $c;
    my @seq;
    my $fd = fileno(STDERR);
    my($cflag,$iflag,$lflag);

    $termios = POSIX::Termios->new();
    $term_ca = POSIX::Termios->new();
    $termios->getattr($fd);
    $term_ca->getattr($fd);

    $cflag = $termios->getcflag() & ~(TC_CFLAG) | CS8;
    $iflag = $termios->getiflag() & ~(TC_IFLAG);
    $lflag = $termios->getlflag() & ~(TC_LFLAG);

    $termios->setcflag($cflag);
    $termios->setiflag($iflag);
    $termios->setlflag($lflag);

    $termios->setattr($fd, TCSADRAIN);

    syswrite(STDERR, $out, length($out), 0);

    while(sysread(STDERR, $c, 1, 0))
    {
	push(@seq, $c);
	($c eq $eor) && last;
    }

    $term_ca->setattr($fd, TCSAFLUSH);

    return wantarray ? @seq : join('',@seq);
}

sub SEQUENCE_8BIT (@)
{
    *XCTL = *XCTL_8;
    return join('', interpolate(tokenise(@_)));
}

sub SEQUENCE_7BIT (@)
{
    *XCTL = *XCTL_7;
    return join('', interpolate(tokenise(@_)));
}

sub SEQUENCE_8BIT_DEBUG (@)
{
    *XCTL = *XCTL_8;
    return join('', map { hexlify($_) } interpolate(tokenise(@_)));
}

sub SEQUENCE_7BIT_DEBUG (@)
{
    *XCTL = *XCTL_7;
    return join('', map { hexlify($_) } interpolate(tokenise(@_)));
}

__END__

=pod

=head1 NAME

DBIShell::Term_CTL - terminal control routines

=head1 SYNOPSIS

  use DBIShell::Term_CTL;

=head1 DESCRIPTION

This module provides terminal control routines for DBIShell.

=head1 EXPORTED SYMBOLS

=head2 CTL_SET_TITLE

The sprintf format, containing one %s, that when filled with a string, and
printed to STDERR, will set the xterm/dtterm/rxvt's title to the contents
of %s

=head2 CTL_ICONIFY

The control sequence that will iconify the *term in question

=head2 CTL_DEICONIFY

The control sequence that will deiconify the *term in question

=head1 SUBROUTINES

=head2 _XCTL_ESC(CHAR)

Return a 7 bit escape sequence of ESC <CHAR>

=head2 _XCTL_CTL(CHAR)

Return the control character corresponding to ^<CHAR>
[eg _XCTL_CTL('I') returns ^I or TAB]

=head2 get_response(TCHAR, SYMBOLIC_LIST...)

Translates SYMBOLIC_LIST into a term control sequence using SEQUENCE_7BIT
[ L</SEQUENCE_7BIT(LIST)> ], does some black magic with termios, emits the sequence
on STDERR, and reads the response, character by character, using blocking io
until the terminator character TCHAR is encountered.

Returns the whole response. Don't get the terminator wrong, or you'll block,
hard, forever, and you'll have to kill your process from elsewhere.

=head2 get_title()

Return the xterm's title

=head2 set_title(STRING)

Set the xterm's window title to STRING

=head2 get_ititle()

Return the xterms icon label

=head2 set_ititle(STRING)

Set the windows icon title to STRING

=head2 tokenise(LIST...)

Split the text string(s) up into tokens

=head2 expand_tok(TOK)

Expand a token [eg CSI] into its final form

=head2 interpolate(TOKENS...)

Transform a list of tokens into their final form

=head2 hexlify(STRING)

Render a string into hexdigits

=head2 SEQUENCE_8BIT(LIST)

Transform a symbolic control sequent string or list [eg ('CSI', '2', 't')]
into it's fimal 8 bit control sequence form and return it

=head2 SEQUENCE_7BIT(LIST)

Transform a symbolic control sequent string or list [eg ('CSI', '2', 't')]
into it's fimal 7 bit control sequence form and return it

=head2 SEQUENCE_8BIT_DEBUG(LIST)

As above [See L</SEQUENCE_8BIT(LIST)>] but returns a human readable hex
sequence instead

=head2 SEQUENCE_7BIT_DEBUG(LIST)

As above [See L</SEQUENCE_7BIT(LIST)>] but returns a human readable hex
sequence instead

=head1 SEE ALSO

dbishell
ctlseqs.ms from xterm or rxvt source

=head1 AUTHOR

Vivek Dasmohapatra <vivek@etla.org>

=cut