[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 two
additional methods: C<tkRunning> and C<ornaments>.  The first one
makes Tk event loop run when waiting for user input (i.e., during
C<readline> method), the second one 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 "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.

=head1 EXPORTS

None

=head1 ENVIRONMENT

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

If the variable is not set, the best available package is loaded.

=cut

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

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

sub ReadLine {'Term::ReadLine::Stub'}
sub readline {
  my $self = shift;
  my ($in,$out,$str) = @$self;
  print $out $rl_term_set[0], shift, $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;
  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 (-e "/dev/tty") {
	$console = "/dev/tty";
    } elsif (-e "con") {
	$console = "con";
    } else {
	$console = "sys\$command";
    }

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

    $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);
  if (@_==2) {
    ($console, $consoleOUT) = findConsole;

    open(FIN, "<$console"); 
    open(FOUT,">$consoleOUT");
    #OUT->autoflush(1);		# Conflicts with debugger?
    $sel = select(FOUT);
    $| = 1;				# for DB::OUT
    select($sel);
    bless [\*FIN, \*FOUT];
  } else {			# Filehandles supplied
    $FIN = $_[2]; $FOUT = $_[3];
    #OUT->autoflush(1);		# Conflicts with debugger?
    $sel = select($FOUT);
    $| = 1;				# for DB::OUT
    select($sel);
    bless [$FIN, $FOUT];
  }
}
sub IN { shift->[0] }
sub OUT { shift->[1] }
sub MinLine { undef }
sub Attribs { {} }

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

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

my $which = $ENV{PERL_RL};
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) {	# 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).

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.
@rl_term_set = ("","","","");
# string encoded:
$rl_term_set = ',,,';

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 == 1;
  my @ts = split /,/, $rl_term_set, 4;
  eval { LoadTermCap };
  warn("Cannot find termcap: $@\n"), return unless defined $terminal;
  @rl_term_set = map {$_ ? $terminal->Tputs($_,1) || '' : ''} @ts;
  return $rl_term_set;
}


package Term::ReadLine::Tk;

$count_handle = $count_DoOne = $count_loop = 0;

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;
  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
6fb2d361	108	The stub package included with the perl distribution allows two
	109	additional methods: C<tkRunning> and C<ornaments>. The first one
	110	makes Tk event loop run when waiting for user input (i.e., during
	111	C<readline> method), the second one makes the command line stand out
	112	by using termcap data. The argument to C<ornaments> should be 0, 1,
	113	or a string of a form "aa,bb,cc,dd". Four components of this string
	114	should be names of I<terminal capacities>, first two will be issued to
	115	make the prompt standout, last two to make the input line standout.
	116
cb31d310	117	=head1 EXPORTS
	118
	119	None
	120
a737e074	121	=head1 ENVIRONMENT
	122
	123	The variable C<PERL_RL> governs which ReadLine clone is loaded. If the
	124	value is false, a dummy interface is used. If the value is true, it
	125	should be tail of the name of the package to use, such as C<Perl> or
	126	C<Gnu>.
	127
	128	If the variable is not set, the best available package is loaded.
	129
cb31d310	130	=cut
	131
	132	package Term::ReadLine::Stub;
6fb2d361	133	@ISA = qw'Term::ReadLine::Tk Term::ReadLine::TermCap';
cb31d310	134
cb31d310	135	$DB::emacs = $DB::emacs; # To peacify -w
6fb2d361	136	*rl_term_set = \@Term::ReadLine::TermCap::rl_term_set;
cb31d310	137
	138	sub ReadLine {'Term::ReadLine::Stub'}
	139	sub readline {
a737e074	140	my $self = shift;
a737e074	141	my ($in,$out,$str) = @$self;
6fb2d361	142	print $out $rl_term_set[0], shift, $rl_term_set[1], $rl_term_set[2];
a737e074	143	$self->register_Tk
	144	if not $Term::ReadLine::registered and $Term::ReadLine::toloop
	145	and defined &Tk::DoOneEvent;
	146	#$str = scalar <$in>;
	147	$str = $self->get_line;
6fb2d361	148	print $out $rl_term_set[3];
cb31d310	149	# bug in 5.000: chomping empty string creats length -1:
	150	chomp $str if defined $str;
	151	$str;
	152	}
	153	sub addhistory {}
	154
	155	sub findConsole {
	156	my $console;
	157
	158	if (-e "/dev/tty") {
	159	$console = "/dev/tty";
	160	} elsif (-e "con") {
	161	$console = "con";
	162	} else {
	163	$console = "sys\$command";
	164	}
	165
287f63d2	166	if ($^O eq 'amigaos') {
	167	$console = undef;
	168	}
	169	elsif ($^O eq 'os2') {
cb31d310	170	if ($DB::emacs) {
	171	$console = undef;
	172	} else {
	173	$console = "/dev/con";
	174	}
	175	}
	176
	177	$consoleOUT = $console;
	178	$console = "&STDIN" unless defined $console;
	179	if (!defined $consoleOUT) {
	180	$consoleOUT = defined fileno(STDERR) ? "&STDERR" : "&STDOUT";
	181	}
	182	($console,$consoleOUT);
	183	}
	184
	185	sub new {
	186	die "method new called with wrong number of arguments"
	187	unless @_==2 or @_==4;
	188	#local (FIN, FOUT);
	189	my ($FIN, $FOUT);
	190	if (@_==2) {
	191	($console, $consoleOUT) = findConsole;
	192
	193	open(FIN, "<$console");
	194	open(FOUT,">$consoleOUT");
	195	#OUT->autoflush(1); # Conflicts with debugger?
	196	$sel = select(FOUT);
	197	$\| = 1; # for DB::OUT
	198	select($sel);
	199	bless [\FIN, \FOUT];
	200	} else { # Filehandles supplied
	201	$FIN = $_[2]; $FOUT = $_[3];
	202	#OUT->autoflush(1); # Conflicts with debugger?
	203	$sel = select($FOUT);
	204	$\| = 1; # for DB::OUT
	205	select($sel);
	206	bless [$FIN, $FOUT];
	207	}
	208	}
	209	sub IN { shift->[0] }
	210	sub OUT { shift->[1] }
	211	sub MinLine { undef }
a737e074	212	sub Attribs { {} }
a737e074	213
6fb2d361	214	my %features = (tkRunning => 1, ornaments => 1);
a737e074	215	sub Features { \%features }
cb31d310	216
cb31d310	217	package Term::ReadLine; # So late to allow the above code be defined?
a737e074	218
	219	my $which = $ENV{PERL_RL};
	220	if ($which) {
	221	if ($which =~ /\bgnu\b/i){
	222	eval "use Term::ReadLine::Gnu;";
	223	} elsif ($which =~ /\bperl\b/i) {
	224	eval "use Term::ReadLine::Perl;";
	225	} else {
	226	eval "use Term::ReadLine::$which;";
	227	}
	228	} elsif (defined $which) { # Defined but false
	229	# Do nothing fancy
	230	} else {
	231	eval "use Term::ReadLine::Gnu; 1" or eval "use Term::ReadLine::Perl; 1";
	232	}
cb31d310	233
	234	#require FileHandle;
	235
	236	# To make possible switch off RL in debugger: (Not needed, work done
	237	# in debugger).
	238
	239	if (defined &Term::ReadLine::Gnu::readline) {
	240	@ISA = qw(Term::ReadLine::Gnu Term::ReadLine::Stub);
	241	} elsif (defined &Term::ReadLine::Perl::readline) {
	242	@ISA = qw(Term::ReadLine::Perl Term::ReadLine::Stub);
	243	} else {
	244	@ISA = qw(Term::ReadLine::Stub);
	245	}
	246
6fb2d361	247	package Term::ReadLine::TermCap;
	248
	249	# Prompt-start, prompt-end, command-line-start, command-line-end
	250	# -- zero-width beautifies to emit around prompt and the command line.
	251	@rl_term_set = ("","","","");
	252	# string encoded:
	253	$rl_term_set = ',,,';
	254
	255	sub LoadTermCap {
	256	return if defined $terminal;
	257
	258	require Term::Cap;
	259	$terminal = Tgetent Term::Cap ({OSPEED => 9600}); # Avoid warning.
	260	}
	261
	262	sub ornaments {
	263	shift;
	264	return $rl_term_set unless @_;
	265	$rl_term_set = shift;
	266	$rl_term_set \|\|= ',,,';
	267	$rl_term_set = 'us,ue,md,me' if $rl_term_set == 1;
	268	my @ts = split /,/, $rl_term_set, 4;
	269	eval { LoadTermCap };
	270	warn("Cannot find termcap: $@\n"), return unless defined $terminal;
	271	@rl_term_set = map {$_ ? $terminal->Tputs($_,1) \|\| '' : ''} @ts;
	272	return $rl_term_set;
	273	}
	274
	275
a737e074	276	package Term::ReadLine::Tk;
	277
	278	$count_handle = $count_DoOne = $count_loop = 0;
	279
	280	sub handle {$giveup = 1; $count_handle++}
	281
	282	sub Tk_loop {
	283	# Tk->tkwait('variable',\$giveup); # needs Widget
	284	$count_DoOne++, Tk::DoOneEvent(0) until $giveup;
	285	$count_loop++;
	286	$giveup = 0;
	287	}
	288
	289	sub register_Tk {
	290	my $self = shift;
	291	$Term::ReadLine::registered++
	292	or Tk->fileevent($self->IN,'readable',\&handle);
	293	}
	294
	295	sub tkRunning {
	296	$Term::ReadLine::toloop = $_[1] if @_ > 1;
	297	$Term::ReadLine::toloop;
	298	}
	299
	300	sub get_c {
	301	my $self = shift;
	302	$self->Tk_loop if $Term::ReadLine::toloop && defined &Tk::DoOneEvent;
	303	return getc $self->IN;
	304	}
	305
	306	sub get_line {
	307	my $self = shift;
	308	$self->Tk_loop if $Term::ReadLine::toloop && defined &Tk::DoOneEvent;
	309	my $in = $self->IN;
	310	return scalar <$in>;
	311	}
cb31d310	312
	313	1;
	314