← Back to branch summary

~vcs-imports/debconf/svn

« back to all changes in this revision

Viewing changes to src/debconf/Debconf/FrontEnd/Readline.pm

  • Committer: joeyh
  • Date: 2011-02-02 00:33:44 UTC
  • Revision ID: svn-v4:a4a2c43b-8ac3-0310-8836-e0e880c912e2:trunk:2516
moved to git

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/debconf/Debconf/FrontEnd/Readline.pm
1
 
#!/usr/bin/perl -w
2
 
 
3
 
=head1 NAME
4
 
 
5
 
Debconf::FrontEnd::Readline - Terminal frontend with readline support
6
 
 
7
 
=cut
8
 
 
9
 
package Debconf::FrontEnd::Readline;
10
 
use strict;
11
 
use Term::ReadLine;
12
 
use Debconf::Gettext;
13
 
use base qw(Debconf::FrontEnd::Teletype);
14
 
 
15
 
=head1 DESCRIPTION
16
 
 
17
 
This FrontEnd is for a traditional unix command-line like user interface.
18
 
It features completion if you're using Gnu readline.
19
 
 
20
 
=head1 FIELDS
21
 
 
22
 
=over 4
23
 
 
24
 
=item readline
25
 
 
26
 
An object of type Term::ReadLine, that is used to do the actual prompting.
27
 
 
28
 
=item promptdefault
29
 
 
30
 
Set if the varient of readline being used is so lame that it cannot display
31
 
defaults, so the default must be part of the prompt instead.
32
 
 
33
 
=back
34
 
 
35
 
=head1 METHODS
36
 
 
37
 
=over 4
38
 
 
39
 
=cut
40
 
 
41
 
sub init {
42
 
        my $this=shift;
43
 
 
44
 
        $this->SUPER::init(@_);
45
 
 
46
 
        # Yeah, you need a controlling tty. Make sure there is one.
47
 
        open(TESTTY, "/dev/tty") || die gettext("This frontend requires a controlling tty.")."\n";
48
 
        close TESTTY;
49
 
 
50
 
        $Term::ReadLine::termcap_nowarn = 1; # Turn off stupid termcap warning.
51
 
        $this->readline(Term::ReadLine->new('debconf'));
52
 
        $this->readline->ornaments(1);
53
 
 
54
 
        if (Term::ReadLine->ReadLine =~ /::Gnu$/) {
55
 
                # Well, emacs shell buffer has some annoying interactions
56
 
                # with Term::ReadLine::GNU. It's not worth the pain.
57
 
                if (exists $ENV{TERM} && $ENV{TERM} =~ /emacs/i) {
58
 
                        die gettext("Term::ReadLine::GNU is incompatable with emacs shell buffers.")."\n";
59
 
                }
60
 
                
61
 
                # Ctrl-u or pageup backs up, while ctrl-v or pagedown moves
62
 
                # forward. These key bindings and history completion are only
63
 
                # supported by Gnu ReadLine.
64
 
                $this->readline->add_defun('previous-question', 
65
 
                        sub {
66
 
                                if ($this->capb_backup) {
67
 
                                        $this->_skip(1);
68
 
                                        $this->_direction(-1);
69
 
                                        # Tell readline to quit. Yes, 
70
 
                                        # this is really the best way. <sigh>
71
 
                                        $this->readline->stuff_char(ord "\n");
72
 
                                }
73
 
                                else {
74
 
                                        $this->readline->ding;
75
 
                                }
76
 
                        }, ord "\cu");
77
 
                # This is only defined so people have a readline function
78
 
                # they can remap if they desire.
79
 
                $this->readline->add_defun('next-question',
80
 
                        sub {
81
 
                                if ($this->capb_backup) {
82
 
                                        # Just move onward.
83
 
                                        $this->readline->stuff_char(ord "\n");
84
 
                                }
85
 
                        }, ord "\cv");
86
 
                # FIXME: I cannot figure out a better way to feed in a key 
87
 
                # sequence -- someone help me.
88
 
                $this->readline->parse_and_bind('"\e[5~": previous-question');
89
 
                $this->readline->parse_and_bind('"\e[6~": next-question');
90
 
                $this->capb('backup');
91
 
        }
92
 
        
93
 
        # Figure out which readline module has been loaded, to tell if
94
 
        # prompts must include defaults or not.
95
 
        if (Term::ReadLine->ReadLine =~ /::Stub$/) {
96
 
                $this->promptdefault(1);
97
 
        }
98
 
}
99
 
 
100
 
=item elementtype
101
 
 
102
 
This frontend uses the same elements as does the Teletype frontend.
103
 
 
104
 
=cut
105
 
 
106
 
sub elementtype {
107
 
        return 'Teletype';
108
 
}
109
 
 
110
 
=item go
111
 
 
112
 
Overrides the default go method with something a little more sophisticated.
113
 
This frontend supports backing up, but it doesn't support displaying blocks of
114
 
questions at the same time. So backing up from one block to the next is
115
 
taken care of for us, but we have to handle movement within a block. This
116
 
includes letting the user move back and forth from one question to the next
117
 
in the block, which this method supports.
118
 
 
119
 
The really gritty part is that it keeps track of whether the user moves all
120
 
the way out of the current block and back, in which case they have to start
121
 
at the _last_ question of the previous block, not the first.
122
 
 
123
 
=cut
124
 
 
125
 
sub go {
126
 
        my $this=shift;
127
 
 
128
 
        # First, take care of any noninteractive elements in the block.
129
 
        foreach my $element (grep ! $_->visible, @{$this->elements}) {
130
 
                my $value=$element->show;
131
 
                return if $this->backup && $this->capb_backup;
132
 
                $element->question->value($value);
133
 
        }
134
 
 
135
 
        # Now we only have to deal with the interactive elements.
136
 
        my @elements=grep $_->visible, @{$this->elements};
137
 
        unless (@elements) {
138
 
                $this->_didbackup('');
139
 
                return 1;
140
 
        }
141
 
 
142
 
        # Figure out where to start, based on if we backed up to get here.
143
 
        my $current=$this->_didbackup ? $#elements : 0;
144
 
 
145
 
        # Loop through the elements from starting point until we move
146
 
        # out of either side. The property named "_direction" will indicate
147
 
        # which direction to go next; it is changed elsewhere.
148
 
        $this->_direction(1);
149
 
        for (; $current > -1 && $current < @elements; $current += $this->_direction) {
150
 
                my $value=$elements[$current]->show;
151
 
        }
152
 
 
153
 
        if ($current < 0) {
154
 
                $this->_didbackup(1);
155
 
                return;
156
 
        }
157
 
        else {
158
 
                $this->_didbackup('');
159
 
                return 1;
160
 
        }
161
 
}
162
 
 
163
 
=item prompt
164
 
 
165
 
Prompts the user for input, and returns it. If a title is pending,
166
 
it will be displayed before the prompt.
167
 
 
168
 
This function will return undef if the user opts to skip the question 
169
 
(by backing up or moving on to the next question). Anything that uses this
170
 
function should catch that and handle it, probably by exiting any
171
 
read/validate loop it is in.
172
 
 
173
 
The function uses named parameters.
174
 
 
175
 
Completion amoung available choices is supported. For this to work, if
176
 
a reference to an array of all possible completions is passed in.
177
 
 
178
 
=cut
179
 
 
180
 
sub prompt {
181
 
        my $this=shift;
182
 
        my %params=@_;
183
 
        my $prompt=$params{prompt}." ";
184
 
        my $default=$params{default};
185
 
        my $noshowdefault=$params{noshowdefault};
186
 
        my $completions=$params{completions};
187
 
 
188
 
        if ($completions) {
189
 
                # Set up completion function (a closure).
190
 
                my @matches;
191
 
                $this->readline->Attribs->{completion_entry_function} = sub {
192
 
                        my $text=shift;
193
 
                        my $state=shift;
194
 
                        
195
 
                        if ($state == 0) {
196
 
                                @matches=();
197
 
                                foreach (@{$completions}) {
198
 
                                        push @matches, $_ if /^\Q$text\E/i;
199
 
                                }
200
 
                        }
201
 
 
202
 
                        return pop @matches;
203
 
                };
204
 
        }
205
 
        else {
206
 
                $this->readline->Attribs->{completion_entry_function} = undef;
207
 
        }
208
 
 
209
 
        if (exists $params{completion_append_character}) {
210
 
                $this->readline->Attribs->{completion_append_character}=$params{completion_append_character};
211
 
        }
212
 
        else {
213
 
                $this->readline->Attribs->{completion_append_character}='';
214
 
        }
215
 
        
216
 
        $this->linecount(0);
217
 
        my $ret;
218
 
        $this->_skip(0);
219
 
        if (! $noshowdefault) {
220
 
                $ret=$this->readline->readline($prompt, $default);
221
 
        }
222
 
        else {
223
 
                $ret=$this->readline->readline($prompt);
224
 
        }
225
 
        $this->display_nowrap("\n");
226
 
        return if $this->_skip;
227
 
        $this->_direction(1);
228
 
        $this->readline->addhistory($ret);
229
 
        return $ret;
230
 
}
231
 
 
232
 
=item prompt_password
233
 
 
234
 
Safely prompts for a password; arguments are the same as for prompt.
235
 
 
236
 
=cut
237
 
 
238
 
sub prompt_password {
239
 
        my $this=shift;
240
 
        my %params=@_;
241
 
 
242
 
        if (Term::ReadLine->ReadLine =~ /::Perl$/) {
243
 
                # I hate this library. Sigh. It always echos,
244
 
                # so it is unusable here. Use Teletype's prompt_password.
245
 
                return $this->SUPER::prompt_password(%params);
246
 
        }
247
 
        
248
 
        # Kill default: not a good idea for passwords.
249
 
        delete $params{default};
250
 
        # Force echoing off.
251
 
        system('stty -echo 2>/dev/null');
252
 
        my $ret=$this->prompt(@_, noshowdefault => 1, completions => []);
253
 
        system('stty sane 2>/dev/null');
254
 
        print "\n";
255
 
        return $ret;
256
 
}
257
 
 
258
 
=back
259
 
 
260
 
=head1 AUTHOR
261
 
 
262
 
Joey Hess <joeyh@debian.org>
263
 
 
264
 
=cut
265
 
 
266
 
1