[p5sagit/p5-mst-13.2.git] / lib / Term / ReadLine.pm

=head1 NAME

Term::ReadLine - Perl interface to various C<readline> packages. If
no real package is found, substitutes stubs instead of basic functions.

=head1 SYNOPSIS

  use Term::ReadLine;
  $term = new Term::ReadLine 'Simple Perl calc';
  $prompt = "Enter your arithmetic expression: ";
  $OUT = $term->OUT || STDOUT;
  while ( defined ($_ = $term->readline($prompt)) ) {
    $res = eval($_), "\n";
    warn $@ if $@;
    print $OUT $res, "\n" unless $@;
    $term->addhistory($_) if /\S/;
  }

=head1 DESCRIPTION

This package is just a front end to some other packages. At the moment
this description is written, the only such package is Term-ReadLine,
available on CPAN near you. The real target of this stub package is to
set up a common interface to whatever Readline emerges with time.

=head1 Minimal set of supported functions

All the supported functions should be called as methods, i.e., either as 

  $term = new Term::ReadLine 'name';

or as 

  $term->addhistory('row');

where $term is a return value of Term::ReadLine-E<gt>Init.

=over 12

=item C<ReadLine>

returns the actual package that executes the commands. Among possible
values are C<Term::ReadLine::Gnu>, C<Term::ReadLine::Perl>,
C<Term::ReadLine::Stub Exporter>.

=item C<new>

returns the handle for subsequent calls to following
functions. Argument is the name of the application. Optionally can be
followed by two arguments for C<IN> and C<OUT> filehandles. These
arguments should be globs.

=item C<readline>

gets an input line, I<possibly> with actual C<readline>
support. Trailing newline is removed. Returns C<undef> on C<EOF>.

=item C<addhistory>

adds the line to the history of input, from where it can be used if
the actual C<readline> is present.

=item C<IN>, $C<OUT>

return the filehandles for input and output or C<undef> if C<readline>
input and output cannot be used for Perl.

=item C<MinLine>

If argument is specified, it is an advice on minimal size of line to
be included into history.  C<undef> means do not include anything into
history. Returns the old value.

=item C<findConsole>

returns an array with two strings that give most appropriate names for
files for input and output using conventions C<"E<lt>$in">, C<"E<gt>out">.

=item Attribs

returns a reference to a hash which describes internal configuration
of the package. Names of keys in this hash conform to standard
conventions with the leading C<rl_> stripped.

=item C<Features>

Returns a reference to a hash with keys being features present in
current implementation. Several optional features are used in the
minimal interface: C<appname> should be present if the first argument
to C<new> is recognized, and C<minline> should be present if
C<MinLine> method is not dummy.  C<autohistory> should be present if
lines are put into history automatically (maybe subject to
C<MinLine>), and C<addhistory> if C<addhistory> method is not dummy.

If C<Features> method reports a feature C<attribs> as present, the
method C<Attribs> is not dummy.

=back

=head1 Additional supported functions

Actually C<Term::ReadLine> can use some other package, that will
support reacher set of commands.

All these commands are callable via method interface and have names
which conform to standard conventions with the leading C<rl_> stripped.

The stub package included with the perl distribution allows some
additional methods: 

=over 12

=item C<tkRunning>

makes Tk event loop run when waiting for user input (i.e., during
C<readline> method).

=item C<ornaments>

makes the command line stand out by using termcap data.  The argument
to C<ornaments> should be 0, 1, or a string of a form
C<"aa,bb,cc,dd">.  Four components of this string should be names of
I<terminal capacities>, first two will be issued to make the prompt
standout, last two to make the input line standout.

=item C<newTTY>

takes two arguments which are input filehandle and output filehandle.
Switches to use these filehandles.

=back

One can check whether the currently loaded ReadLine package supports
these methods by checking for corresponding C<Features>.

=head1 EXPORTS

None

=head1 ENVIRONMENT

The environment variable C<PERL_RL> governs which ReadLine clone is
loaded. If the value is false, a dummy interface is used. If the value
is true, it should be tail of the name of the package to use, such as
C<Perl> or C<Gnu>.  

As a special case, if the value of this variable is space-separated,
the tail might be used to disable the ornaments by setting the tail to
be C<o=0> or C<ornaments=0>.  The head should be as described above, say

If the variable is not set, or if the head of space-separated list is
empty, the best available package is loaded.

  export "PERL_RL=Perl o=0"	# Use Perl ReadLine without ornaments
  export "PERL_RL= o=0"		# Use best available ReadLine without ornaments

(Note that processing of C<PERL_RL> for ornaments is in the discretion of the 
particular used C<Term::ReadLine::*> package).

=head1 CAVEATS

It seems that using Term::ReadLine from Emacs minibuffer doesn't work
quite right and one will get an error message like

    Cannot open /dev/tty for read at ...

One possible workaround for this is to explicitly open /dev/tty like this

    open (FH, "/dev/tty" )
      or eval 'sub Term::ReadLine::findConsole { ("&STDIN", "&STDERR") }';
    die $@ if $@;
    close (FH);

or you can try using the 4-argument form of Term::ReadLine->new().

=cut

use strict;

package Term::ReadLine::Stub;
our @ISA = qw'Term::ReadLine::Tk Term::ReadLine::TermCap';

$DB::emacs = $DB::emacs;	# To peacify -w
our @rl_term_set;
*rl_term_set = \@Term::ReadLine::TermCap::rl_term_set;

sub ReadLine {'Term::ReadLine::Stub'}
sub readline {
  my $self = shift;
  my ($in,$out,$str) = @$self;
  my $prompt = shift;
  print $out $rl_term_set[0], $prompt, $rl_term_set[1], $rl_term_set[2]; 
  $self->register_Tk 
     if not $Term::ReadLine::registered and $Term::ReadLine::toloop
	and defined &Tk::DoOneEvent;
  #$str = scalar <$in>;
  $str = $self->get_line;
  $str =~ s/^\s*\Q$prompt\E// if ($^O eq 'MacOS');
  print $out $rl_term_set[3]; 
  # bug in 5.000: chomping empty string creats length -1:
  chomp $str if defined $str;
  $str;
}
sub addhistory {}

sub findConsole {
    my $console;

    if ($^O eq 'MacOS') {
        $console = "Dev:Console";
    } elsif (-e "/dev/tty") {
	$console = "/dev/tty";
    } elsif (-e "con" or $^O eq 'MSWin32') {
	$console = "con";
    } else {
	$console = "sys\$command";
    }

    if (($^O eq 'amigaos') || ($^O eq 'beos') || ($^O eq 'epoc')) {
	$console = undef;
    }
    elsif ($^O eq 'os2') {
      if ($DB::emacs) {
	$console = undef;
      } else {
	$console = "/dev/con";
      }
    }

    my $consoleOUT = $console;
    $console = "&STDIN" unless defined $console;
    if (!defined $consoleOUT) {
      $consoleOUT = defined fileno(STDERR) ? "&STDERR" : "&STDOUT";
    }
    ($console,$consoleOUT);
}

sub new {
  die "method new called with wrong number of arguments" 
    unless @_==2 or @_==4;
  #local (*FIN, *FOUT);
  my ($FIN, $FOUT, $ret);
  if (@_==2) {
    my($console, $consoleOUT) = $_[0]->findConsole;

    open(FIN, "<$console"); 
    open(FOUT,">$consoleOUT");
    #OUT->autoflush(1);		# Conflicts with debugger?
    my $sel = select(FOUT);
    $| = 1;				# for DB::OUT
    select($sel);
    $ret = bless [\*FIN, \*FOUT];
  } else {			# Filehandles supplied
    $FIN = $_[2]; $FOUT = $_[3];
    #OUT->autoflush(1);		# Conflicts with debugger?
    my $sel = select($FOUT);
    $| = 1;				# for DB::OUT
    select($sel);
    $ret = bless [$FIN, $FOUT];
  }
  if ($ret->Features->{ornaments} 
      and not ($ENV{PERL_RL} and $ENV{PERL_RL} =~ /\bo\w*=0/)) {
    local $Term::ReadLine::termcap_nowarn = 1;
    $ret->ornaments(1);
  }
  return $ret;
}

sub newTTY {
  my ($self, $in, $out) = @_;
  $self->[0] = $in;
  $self->[1] = $out;
  my $sel = select($out);
  $| = 1;				# for DB::OUT
  select($sel);
}

sub IN { shift->[0] }
sub OUT { shift->[1] }
sub MinLine { undef }
sub Attribs { {} }

my %features = (tkRunning => 1, ornaments => 1, 'newTTY' => 1);
sub Features { \%features }

package Term::ReadLine;		# So late to allow the above code be defined?

our $VERSION = '1.00';

my ($which) = exists $ENV{PERL_RL} ? split /\s+/, $ENV{PERL_RL} : undef;
if ($which) {
  if ($which =~ /\bgnu\b/i){
    eval "use Term::ReadLine::Gnu;";
  } elsif ($which =~ /\bperl\b/i) {
    eval "use Term::ReadLine::Perl;";
  } else {
    eval "use Term::ReadLine::$which;";
  }
} elsif (defined $which and $which ne '') {	# Defined but false
  # Do nothing fancy
} else {
  eval "use Term::ReadLine::Gnu; 1" or eval "use Term::ReadLine::Perl; 1";
}

#require FileHandle;

# To make possible switch off RL in debugger: (Not needed, work done
# in debugger).
our @ISA;
if (defined &Term::ReadLine::Gnu::readline) {
  @ISA = qw(Term::ReadLine::Gnu Term::ReadLine::Stub);
} elsif (defined &Term::ReadLine::Perl::readline) {
  @ISA = qw(Term::ReadLine::Perl Term::ReadLine::Stub);
} else {
  @ISA = qw(Term::ReadLine::Stub);
}

package Term::ReadLine::TermCap;

# Prompt-start, prompt-end, command-line-start, command-line-end
#     -- zero-width beautifies to emit around prompt and the command line.
our @rl_term_set = ("","","","");
# string encoded:
our $rl_term_set = ',,,';

our $terminal;
sub LoadTermCap {
  return if defined $terminal;
  
  require Term::Cap;
  $terminal = Tgetent Term::Cap ({OSPEED => 9600}); # Avoid warning.
}

sub ornaments {
  shift;
  return $rl_term_set unless @_;
  $rl_term_set = shift;
  $rl_term_set ||= ',,,';
  $rl_term_set = 'us,ue,md,me' if $rl_term_set eq '1';
  my @ts = split /,/, $rl_term_set, 4;
  eval { LoadTermCap };
  unless (defined $terminal) {
    warn("Cannot find termcap: $@\n") unless $Term::ReadLine::termcap_nowarn;
    $rl_term_set = ',,,';
    return;
  }
  @rl_term_set = map {$_ ? $terminal->Tputs($_,1) || '' : ''} @ts;
  return $rl_term_set;
}


package Term::ReadLine::Tk;

our($count_handle, $count_DoOne, $count_loop);
$count_handle = $count_DoOne = $count_loop = 0;

our($giveup);
sub handle {$giveup = 1; $count_handle++}

sub Tk_loop {
  # Tk->tkwait('variable',\$giveup);	# needs Widget
  $count_DoOne++, Tk::DoOneEvent(0) until $giveup;
  $count_loop++;
  $giveup = 0;
}

sub register_Tk {
  my $self = shift;
  $Term::ReadLine::registered++ 
    or Tk->fileevent($self->IN,'readable',\&handle);
}

sub tkRunning {
  $Term::ReadLine::toloop = $_[1] if @_ > 1;
  $Term::ReadLine::toloop;
}

sub get_c {
  my $self = shift;
  $self->Tk_loop if $Term::ReadLine::toloop && defined &Tk::DoOneEvent;
  return getc $self->IN;
}

sub get_line {
  my $self = shift;
  $self->Tk_loop if $Term::ReadLine::toloop && defined &Tk::DoOneEvent;
  my $in = $self->IN;
  local ($/) = "\n";
  return scalar <$in>;
}

1;
Commit	Line	Data
cb31d310	1	=head1 NAME
cb31d310	2
c07a80fd	3	Term::ReadLine - Perl interface to various C<readline> packages. If
cb31d310	4	no real package is found, substitutes stubs instead of basic functions.
	5
	6	=head1 SYNOPSIS
	7
	8	use Term::ReadLine;
	9	$term = new Term::ReadLine 'Simple Perl calc';
	10	$prompt = "Enter your arithmetic expression: ";
	11	$OUT = $term->OUT \|\| STDOUT;
	12	while ( defined ($_ = $term->readline($prompt)) ) {
	13	$res = eval($_), "\n";
	14	warn $@ if $@;
	15	print $OUT $res, "\n" unless $@;
	16	$term->addhistory($_) if /\S/;
	17	}
	18
c07a80fd	19	=head1 DESCRIPTION
	20
	21	This package is just a front end to some other packages. At the moment
	22	this description is written, the only such package is Term-ReadLine,
	23	available on CPAN near you. The real target of this stub package is to
	24	set up a common interface to whatever Readline emerges with time.
	25
cb31d310	26	=head1 Minimal set of supported functions
	27
	28	All the supported functions should be called as methods, i.e., either as
	29
	30	$term = new Term::ReadLine 'name';
	31
	32	or as
	33
	34	$term->addhistory('row');
	35
1fef88e7	36	where $term is a return value of Term::ReadLine-E<gt>Init.
cb31d310	37
	38	=over 12
	39
	40	=item C<ReadLine>
	41
	42	returns the actual package that executes the commands. Among possible
	43	values are C<Term::ReadLine::Gnu>, C<Term::ReadLine::Perl>,
	44	C<Term::ReadLine::Stub Exporter>.
	45
	46	=item C<new>
	47
	48	returns the handle for subsequent calls to following
	49	functions. Argument is the name of the application. Optionally can be
	50	followed by two arguments for C<IN> and C<OUT> filehandles. These
	51	arguments should be globs.
	52
	53	=item C<readline>
	54
	55	gets an input line, I<possibly> with actual C<readline>
	56	support. Trailing newline is removed. Returns C<undef> on C<EOF>.
	57
	58	=item C<addhistory>
	59
	60	adds the line to the history of input, from where it can be used if
	61	the actual C<readline> is present.
	62
	63	=item C<IN>, $C<OUT>
	64
	65	return the filehandles for input and output or C<undef> if C<readline>
	66	input and output cannot be used for Perl.
	67
	68	=item C<MinLine>
	69
	70	If argument is specified, it is an advice on minimal size of line to
	71	be included into history. C<undef> means do not include anything into
	72	history. Returns the old value.
	73
	74	=item C<findConsole>
	75
	76	returns an array with two strings that give most appropriate names for
1fef88e7	77	files for input and output using conventions C<"E<lt>$in">, C<"E<gt>out">.
cb31d310	78
a737e074	79	=item Attribs
	80
	81	returns a reference to a hash which describes internal configuration
	82	of the package. Names of keys in this hash conform to standard
	83	conventions with the leading C<rl_> stripped.
	84
cb31d310	85	=item C<Features>
	86
	87	Returns a reference to a hash with keys being features present in
	88	current implementation. Several optional features are used in the
	89	minimal interface: C<appname> should be present if the first argument
	90	to C<new> is recognized, and C<minline> should be present if
	91	C<MinLine> method is not dummy. C<autohistory> should be present if
	92	lines are put into history automatically (maybe subject to
	93	C<MinLine>), and C<addhistory> if C<addhistory> method is not dummy.
	94
a737e074	95	If C<Features> method reports a feature C<attribs> as present, the
	96	method C<Attribs> is not dummy.
	97
cb31d310	98	=back
cb31d310	99
a737e074	100	=head1 Additional supported functions
a737e074	101
cb31d310	102	Actually C<Term::ReadLine> can use some other package, that will
	103	support reacher set of commands.
	104
a737e074	105	All these commands are callable via method interface and have names
	106	which conform to standard conventions with the leading C<rl_> stripped.
	107
f36776d9	108	The stub package included with the perl distribution allows some
	109	additional methods:
	110
	111	=over 12
	112
	113	=item C<tkRunning>
	114
7a2e2cd6	115	makes Tk event loop run when waiting for user input (i.e., during
f36776d9	116	C<readline> method).
	117
	118	=item C<ornaments>
	119
	120	makes the command line stand out by using termcap data. The argument
	121	to C<ornaments> should be 0, 1, or a string of a form
	122	C<"aa,bb,cc,dd">. Four components of this string should be names of
	123	I<terminal capacities>, first two will be issued to make the prompt
	124	standout, last two to make the input line standout.
	125
	126	=item C<newTTY>
	127
	128	takes two arguments which are input filehandle and output filehandle.
	129	Switches to use these filehandles.
	130
	131	=back
	132
	133	One can check whether the currently loaded ReadLine package supports
	134	these methods by checking for corresponding C<Features>.
7a2e2cd6	135
cb31d310	136	=head1 EXPORTS
	137
	138	None
	139
a737e074	140	=head1 ENVIRONMENT
a737e074	141
8dcee03e	142	The environment variable C<PERL_RL> governs which ReadLine clone is
405ff068	143	loaded. If the value is false, a dummy interface is used. If the value
	144	is true, it should be tail of the name of the package to use, such as
	145	C<Perl> or C<Gnu>.
a737e074	146
405ff068	147	As a special case, if the value of this variable is space-separated,
	148	the tail might be used to disable the ornaments by setting the tail to
	149	be C<o=0> or C<ornaments=0>. The head should be as described above, say
	150
	151	If the variable is not set, or if the head of space-separated list is
	152	empty, the best available package is loaded.
	153
	154	export "PERL_RL=Perl o=0" # Use Perl ReadLine without ornaments
	155	export "PERL_RL= o=0" # Use best available ReadLine without ornaments
	156
	157	(Note that processing of C<PERL_RL> for ornaments is in the discretion of the
	158	particular used C<Term::ReadLine::*> package).
a737e074	159
4c3ccbe1	160	=head1 CAVEATS
	161
	162	It seems that using Term::ReadLine from Emacs minibuffer doesn't work
	163	quite right and one will get an error message like
	164
	165	Cannot open /dev/tty for read at ...
	166
	167	One possible workaround for this is to explicitly open /dev/tty like this
	168
	169	open (FH, "/dev/tty" )
	170	or eval 'sub Term::ReadLine::findConsole { ("&STDIN", "&STDERR") }';
	171	die $@ if $@;
	172	close (FH);
	173
	174	or you can try using the 4-argument form of Term::ReadLine->new().
	175
cb31d310	176	=cut
cb31d310	177
b75c8c73	178	use strict;
b75c8c73	179
cb31d310	180	package Term::ReadLine::Stub;
b75c8c73	181	our @ISA = qw'Term::ReadLine::Tk Term::ReadLine::TermCap';
cb31d310	182
cb31d310	183	$DB::emacs = $DB::emacs; # To peacify -w
b75c8c73	184	our @rl_term_set;
7a2e2cd6	185	*rl_term_set = \@Term::ReadLine::TermCap::rl_term_set;
cb31d310	186
	187	sub ReadLine {'Term::ReadLine::Stub'}
	188	sub readline {
a737e074	189	my $self = shift;
a737e074	190	my ($in,$out,$str) = @$self;
6d697788	191	my $prompt = shift;
6d697788	192	print $out $rl_term_set[0], $prompt, $rl_term_set[1], $rl_term_set[2];
a737e074	193	$self->register_Tk
	194	if not $Term::ReadLine::registered and $Term::ReadLine::toloop
	195	and defined &Tk::DoOneEvent;
	196	#$str = scalar <$in>;
	197	$str = $self->get_line;
6d697788	198	$str =~ s/^\s*\Q$prompt\E// if ($^O eq 'MacOS');
7a2e2cd6	199	print $out $rl_term_set[3];
cb31d310	200	# bug in 5.000: chomping empty string creats length -1:
	201	chomp $str if defined $str;
	202	$str;
	203	}
	204	sub addhistory {}
	205
	206	sub findConsole {
	207	my $console;
	208
6d697788	209	if ($^O eq 'MacOS') {
	210	$console = "Dev:Console";
	211	} elsif (-e "/dev/tty") {
cb31d310	212	$console = "/dev/tty";
8878e869	213	} elsif (-e "con" or $^O eq 'MSWin32') {
cb31d310	214	$console = "con";
	215	} else {
	216	$console = "sys\$command";
	217	}
	218
4d2c4e07	219	if (($^O eq 'amigaos') \|\| ($^O eq 'beos') \|\| ($^O eq 'epoc')) {
287f63d2	220	$console = undef;
	221	}
	222	elsif ($^O eq 'os2') {
cb31d310	223	if ($DB::emacs) {
	224	$console = undef;
	225	} else {
	226	$console = "/dev/con";
	227	}
	228	}
	229
b75c8c73	230	my $consoleOUT = $console;
cb31d310	231	$console = "&STDIN" unless defined $console;
	232	if (!defined $consoleOUT) {
	233	$consoleOUT = defined fileno(STDERR) ? "&STDERR" : "&STDOUT";
	234	}
	235	($console,$consoleOUT);
	236	}
	237
	238	sub new {
	239	die "method new called with wrong number of arguments"
	240	unless @_==2 or @_==4;
	241	#local (FIN, FOUT);
405ff068	242	my ($FIN, $FOUT, $ret);
cb31d310	243	if (@_==2) {
4c3ccbe1	244	my($console, $consoleOUT) = $_[0]->findConsole;
cb31d310	245
	246	open(FIN, "<$console");
	247	open(FOUT,">$consoleOUT");
	248	#OUT->autoflush(1); # Conflicts with debugger?
b75c8c73	249	my $sel = select(FOUT);
cb31d310	250	$\| = 1; # for DB::OUT
cb31d310	251	select($sel);
405ff068	252	$ret = bless [\FIN, \FOUT];
cb31d310	253	} else { # Filehandles supplied
	254	$FIN = $_[2]; $FOUT = $_[3];
	255	#OUT->autoflush(1); # Conflicts with debugger?
b75c8c73	256	my $sel = select($FOUT);
cb31d310	257	$\| = 1; # for DB::OUT
cb31d310	258	select($sel);
405ff068	259	$ret = bless [$FIN, $FOUT];
cb31d310	260	}
405ff068	261	if ($ret->Features->{ornaments}
	262	and not ($ENV{PERL_RL} and $ENV{PERL_RL} =~ /\bo\w*=0/)) {
	263	local $Term::ReadLine::termcap_nowarn = 1;
	264	$ret->ornaments(1);
	265	}
	266	return $ret;
cb31d310	267	}
f36776d9	268
	269	sub newTTY {
	270	my ($self, $in, $out) = @_;
	271	$self->[0] = $in;
	272	$self->[1] = $out;
	273	my $sel = select($out);
	274	$\| = 1; # for DB::OUT
	275	select($sel);
	276	}
	277
cb31d310	278	sub IN { shift->[0] }
	279	sub OUT { shift->[1] }
	280	sub MinLine { undef }
a737e074	281	sub Attribs { {} }
a737e074	282
84902520	283	my %features = (tkRunning => 1, ornaments => 1, 'newTTY' => 1);
a737e074	284	sub Features { \%features }
cb31d310	285
cb31d310	286	package Term::ReadLine; # So late to allow the above code be defined?
a737e074	287
b75c8c73	288	our $VERSION = '1.00';
b75c8c73	289
405ff068	290	my ($which) = exists $ENV{PERL_RL} ? split /\s+/, $ENV{PERL_RL} : undef;
a737e074	291	if ($which) {
	292	if ($which =~ /\bgnu\b/i){
	293	eval "use Term::ReadLine::Gnu;";
	294	} elsif ($which =~ /\bperl\b/i) {
	295	eval "use Term::ReadLine::Perl;";
	296	} else {
	297	eval "use Term::ReadLine::$which;";
	298	}
405ff068	299	} elsif (defined $which and $which ne '') { # Defined but false
a737e074	300	# Do nothing fancy
	301	} else {
	302	eval "use Term::ReadLine::Gnu; 1" or eval "use Term::ReadLine::Perl; 1";
	303	}
cb31d310	304
	305	#require FileHandle;
	306
	307	# To make possible switch off RL in debugger: (Not needed, work done
	308	# in debugger).
b75c8c73	309	our @ISA;
cb31d310	310	if (defined &Term::ReadLine::Gnu::readline) {
	311	@ISA = qw(Term::ReadLine::Gnu Term::ReadLine::Stub);
	312	} elsif (defined &Term::ReadLine::Perl::readline) {
	313	@ISA = qw(Term::ReadLine::Perl Term::ReadLine::Stub);
	314	} else {
	315	@ISA = qw(Term::ReadLine::Stub);
	316	}
	317
7a2e2cd6	318	package Term::ReadLine::TermCap;
	319
	320	# Prompt-start, prompt-end, command-line-start, command-line-end
	321	# -- zero-width beautifies to emit around prompt and the command line.
b75c8c73	322	our @rl_term_set = ("","","","");
7a2e2cd6	323	# string encoded:
b75c8c73	324	our $rl_term_set = ',,,';
7a2e2cd6	325
b75c8c73	326	our $terminal;
7a2e2cd6	327	sub LoadTermCap {
	328	return if defined $terminal;
	329
	330	require Term::Cap;
	331	$terminal = Tgetent Term::Cap ({OSPEED => 9600}); # Avoid warning.
	332	}
	333
	334	sub ornaments {
	335	shift;
	336	return $rl_term_set unless @_;
	337	$rl_term_set = shift;
	338	$rl_term_set \|\|= ',,,';
7b8d334a	339	$rl_term_set = 'us,ue,md,me' if $rl_term_set eq '1';
7a2e2cd6	340	my @ts = split /,/, $rl_term_set, 4;
7a2e2cd6	341	eval { LoadTermCap };
405ff068	342	unless (defined $terminal) {
	343	warn("Cannot find termcap: $@\n") unless $Term::ReadLine::termcap_nowarn;
	344	$rl_term_set = ',,,';
	345	return;
	346	}
7a2e2cd6	347	@rl_term_set = map {$_ ? $terminal->Tputs($_,1) \|\| '' : ''} @ts;
	348	return $rl_term_set;
	349	}
	350
	351
a737e074	352	package Term::ReadLine::Tk;
a737e074	353
b75c8c73	354	our($count_handle, $count_DoOne, $count_loop);
a737e074	355	$count_handle = $count_DoOne = $count_loop = 0;
a737e074	356
b75c8c73	357	our($giveup);
a737e074	358	sub handle {$giveup = 1; $count_handle++}
	359
	360	sub Tk_loop {
	361	# Tk->tkwait('variable',\$giveup); # needs Widget
	362	$count_DoOne++, Tk::DoOneEvent(0) until $giveup;
	363	$count_loop++;
	364	$giveup = 0;
	365	}
	366
	367	sub register_Tk {
	368	my $self = shift;
	369	$Term::ReadLine::registered++
	370	or Tk->fileevent($self->IN,'readable',\&handle);
	371	}
	372
	373	sub tkRunning {
	374	$Term::ReadLine::toloop = $_[1] if @_ > 1;
	375	$Term::ReadLine::toloop;
	376	}
	377
	378	sub get_c {
	379	my $self = shift;
	380	$self->Tk_loop if $Term::ReadLine::toloop && defined &Tk::DoOneEvent;
	381	return getc $self->IN;
	382	}
	383
	384	sub get_line {
	385	my $self = shift;
	386	$self->Tk_loop if $Term::ReadLine::toloop && defined &Tk::DoOneEvent;
	387	my $in = $self->IN;
4e83e451	388	local ($/) = "\n";
a737e074	389	return scalar <$in>;
a737e074	390	}
cb31d310	391
	392	1;
	393