package Tk::Terminal;

=head1 NAME

Tk::Terminal - Running system commands in a Tk::Text widget.

=cut

use strict;
use warnings;
use vars qw( $VERSION );
$VERSION = '0.03';

use Cwd;
use Fcntl;
use File::Basename;
use POSIX ":sys_wait_h";
use IPC::Open3;
use IO::Handle;
#use IO::Pty;
use Term::ANSIColor;
use Tk;
require Tk::Clipboard;

#boilerplating
my $sep = '/';
my $qsep = quotemeta($sep);
my $root = qr/^\//;

use base qw(Tk::Derived Tk::TextANSIColor);
Construct Tk::Widget 'Terminal';

=head1 SYNOPSIS

 require Tk::Terminal;
 my $text= $window->Terminal(@options)->pack;

=head1 DESCRIPTION

Inherits L<Tk::TextANSIColor>.

This module works as a modest command shell. You can enter a command and go into dialog with
the program you are running, if the program does not buffer it's output.

It is in no way a replacement for the standard command shell on your system. It handles ANSI 
colored output, but only colours.

This module will install but not work on Windows.

=head1 OPTIONS

If you change any of the color options while running, you should call B<configureTags> to see the changes.

=over 4

=item Switch B<-buffering>

Default value: 1 (boolean flag)

Used when a process is running.

If buffering is set you have the opportunity to edit your response line
before sending it to the process with return. If buffering is not set every 
key stroke will be sent to the process immediately.

=item Switch B<-dircall>

Callback, called when you change directory.

=item Name B<errorbg>

=item Class B<Errorbg>

=item Switch B<-errorbg>

Default value: #FF0000 (red)

Background color for text tagged as 'error'.

=item Name B<errorfg>

=item Class B<Errorfg>

=item Switch B<-errorfg>

Default value: #FFFF00 (yellow)

Foreground color for text tagged as 'error'.

=item Switch B<-historyfile>

File where the hisory commands given is stored. If you specify this
option the file will be loaded at startup and kept up to date.

=item Switch B<-historymax>

Default value: 64

Maximum size of the command history. If it is full, the oldest entry
is removed when one is added.

=item Name B<linkbg>

=item Class B<Linkbg>

=item Switch B<-linkbg>

Default value: undef

Background color for text tagged as 'link'.

=item Switch B<-linkcall>

Callback to execute when the user clicks a link. It gets the link text as parameter.

=item Name B<linkfg>

=item Class B<Linkfg>

=item Switch B<-linkfg>

Default value: #0000FF (blue)

Foreground color for text tagged as 'link'.

=item Switch B<-linkreg>

Default value: undef

Regular expression used to search for links in the text.
Searching for links is done every time a process finishes.

=item Name B<messagebg>

=item Class B<Messagebg>

=item Switch B<-messagebg>

Default value: undef

Background color for text tagged as 'message'.

=item Name B<messagefg>

=item Class B<Messagefg>

=item Switch B<-messagefg>

Default value: #FFFF00 (blue)

Foreground color for text tagged as 'message'.

=item Name B<tbackground>

=item Class B<Tbackground>

=item Switch B<-tbackground>

Default value: #143B57 (some deep marine blue with a touch of spinache)

Background color for the Tk::Terminal widget.

=item Name B<tfont>

=item Class B<Tfont>

=item Switch B<-tfont>

Default value: Mono 12

Font for the Tk::Terminal widget.

=item Name B<tforeground>

=item Class B<Tforeground>

=item Switch B<-tforeground>

Default value: #F0F0F0 (almost white)

Background color for the Tk::Terminal widget.

=item Switch B<-usercommands>

User defined commands. You can specify a hash with keys that are the commands and
standard Tk callbacks as their value. 

 $term->configure(-usercommands => {
    exit => ['destroy', $app],
 });

=item Switch B<-workdir>

Default value: current working directory.

Acting working directory for commands launched.
Shows up in the prompt.

=back

=head1 KEYBOARD BINDINGS

Most of the keyboard bindings you expect with a command shell apply.
Besides that we have:

=over 4

=item B<CTRL+U>

Toggles buffering.

=item B<CTRL+W>

Performs a clear.

=item B<CTRL+Z>

Kills the currently running process.

=back

=head1 INTERNAL COMMANDS

Commands that are handled internally and not launched as a process:

=over 4

=item B<cd>

Change your working directory. The B<-dircall> callback is called when
you use this command.

=item B<clear>

Performs a clear.

=back

=head1 METHODS

=over 4

=cut

sub Populate {
	my ($self, $args) = @_;
	
#	$args->{'-cursor'} = 'arrow';
	$args->{'-insertwidth'} = 0;
	$args->{'-wrap'} = 'char';

	$self->SUPER::Populate($args);
	$self->{CURRENT} = undef;
	$self->{ERR} = undef;
	$self->{HISTORY} = [];
	$self->{HISTPOINTER} = undef;
	$self->{IN} = undef;
	$self->{OUT} = undef;
	$self->{PID} = undef;
	$self->{SCANNED} = 1;
	$self->{START} = '1.0';
	$self->{WORKDIR} = cwd;
	$self->insert('end', ' ');
	$self->point('1.0');

	$self->ConfigSpecs(
		-buffering => ['PASSIVE', undef, undef, 1],
		-dircall => ['CALLBACK', undef, undef, sub {}],
		-errorbg => ['PASSIVE', 'errorbg', 'Errorbg', '#FF0000'], #red
		-errorfg => ['PASSIVE', 'errorfg', 'Errorfg', '#FFFF00'], #yellow
		-historyfile => ['PASSIVE'],
		-historymax => ['PASSIVE', undef, undef, 64],
		-linkbg => ['PASSIVE', 'linkbg', 'Linkbg', undef],
		-linkcall => ['CALLBACK', undef, undef, sub {}],
		-linkfg => ['PASSIVE', 'linkfg', 'Linkfg', '#0000FF'], #blue
		-linkreg => ['PASSIVE'],
		-messagebg => ['PASSIVE', 'messagebg', 'Messagebg', undef],
		-messagefg => ['PASSIVE', 'messagefg', 'Messagefg', '#FFFF00'], #yellow
		-tbackground => ['PASSIVE', 'tbackground', 'Tbackground', '#143B57'], #some deep marine blue with a touch of spinache
		-tfont => ['PASSIVE', 'tfont', 'Tfont', 'Mono 12'],
		-tforeground => ['PASSIVE', 'tforeground', 'Tforeground', '#F0F0F0'], #almost white
		-uc => ['CALLBACK'],
		-usercommands => ['PASSIVE', undef, undef, {}],
		-workdir => ['METHOD'],
		DEFAULT => [$self],
	);
	$self->after(1, ['postConfig', $self]);
	return $self
}

sub bindRdOnly {
	my ($class, $mw) = @_;

	# Standard Motif bindings:
	$mw->bind($class,'<Meta-B1-Motion>','NoOp');
	$mw->bind($class,'<Meta-1>','NoOp');
	$mw->bind($class,'<Alt-KeyPress>','NoOp');
	$mw->bind($class,'<Meta-KeyPress>','NoOp');
	$mw->bind($class,'<Control-KeyPress>','NoOp');
	$mw->bind($class,'<Escape>','unselectAll');
 
	$mw->bind($class,'<1>',['Button1',Ev('x'),Ev('y')]);
	$mw->bind($class,'<B1-Motion>','B1_Motion' ) ;
	$mw->bind($class,'<B1-Leave>','B1_Leave' ) ;
	$mw->bind($class,'<B1-Enter>','CancelRepeat');
	$mw->bind($class,'<ButtonRelease-1>','CancelRepeat');
	$mw->bind($class,'<Control-1>',['markSet','insert',Ev('@')]);
 
	$mw->bind($class,'<Double-1>','selectWord' ) ;
	$mw->bind($class,'<Triple-1>','selectLine' ) ;
	$mw->bind($class,'<Shift-1>','adjustSelect' ) ;
	$mw->bind($class,'<Double-Shift-1>',['SelectTo',Ev('@'),'word']);
	$mw->bind($class,'<Triple-Shift-1>',['SelectTo',Ev('@'),'line']);
 
	$mw->bind($class,'<Left>',['keyLeft']);
	$mw->bind($class,'<Shift-Left>',['KeySelect',Ev('index','insert-1c')]);
	$mw->bind($class,'<Control-Left>',['SetCursor',Ev('index','insert-1c wordstart')]);
	$mw->bind($class,'<Shift-Control-Left>',['KeySelect',Ev('index','insert-1c wordstart')]);

	$mw->bind($class,'<Right>',['keyRight']);
	$mw->bind($class,'<Shift-Right>',['KeySelect',Ev('index','insert+1c')]);
	$mw->bind($class,'<Control-Right>',['SetCursor',Ev('index','insert+1c wordend')]);
	$mw->bind($class,'<Shift-Control-Right>',['KeySelect',Ev('index','insert wordend')]);
 
	$mw->bind($class,'<Up>',['historyUp']);
	$mw->bind($class,'<Shift-Up>',['KeySelect',Ev('UpDownLine',-1)]);
	$mw->bind($class,'<Control-Up>',['SetCursor',Ev('PrevPara','insert')]);
	$mw->bind($class,'<Shift-Control-Up>',['KeySelect',Ev('PrevPara','insert')]);
 
	$mw->bind($class,'<Down>',['historyDown']);
	$mw->bind($class,'<Shift-Down>',['KeySelect',Ev('UpDownLine',1)]);
	$mw->bind($class,'<Control-Down>',['SetCursor',Ev('NextPara','insert')]);
	$mw->bind($class,'<Shift-Control-Down>',['KeySelect',Ev('NextPara','insert')]);

	$mw->bind($class,'<Home>',['keyHome']);
	$mw->bind($class,'<Shift-Home>',['KeySelect','insert linestart']);
	$mw->bind($class,'<Control-Home>',['SetCursor','1.0']);
	$mw->bind($class,'<Control-Shift-Home>',['KeySelect','1.0']);

	$mw->bind($class,'<End>',['keyEnd']);
	$mw->bind($class,'<Shift-End>',['KeySelect','insert lineend']);
	$mw->bind($class,'<Control-End>',['SetCursor','end-1char']);
	$mw->bind($class,'<Control-Shift-End>',['KeySelect','end-1char']);

	$mw->bind($class,'<Prior>',['SetCursor',Ev('ScrollPages',-1)]);
	$mw->bind($class,'<Shift-Prior>',['KeySelect',Ev('ScrollPages',-1)]);
	$mw->bind($class,'<Control-Prior>',['xview','scroll',-1,'page']);

	$mw->bind($class,'<Next>',['SetCursor',Ev('ScrollPages',1)]);
	$mw->bind($class,'<Shift-Next>',['KeySelect',Ev('ScrollPages',1)]);
	$mw->bind($class,'<Control-Next>',['xview','scroll',1,'page']);

	$mw->bind($class,'<Shift-Tab>', 'NoOp');
	$mw->bind($class,'<Control-Tab>','focusNext');
	$mw->bind($class,'<Control-Shift-Tab>','focusPrev');

	$mw->bind($class,'<Control-space>',['markSet','anchor','insert']);
	$mw->bind($class,'<Select>',['markSet','anchor','insert']);
	$mw->bind($class,'<Control-Shift-space>',['SelectTo','insert','char']);
	$mw->bind($class,'<Shift-Select>',['SelectTo','insert','char']);
	$mw->bind($class,'<Control-slash>','selectAll');
	$mw->bind($class,'<Control-backslash>','unselectAll');

	$mw->bind($class,'<Control-z>','processKill');
	$mw->bind($class,'<Control-u>','bufferToggle');
	$mw->bind($class,'<Control-w>','clear');

	$mw->bind($class,'<Destroy>','Destroy');
#	$mw->bind($class, '<3>', ['PostPopupMenu', Ev('X'), Ev('Y')]  );
	$mw->YMouseWheelBind($class);
	$mw->XMouseWheelBind($class);

	$mw->MouseWheelBind($class);
 
	return $class;
}

sub bufferToggle {
	my $self = shift;
	my $flag = $self->cget('-buffering');
	my $val;
	if ($flag) {
		$self->configure(-buffering => 0);
		$val = 'off';
	} else {
		$self->configure(-buffering => 1);
		$val = 'on';
	}
	$self->condNewline;
	$self->writeMessage("buffering $val\n");
	$self->prompt unless $self->processRuns;
}

=item B<clear>

Kills the current process if one is running and deletes all text.

=cut

sub clear {
	my $self = shift;
	$self->processKill;
	$self->delete('1.0', 'end - 2c');
	$self->linkScanned(1);
	$self->prompt;
}

sub clipboardCut { #Disabling clipboard cut
}

sub clipboardPaste { #clipboard paste now pastes as if typed
	my $self = shift;
	my $text = $self->clipboardGet;
	while ($text =~ s/(.)//) {
		$self->Insert($1); 
	}
}

sub commandGet {
	my $self = shift;
	my $command = $self->get($self->start, $self->start . ' lineend - 1c');
	return $command
}

sub commandSet {
	my ($self, $command) = @_;
	my $start = $self->start;

	#remove current entry
	my $cur = $self->commandGet;
	my $l = length $cur;
	$self->delete($start, "$start + $l c") if $l > 0;

	#insert the new one
	$self->insert('point', $command);
}

=item B<configureTags>

Configures all tags for this package.
Call this if you make changes to any of them.

=cut

# This code was blatantly copied from Tk::TextANSIColor
# It does not generate tags when you inherit it.
my (%fgcolors, %bgcolors);
my $clear = color('clear');  # Code to reset control codes

my $code_bold = color('bold');
my $code_uline= color('underline');
my @colors = qw/black red green yellow blue magenta cyan white/;
for (@colors) {
  my $fg = color($_);
  my $bg = color("on_$_");

  $fgcolors{$fg} = "ANSIfg$_";
  $bgcolors{$bg} = "ANSIbg$_";
}
#end of blatantly copied code

sub condNewline {
	my $self = shift;
	my $point = $self->point;
	my $text = $self->get("$point linestart", $point);
	$self->insert('point', "\n") unless $text eq '';
}

sub configureTags {
	my $self = shift;
	
	# This code was blatantly copied from Tk::TextANSIColor
	# It does not generate tags when you inherit it.
	for (@colors) {
		$self->tagConfigure("ANSIfg$_", -foreground => $_);
		$self->tagConfigure("ANSIbg$_", -background => $_);
	}
	# Underline
	$self->tagConfigure("ANSIul", -underline => 1);
	$self->tagConfigure("ANSIbd", 
		-font => $self->Font(weight => "bold") );
	#end of blatantly copied code

	$self->tagConfigure('prompt', 
		-background => $self->cget(-tforeground),
		-foreground => $self->cget(-tbackground),
	);

	for ('error', 'link', 'message') {
		my $base = $_;
		my @opt = ();
		my $bg = $self->cget("-$base" . 'bg');
		push @opt, -background => $bg if defined $bg;
		my $fg = $self->cget("-$base" . 'fg');
		push @opt, -foreground => $fg if defined $fg;
		$self->tagConfigure($base, @opt);
	}
}

sub cur {
	my $self = shift;
	$self->{CURRENT} = shift if @_;
	return $self->{CURRENT}
}

sub cycleCancel {
	my $self = shift;
	my $cid = $self->{'check_id'};
	$self->afterCancel($cid) if defined $cid;
}

sub deleteBefore {
	my $self = shift;
	if ($self->compare('point','!=', $self->start)) {
		$self->delete('point - 1c');
		$self->see('point')
	}
}
 
sub Delete {
	my $self = shift;
	return if $self->point eq $self->index($self->start . ' lineend - 1c');
	$self->delete('point');
	$self->pointShow;
	$self->see('point')
}

sub directory {
	my ($self, $dir) = @_;
	my $current = $self->cget('-workdir');
	my $path = '';
	while ($dir ne '') {
		if ($dir eq '.') { #same dir
			$path = $current;
			$dir = '';
		} elsif ($dir eq '..') { #parent dir
			$path = dirname($current);
			$dir = '';
		} elsif ($dir eq '~') { #parent dir
			$path = $ENV{'HOME'};
			$dir = '';
		} elsif ($dir =~ s/^\~$qsep(.+)//) { #home directory involved
			$path = $ENV{'HOME'} . "$sep$1";
			$dir = '';
		} elsif ($dir =~ /$root/) { #full path
			$path = $dir;
			$dir = '';
		} elsif ($dir =~ s/^\.\.$qsep//) { #incremental parent dir
			$path = dirname($current);
			$current = $path;
		} else {
			$path = $current . $sep . $dir;
			$dir = '';
		}
	}
	unless (-e $path) {
		$self->writeError("'$path' does not exist\n");
		return
	}
	unless (-d $path) {
		$self->writeError("'$path' is not a directory\n");
		return
	}
	$self->workdir($path);
	$self->Callback('-dircall', $path);
}

sub err {
	my $self = shift;
	$self->{ERR} = shift if @_;
	return $self->{ERR}
}

sub hist {
	my $self = shift;
	$self->{HISTORY} = shift if @_;
	return $self->{HISTORY}
}

sub historyAdd {
	my ($self, $item) = @_;
	return if $item eq '';
	$self->historyRemove($item);
	my $hist = $self->hist;
	unshift @$hist, $item;

	my $max = $self->cget('-historymax');
	pop @$hist if @$hist > $max;

	$self->historySave;
}

sub historyDown {
	my $self = shift;
	my $hist = $self->hist;
	return unless @$hist;
	my $hp = $self->hp;
	return unless defined $hp;
	if ($hp eq 0) {
		$self->commandSet($self->{'hist_save'});
		$self->hp(undef);
	} else {
		$hp --;
		$self->commandSet($hist->[$hp]);
		$self->hp($hp);
	}
	$self->see('point');
}

sub historyLoad {
	my $self = shift;
	my $file = $self->cget('-historyfile');
	if ((defined $file) and (-e $file)) {
		if (open(INPUT, '<', $file)) {
			my $hist = $self->hist;
			$hist = [];
			while (<INPUT>) {
				my $item = $_;
				chomp $item;
				push @$hist, $item;
			}
			close INPUT;
			$self->hist($hist);
		}
	}
}

sub historyRemove {
	my ($self, $item) = @_;
	my $hist = $self->hist;
	my $pos = 0;
	my $found = 0;
	for (@$hist) {
		if ($item eq $_) {
			$found = 1;
			last;
		} else {
			$pos ++
		}
	}
	if ($found) {
		splice @$hist, $pos, 1
	}
}

sub historySave {
	my $self = shift;
	my $file = $self->cget('-historyfile');
	if (defined $file) {
		if (open(OUTPUT, '>', $file)) {
			my $hist = $self->hist;
			for (@$hist) { print OUTPUT $_, "\n" }
			close OUTPUT;
		}
	}
}

sub historyUp {
	my $self = shift;
	my $hist = $self->hist;
	return unless @$hist;
	my $hp = $self->hp;
	unless (defined $hp) {
		$self->{'hist_save'} = $self->commandGet;
		$hp = 0;
	} else {
		return if $hp eq @$hist - 1;
		$hp ++
	}
	$self->commandSet($hist->[$hp]);
	$self->hp($hp);
	$self->see('point');
}

sub hp {
	my $self = shift;
	$self->{HISTPOINTER} = shift if @_;
	return $self->{HISTPOINTER}
}

sub in {
	my $self = shift;
	$self->{IN} = shift if @_;
	return $self->{IN}
}

sub Insert {
	my ($self, $string) = @_;
	return unless (defined $string && $string ne '');
	my $buffering = $self->cget('-buffering');
 	$self->send($string) unless $buffering;
 	if ($string eq "\n") {
 		if ($self->processRuns) {
 			if ($buffering) {
 				$self->send($self->commandGet . "\n");
				$self->point($self->point . ' lineend - 1c');
 			}
			$self->insert('point', $string);
 		} else {
			my $command = $self->commandGet;
			$self->point($self->point . ' lineend - 1c');
			$self->insert('point', $string);
			$self->processLaunch($command);
		}
 	} else {
		$self->insert('point',$string);
	}
	$self->see('point');
}

sub InsertKeyPress {
	my ($self, $char) = @_;
 	return unless length($char);
	if ($self->OverstrikeMode) {
		my $pos = $self->point;
		my $current = $self->get($pos);
		$self->delete($pos) unless ($current eq "\n");
	}
 	$self->Insert($char);
}

sub keyEnd {
	my $self = shift;
	$self->point($self->start . ' lineend - 1c');
}

sub keyHome {
	my $self = shift;
	$self->point($self->start);
}

sub keyLeft {
	my $self = shift;
	$self->point($self->point . ' - 1c') if $self->compare($self->point, '>', $self->start)
}

sub keyRight {
	my $self = shift;
	$self->point($self->point . ' + 1c') if $self->compare($self->point, '<', $self->start . ' lineend - 1c')
}

=item B<launch>I<($command)>

Launches a process with $command as command string.

=cut

sub launch {
	my ($self, $command) = @_;
	$self->commandSet($command);
	$self->Insert("\n");
}

sub linkClick {
	my ($self, $x, $y) = @_;
	my $link;

	#find the link
	my $pos = $self->index('@' ."$x,$y");
	my @ranges = $self->tagRanges('link');
	while (@ranges) {
		my $begin = shift @ranges;
		my $end = shift @ranges;
		if (($self->compare($begin, '<=', $pos)) and ($self->compare($begin, '<=', $pos))) {
			$link = $self->get($begin, $end);
		}
	}

	#invoke the callback
	$self->Callback('-linkcall', $link) if defined $link;
}

sub linkScan {
	my $self = shift;
	my $reg = $self->cget('-linkreg');
	return unless defined $reg;
	my $scanned = $self->linkScanned;

	my $end = $self->index('end - 1c');
	$end =~ /^(\d+)/;
	my $lastline = $1;
	return if $lastline eq $scanned;

	while ($scanned <= $lastline) {
		my $text = $self->get("$scanned.0", "$scanned.0 lineend");
		my $pos = 0;
		while ($text ne '') {
			if ($text =~ s/^($reg)//) {
				my $result = $1;
				my $end = $pos + length($result);
				$self->tagAdd('link', "$scanned.$pos", "$scanned.$end");
				$pos = $end;
			} else {
				$pos ++;
				$text =~ s/^.//; #remove first character
			}
		}
		$scanned ++;
	}

	$self->linkScanned($scanned);
}

sub linkScanned {
	my $self = shift;
	$self->{SCANNED} = shift if @_;
	return $self->{SCANNED}
}

sub out {
	my $self = shift;
	$self->{OUT} = shift if @_;
	return $self->{OUT}
}

sub pid {
	my $self = shift;
	$self->{PID} = shift if @_;
	return $self->{PID}
}

sub point {
	my ($self, $index) = @_;
	if (defined $index) {
		$index = $self->index($index);
		$self->markSet('point', $index);
		$self->pointShow;
	}
	return $self->index('point');
}

sub pointShow {
	my $self = shift;
	$self->tagRemove('prompt', '1.0', 'end');
	$self->tagAdd('prompt', $self->point);
	$self->tagRaise('prompt');
}

sub postConfig {
	my $self = shift;
	$self->configure(-background => $self->cget('-tbackground'));
	$self->configure(-foreground => $self->cget('-tforeground'));
	$self->configure(-font => $self->cget('-tfont'));
	$self->configureTags;
	$self->tagBind('link', '<ButtonRelease-1>', [$self, 'linkClick', Ev('x'), Ev('y')]);
	$self->tagBind('link', '<Enter>', sub { $self->configure(-cursor => 'hand1') });
	$self->tagBind('link', '<Leave>', sub { $self->configure(-cursor => 'xterm') });
	$self->historyLoad;
	$self->prompt;
}

sub processCheck {
	my $self = shift;
	delete $self->{'check_id'};
	my $out = $self->out;
	my $err = $self->err;
	my $buffer;
	if (defined sysread($out, $buffer, 8192)) {
		$self->write($buffer);
	}
	if (defined sysread($err, $buffer, 8192)) {
		$self->writeError($buffer);
	}
	my $pid = $self->pid;
	my $kid = waitpid($pid, WNOHANG);
	if ($kid eq $pid) {
		$self->processFinish
	} else {
		$self->{'check_id'} = $self->after(5, ['processCheck', $self]);
	}
}

sub processFinish {
	my $self = shift;
	$self->pid(undef);
	$self->cur(undef);
	$self->linkScan;
	$self->prompt;
}

=item B<processKill>

Kills the currently running process.
Does nothing if no process runs.

=cut

sub processKill {
	my $self = shift;
	return unless $self->processRuns;
	my $pid = $self->pid;
	kill $pid;
	$self->condNewline;
	my $cmd = $self->cur;
	$self->writeMessage("process $pid, '$cmd' killed\n");
	$self->cycleCancel;
	$self->processFinish;
}

sub processLaunch {
	my ($self, $command) = @_;
	return if $self->processRuns;
	return unless defined $command;
	
	#capture cd command
	if ($command =~ /^cd\s+(.+)/) {
		my $dir = $1;
		$self->historyAdd($command);
		$self->directory($dir);
		$command = '';
	}

	#capture clear command
	if ($command eq 'clear') {
		$self->historyAdd('clear');
		$self->clear;
		return
	}

	#capture user defined commands
	my $uc;
	my @opt = ();
	my $usercmds = $self->cget('-usercommands');
	my $copy = $command;
	while ($copy =~ s/^([^\s]+)\s*//) {
#		print "command $copy\n";
		if (defined $uc) {
		 	push @opt, $1
		} else {
			$uc = $1;
		}
	}
	if (defined $uc) {
		if (my $cmd = $usercmds->{$uc}) {
			$self->historyAdd($command);
			$self->configure(-uc => $cmd);
			$self->Callback('-uc', @opt);
			$command = '';
		}
	}

	my $dir = $self->workdir;
	my $cmdstring  = "cd $dir; $command";

	my $in = new IO::Handle;
	my $out = new IO::Handle;
	my $err = new IO::Handle;
	
	my $pid = open3($in, $out, $err, $cmdstring);
	
	#make out and err non blocking;
	for ($out, $err) {
		my $flags = 0;
		fcntl($_, F_GETFL, $flags)	or die "Couldn't get flags for HANDLE : $!\n";
		$flags |= O_NONBLOCK;
		fcntl($_, F_SETFL, $flags)	or die "Couldn't set flags for HANDLE: $!\n";
	}

	if (defined $pid) {
		$self->pid($pid);
		$self->cur($command);

		$self->historyAdd($command);
		$self->hp(undef);

		$self->in($in);
		$self->out($out);
		$self->err($err);

		$self->after(5, ['processCheck', $self]);
	} else {
		$self->writeError("cannot launch '$command'\n");
	}
}

sub processRuns {
	my $self = shift;
	return defined $self->pid
}

sub prompt {
	my $self = shift;
	$self->condNewline;
	my $dir = $self->workdir;
	$self->writeMessage("$dir: ");
	$self->start('end - 2c');
	$self->point('end - 2c');
}

=item B<send>I<($message)>

Sends $message to the input of the process.
Does nothing if no process is running.

=cut

sub send {
	my ($self, $message) = @_;
	return unless $self->processRuns;
	my $in = $self->in;
	print $in $message;
}

sub start {
	my $self = shift;
	$self->{START} = $self->index(shift) if @_;
	return $self->{START}
}

sub workdir {
	my $self = shift;
	if (@_) {
		my $dir = shift;
		unless (-e $dir) {
			warn "'$dir' does not exist";
			return
		} 
		unless (-d $dir) {
			warn "'$dir' is not a directory";
			return
		} 
		$self->{WORKDIR} = $dir;
	}
	return $self->{WORKDIR}
}

=item B<write>I<($text)>

Appends $text to the end.

=cut

sub write {
	my ($self, $message) = @_;
	$self->insert($self->point, $message);
	$self->start($self->point);
	$self->see('end');
}

=item B<writeError>I<($text)>

Appends $text to the end and tags it as error.

=cut

sub writeError {
	my ($self, $message) = @_;
	$self->writeTagged('error', $message);
}

=item B<writeMessage>I<($text)>

Appends $text to the end and tags it as message.

=cut

sub writeMessage {
	my ($self, $message) = @_;
	$self->writeTagged('message', $message);
}

sub writeTagged {
	my ($self, $tag, $message) = @_;
	my $end = $self->index($self->point);
	$self->insert($end, $message);
	my $l = length ($message);
	$self->tagAdd($tag, $end, "$end + $l c");
	$self->start($self->point);
	$self->see('end');
}

=back

=head1 LICENSE

Same as Perl.

=head1 AUTHOR

Hans Jeuken (hanje at cpan dot org)

=head1 BUGS AND CAVEATS

If you find any bugs, please contact the author.

=cut

1;
__END__


