|
996
|
1 package Language::INTERCAL::Interface::Line;
|
|
|
2
|
|
|
3 # line-oriented user interface
|
|
|
4
|
|
|
5 # This file is part of CLC-INTERCAL
|
|
|
6
|
|
|
7 # Copyright (c) 2007-2008 Claudio Calvelli, all rights reserved.
|
|
|
8
|
|
|
9 # CLC-INTERCAL is copyrighted software. However, permission to use, modify,
|
|
|
10 # and distribute it is granted provided that the conditions set out in the
|
|
|
11 # licence agreement are met. See files README and COPYING in the distribution.
|
|
|
12
|
|
|
13 use strict;
|
|
|
14 use vars qw($VERSION $PERVERSION);
|
|
|
15 ($VERSION) = ($PERVERSION = "CLC-INTERCAL/UI-Line INTERCAL/Interface/Line.pm 1.-94.-2") =~ /\s(\S+)$/;
|
|
|
16
|
|
|
17 BEGIN { $ENV{PERL_RL} = 'Gnu'; } # doesn't work with any other ReadLine package
|
|
|
18
|
|
|
19 use Carp;
|
|
|
20 use Term::ReadLine;
|
|
|
21 use Language::INTERCAL::Exporter '1.-94.-2';
|
|
|
22 use Language::INTERCAL::GenericIO '1.-94.-2', qw($stdread $stdwrite);
|
|
|
23
|
|
|
24 sub new {
|
|
|
25 @_ == 2
|
|
|
26 or croak "Usage: Language::INTERCAL::Interface::Line->new(SERVER)";
|
|
|
27 my ($class, $server) = @_;
|
|
|
28 $server or croak "Must provide SERVER";
|
|
|
29 my $term = Term::ReadLine->new('CLC-INTERCAL')
|
|
|
30 or die "Term::ReadLine: $!\n";
|
|
|
31 my $outfile = $term->OUT;
|
|
|
32 if ($outfile) {
|
|
|
33 $outfile = new Language::INTERCAL::GenericIO('FILE', 'r', $outfile);
|
|
|
34 } else {
|
|
|
35 $outfile = $stdread;
|
|
|
36 }
|
|
|
37 my $wobj = bless {
|
|
|
38 prompt => 'Intercalc',
|
|
|
39 buffer => '',
|
|
|
40 server => $server,
|
|
|
41 term => $term,
|
|
|
42 }, 'Language::INTERCAL::Interface::Line::WOBJ';
|
|
|
43 my $infile = new Language::INTERCAL::GenericIO('OBJECT', 'w', $wobj);
|
|
|
44 my $line = bless {
|
|
|
45 term => $term,
|
|
|
46 stdread => $outfile,
|
|
|
47 stdwrite => $infile,
|
|
|
48 wobj => $wobj,
|
|
|
49 }, $class;
|
|
|
50 my $attribs = $term->Attribs;
|
|
|
51 $attribs->{attempted_completion_function} = sub {
|
|
|
52 my ($ignore, $text, $start, $end) = @_;
|
|
|
53 my $code = $line->{complete};
|
|
|
54 return ('') unless $code;
|
|
|
55 my $base = substr($text, $start, $end - $start);
|
|
|
56 $text = substr($text, 0, $end);
|
|
|
57 my $map = sub { $_[0] };
|
|
|
58 if ($text =~ /(?:^|\s)(\w+)$/) {
|
|
|
59 if ($1 eq lc($1)) {
|
|
|
60 $map = sub { lc($_[0]) };
|
|
|
61 } elsif ($1 eq uc($1)) {
|
|
|
62 $map = sub { uc($_[0]) };
|
|
|
63 }
|
|
|
64 }
|
|
|
65 my @list = map { $base . $map->($_) } $code->($text);
|
|
|
66 if (! @list) {
|
|
|
67 $attribs->{rl_completion_suppress_append} = 1;
|
|
|
68 $attribs->{completion_suppress_append} = 1;
|
|
|
69 return '';
|
|
|
70 }
|
|
|
71 if (@list == 1) {
|
|
|
72 my ($word) = @list;
|
|
|
73 if (ref $word) {
|
|
|
74 # special for "attempt filename completion"
|
|
|
75 return ();
|
|
|
76 }
|
|
|
77 if ($word !~ /^\w+$|\s\w+$/) {
|
|
|
78 $attribs->{rl_completion_suppress_append} = 1;
|
|
|
79 $attribs->{completion_suppress_append} = 1;
|
|
|
80 }
|
|
|
81 return $word;
|
|
|
82 }
|
|
|
83 return '', @list;
|
|
|
84 };
|
|
|
85 $attribs->{rl_basic_word_break_characters} = '';
|
|
|
86 $attribs->{basic_word_break_characters} = '';
|
|
|
87 $attribs->{rl_basic_quote_characters} = '';
|
|
|
88 $attribs->{basic_quote_characters} = '';
|
|
|
89 $attribs->{rl_completer_word_break_characters} = '';
|
|
|
90 $attribs->{completer_word_break_characters} = '';
|
|
|
91 $attribs->{rl_special_prefixes} = '';
|
|
|
92 $attribs->{special_prefixes} = '';
|
|
|
93 $line;
|
|
|
94 }
|
|
|
95
|
|
|
96 END {
|
|
|
97 eval { Term::ReadLine->deprep_terminal };
|
|
|
98 }
|
|
|
99
|
|
|
100 sub has_window { 0 }
|
|
|
101 sub is_interactive { 1 }
|
|
|
102
|
|
|
103 sub is_terminal {
|
|
|
104 $stdwrite->is_terminal;
|
|
|
105 }
|
|
|
106
|
|
|
107 sub run {
|
|
|
108 croak "Line mode interface should never enter run()";
|
|
|
109 }
|
|
|
110
|
|
|
111 sub start {
|
|
|
112 croak "Line mode interface should never enter start()";
|
|
|
113 }
|
|
|
114
|
|
|
115 sub stdread {
|
|
|
116 @_ == 1 or croak "Usage: LINE->stdread";
|
|
|
117 my ($line) = @_;
|
|
|
118 $line->{stdread};
|
|
|
119 }
|
|
|
120
|
|
|
121 sub stdwrite {
|
|
|
122 $stdwrite;
|
|
|
123 }
|
|
|
124
|
|
|
125 sub getline {
|
|
|
126 @_ == 2 or croak "Usage: LINE->getline(PROMPT)";
|
|
|
127 my ($line, $prompt) = @_;
|
|
|
128 my $wobj = $line->{wobj};
|
|
|
129 local ($wobj->{prompt}) = $prompt;
|
|
|
130 $line->{stdwrite}->write_text;
|
|
|
131 }
|
|
|
132
|
|
|
133 sub complete {
|
|
|
134 @_ == 1 || @_ == 2 or croak "Usage: LINE->complete [(CALLBACK)]";
|
|
|
135 my ($line, $code) = @_;
|
|
|
136 $line->{complete} = $code;
|
|
|
137 $line;
|
|
|
138 }
|
|
|
139
|
|
|
140 package Language::INTERCAL::Interface::Line::WOBJ;
|
|
|
141
|
|
|
142 sub write {
|
|
|
143 my ($wobj, $size) = @_;
|
|
|
144 my $res = substr($wobj->{buffer}, 0, $size, '');
|
|
|
145 return $res if length $res == $size;
|
|
|
146 $wobj->{buffer} = '';
|
|
|
147 my $term = $wobj->{term};
|
|
|
148 my $server = $wobj->{server};
|
|
|
149 my $go = 1;
|
|
|
150 my $nl = '';
|
|
|
151 my $code = sub {
|
|
|
152 ($nl) = @_;
|
|
|
153 $go = 0;
|
|
|
154 $term->callback_handler_remove;
|
|
|
155 };
|
|
|
156 $term->callback_handler_install($wobj->{prompt}, $code);
|
|
|
157 $server->file_listen(fileno(STDIN),
|
|
|
158 sub { $term->callback_read_char });
|
|
|
159 while ($go) {
|
|
|
160 $server->progress;
|
|
|
161 }
|
|
|
162 $server->file_listen_close(fileno(STDIN));
|
|
|
163 $term->callback_handler_remove;
|
|
|
164 # my $nl = $term->readline($wobj->{prompt}, $res);
|
|
|
165 if (defined $nl) {
|
|
|
166 $term->addhistory($nl);
|
|
|
167 $nl .= "\n";
|
|
|
168 $res = substr($nl, 0, $size, '');
|
|
|
169 $wobj->{buffer} = $nl;
|
|
|
170 return $res;
|
|
|
171 } else {
|
|
|
172 print "\n";
|
|
|
173 return '';
|
|
|
174 }
|
|
|
175 }
|
|
|
176
|
|
|
177 package Language::INTERCAL::Interface::Line::IN;
|
|
|
178
|
|
|
179 sub new {
|
|
|
180 my ($class) = @_;
|
|
|
181 bless \*STDIN, $class;
|
|
|
182 }
|
|
|
183
|
|
|
184 1;
|
