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;
  my $term = new Term::ReadLine 'Simple Perl calc';
  my $prompt = "Enter your arithmetic expression: ";
  my $OUT = $term->OUT || \*STDOUT;
  while ( defined ($_ = $term->readline($prompt)) ) {
    my $res = eval($_);
    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>new().

=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>.

=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 PERL_UNICODE_STDIN () { 0x0001 }

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');
  utf8::upgrade($str)
      if (${^UNICODE} & PERL_UNICODE_STDIN || defined ${^ENCODING}) &&
         utf8::valid($str);
  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.01';

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);
} elsif (defined $which && defined &{"Term::ReadLine::$which\::readline"}) {
  @ISA = "Term::ReadLine::$which";
} 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;

Revision:	1.1
Committed:	Thu Jun 30 14:27:15 2005 UTC (21 years, 4 months ago) by root
Branch:	MAIN
CVS Tags:	PERL-5-8-7, HEAD
Branch point for:	PERL
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.1	=head1 NAME
2
3			Term::ReadLine - Perl interface to various C<readline> packages.
4			If no real package is found, substitutes stubs instead of basic functions.
5
6			=head1 SYNOPSIS
7
8			use Term::ReadLine;
9			my $term = new Term::ReadLine 'Simple Perl calc';
10			my $prompt = "Enter your arithmetic expression: ";
11			my $OUT = $term->OUT \|\| \*STDOUT;
12			while ( defined ($_ = $term->readline($prompt)) ) {
13			my $res = eval($_);
14			warn $@ if $@;
15			print $OUT $res, "\n" unless $@;
16			$term->addhistory($_) if /\S/;
17			}
18
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
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
36			where $term is a return value of Term::ReadLine-E<gt>new().
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>.
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
77			files for input and output using conventions C<"E<lt>$in">, C<"E<gt>out">.
78
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
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
95			If C<Features> method reports a feature C<attribs> as present, the
96			method C<Attribs> is not dummy.
97
98			=back
99
100			=head1 Additional supported functions
101
102			Actually C<Term::ReadLine> can use some other package, that will
103			support reacher set of commands.
104
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
108			The stub package included with the perl distribution allows some
109			additional methods:
110
111			=over 12
112
113			=item C<tkRunning>
114
115			makes Tk event loop run when waiting for user input (i.e., during
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>.
135
136			=head1 EXPORTS
137
138			None
139
140			=head1 ENVIRONMENT
141
142			The environment variable C<PERL_RL> governs which ReadLine clone is
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>.
146
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).
159
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
176			=cut
177
178			use strict;
179
180			package Term::ReadLine::Stub;
181			our @ISA = qw'Term::ReadLine::Tk Term::ReadLine::TermCap';
182
183			$DB::emacs = $DB::emacs; # To peacify -w
184			our @rl_term_set;
185			*rl_term_set = \@Term::ReadLine::TermCap::rl_term_set;
186
187			sub PERL_UNICODE_STDIN () { 0x0001 }
188
189			sub ReadLine {'Term::ReadLine::Stub'}
190			sub readline {
191			my $self = shift;
192			my ($in,$out,$str) = @$self;
193			my $prompt = shift;
194			print $out $rl_term_set[0], $prompt, $rl_term_set[1], $rl_term_set[2];
195			$self->register_Tk
196			if not $Term::ReadLine::registered and $Term::ReadLine::toloop
197			and defined &Tk::DoOneEvent;
198			#$str = scalar <$in>;
199			$str = $self->get_line;
200			$str =~ s/^\s*\Q$prompt\E// if ($^O eq 'MacOS');
201			utf8::upgrade($str)
202			if (${^UNICODE} & PERL_UNICODE_STDIN \|\| defined ${^ENCODING}) &&
203			utf8::valid($str);
204			print $out $rl_term_set[3];
205			# bug in 5.000: chomping empty string creats length -1:
206			chomp $str if defined $str;
207			$str;
208			}
209			sub addhistory {}
210
211			sub findConsole {
212			my $console;
213
214			if ($^O eq 'MacOS') {
215			$console = "Dev:Console";
216			} elsif (-e "/dev/tty") {
217			$console = "/dev/tty";
218			} elsif (-e "con" or $^O eq 'MSWin32') {
219			$console = "con";
220			} else {
221			$console = "sys\$command";
222			}
223
224			if (($^O eq 'amigaos') \|\| ($^O eq 'beos') \|\| ($^O eq 'epoc')) {
225			$console = undef;
226			}
227			elsif ($^O eq 'os2') {
228			if ($DB::emacs) {
229			$console = undef;
230			} else {
231			$console = "/dev/con";
232			}
233			}
234
235			my $consoleOUT = $console;
236			$console = "&STDIN" unless defined $console;
237			if (!defined $consoleOUT) {
238			$consoleOUT = defined fileno(STDERR) ? "&STDERR" : "&STDOUT";
239			}
240			($console,$consoleOUT);
241			}
242
243			sub new {
244			die "method new called with wrong number of arguments"
245			unless @_==2 or @_==4;
246			#local (FIN, FOUT);
247			my ($FIN, $FOUT, $ret);
248			if (@_==2) {
249			my($console, $consoleOUT) = $_[0]->findConsole;
250
251			open(FIN, "<$console");
252			open(FOUT,">$consoleOUT");
253			#OUT->autoflush(1); # Conflicts with debugger?
254			my $sel = select(FOUT);
255			$\| = 1; # for DB::OUT
256			select($sel);
257			$ret = bless [\FIN, \FOUT];
258			} else { # Filehandles supplied
259			$FIN = $_[2]; $FOUT = $_[3];
260			#OUT->autoflush(1); # Conflicts with debugger?
261			my $sel = select($FOUT);
262			$\| = 1; # for DB::OUT
263			select($sel);
264			$ret = bless [$FIN, $FOUT];
265			}
266			if ($ret->Features->{ornaments}
267			and not ($ENV{PERL_RL} and $ENV{PERL_RL} =~ /\bo\w*=0/)) {
268			local $Term::ReadLine::termcap_nowarn = 1;
269			$ret->ornaments(1);
270			}
271			return $ret;
272			}
273
274			sub newTTY {
275			my ($self, $in, $out) = @_;
276			$self->[0] = $in;
277			$self->[1] = $out;
278			my $sel = select($out);
279			$\| = 1; # for DB::OUT
280			select($sel);
281			}
282
283			sub IN { shift->[0] }
284			sub OUT { shift->[1] }
285			sub MinLine { undef }
286			sub Attribs { {} }
287
288			my %features = (tkRunning => 1, ornaments => 1, 'newTTY' => 1);
289			sub Features { \%features }
290
291			package Term::ReadLine; # So late to allow the above code be defined?
292
293			our $VERSION = '1.01';
294
295			my ($which) = exists $ENV{PERL_RL} ? split /\s+/, $ENV{PERL_RL} : undef;
296			if ($which) {
297			if ($which =~ /\bgnu\b/i){
298			eval "use Term::ReadLine::Gnu;";
299			} elsif ($which =~ /\bperl\b/i) {
300			eval "use Term::ReadLine::Perl;";
301			} else {
302			eval "use Term::ReadLine::$which;";
303			}
304			} elsif (defined $which and $which ne '') { # Defined but false
305			# Do nothing fancy
306			} else {
307			eval "use Term::ReadLine::Gnu; 1" or eval "use Term::ReadLine::Perl; 1";
308			}
309
310			#require FileHandle;
311
312			# To make possible switch off RL in debugger: (Not needed, work done
313			# in debugger).
314			our @ISA;
315			if (defined &Term::ReadLine::Gnu::readline) {
316			@ISA = qw(Term::ReadLine::Gnu Term::ReadLine::Stub);
317			} elsif (defined &Term::ReadLine::Perl::readline) {
318			@ISA = qw(Term::ReadLine::Perl Term::ReadLine::Stub);
319			} elsif (defined $which && defined &{"Term::ReadLine::$which\::readline"}) {
320			@ISA = "Term::ReadLine::$which";
321			} else {
322			@ISA = qw(Term::ReadLine::Stub);
323			}
324
325			package Term::ReadLine::TermCap;
326
327			# Prompt-start, prompt-end, command-line-start, command-line-end
328			# -- zero-width beautifies to emit around prompt and the command line.
329			our @rl_term_set = ("","","","");
330			# string encoded:
331			our $rl_term_set = ',,,';
332
333			our $terminal;
334			sub LoadTermCap {
335			return if defined $terminal;
336
337			require Term::Cap;
338			$terminal = Tgetent Term::Cap ({OSPEED => 9600}); # Avoid warning.
339			}
340
341			sub ornaments {
342			shift;
343			return $rl_term_set unless @_;
344			$rl_term_set = shift;
345			$rl_term_set \|\|= ',,,';
346			$rl_term_set = 'us,ue,md,me' if $rl_term_set eq '1';
347			my @ts = split /,/, $rl_term_set, 4;
348			eval { LoadTermCap };
349			unless (defined $terminal) {
350			warn("Cannot find termcap: $@\n") unless $Term::ReadLine::termcap_nowarn;
351			$rl_term_set = ',,,';
352			return;
353			}
354			@rl_term_set = map {$_ ? $terminal->Tputs($_,1) \|\| '' : ''} @ts;
355			return $rl_term_set;
356			}
357
358
359			package Term::ReadLine::Tk;
360
361			our($count_handle, $count_DoOne, $count_loop);
362			$count_handle = $count_DoOne = $count_loop = 0;
363
364			our($giveup);
365			sub handle {$giveup = 1; $count_handle++}
366
367			sub Tk_loop {
368			# Tk->tkwait('variable',\$giveup); # needs Widget
369			$count_DoOne++, Tk::DoOneEvent(0) until $giveup;
370			$count_loop++;
371			$giveup = 0;
372			}
373
374			sub register_Tk {
375			my $self = shift;
376			$Term::ReadLine::registered++
377			or Tk->fileevent($self->IN,'readable',\&handle);
378			}
379
380			sub tkRunning {
381			$Term::ReadLine::toloop = $_[1] if @_ > 1;
382			$Term::ReadLine::toloop;
383			}
384
385			sub get_c {
386			my $self = shift;
387			$self->Tk_loop if $Term::ReadLine::toloop && defined &Tk::DoOneEvent;
388			return getc $self->IN;
389			}
390
391			sub get_line {
392			my $self = shift;
393			$self->Tk_loop if $Term::ReadLine::toloop && defined &Tk::DoOneEvent;
394			my $in = $self->IN;
395			local ($/) = "\n";
396			return scalar <$in>;
397			}
398
399			1;
400