package VCP::UI::Text ; =head1 NAME VCP::UI::Text - A textual user interface for VCP. =head1 SYNOPSIS $ vcp ## VCP::UI::Text is the current default =head1 DESCRIPTION This is a text-only user interface for VCP. It prints out descriptions, prompts the user, reads the responses, and validates input. This class is designed to be refactored and/or inherited from for alternative user interfaces, like GUIs. =head1 METHODS =over =for test_script 00uitext.t =cut $VERSION = 0.1 ; use strict ; use VCP::UIMachines; use VCP::Debug qw( :debug ); use VCP::Utils qw( empty ); use fields ( 'Source', ## reference to the source plugin object 'Dest', ## reference to the destination plugin object 'UIManager' ## UI.pm ) ; sub new { my $class = shift ; $class = ref $class || $class; my VCP::UI::Text $self = do { no strict 'refs' ; bless [ \%{"$class\::FIELDS"} ], $class; }; %$self = @_; return $self ; } =item ask $text_ui->ask( $description, $prompt, $default, $answer_key ); Prompts the user, giving them the possibly lengthy description, a blank line and a prompt. Reads a single line of input and returns it and a reference to the matching answer key. The answer key looks like: [ [ $suggested_answer_1, $validator_1, ... ], [ $suggested_answer_2, $validator_2, ... ], [ $suggested_answer_3, $validator_3, ... ], ... ] The suggested answers are like "yes", "No", etc. Leave this as undef or "" to run a validator without an answer. The validators are one of: undef Entry is compared to the suggested answer, if defined 'foo' Answer must equal 'foo' (case sensitive) qr// Answer must match the indicated regexp sub {...}, \&foo The subroutine will validate. If all validators are strings that are equal to the suggested answer, a multiple choice prompt/response is generated instead of free text entry. Validation subroutines must return TRUE for valid input, FALSE for invalid input but without a message, or die "...\n" with an error message for the user if the input is not valid. If no validators pass, an error message will be printed and the user will be reprompted. If multiple code reference validators fail with different error messages, then these will all be printed. The answer to be validated is placed in $_ when calling a code ref. =cut sub _trim { ( @_ ? $_[0] : $_ ) =~ s/\A[\r\n\s]*(.*?)[\r\n\s]*\z/$1/s or warn "Couldn't trim '$_'"; } { my $try_count = 0; my $prev_prompt = ""; sub ask { my VCP::UI::Text $self = shift; my ( $description, $always_verbose, $prompt, $default, $answer_key ) = @_; die "prompt is required" unless defined $prompt; ## reset $try_count if this is a new question. if ( $prompt ne $prev_prompt ) { $try_count = 0; $prev_prompt = $prompt; } ## take a copy so _trim doesn't modify the original and also ## skip over answer_key records with no suggested answers. my @suggested_answers = grep defined, map $_->[0], @$answer_key; _trim for grep defined, $description, $prompt, @suggested_answers; ## We require that multiple choice is pure multiple choice, ## meaning that if any answer_key records have undef suggested ## answers, its still text input. If need be, we could make ## those multiple choice but offer an "other" choice leading ## to text entry, but that's not yet needed. my $is_multiple_choice = !grep !defined $_->[0] || $_->[0] ne $_->[1], @$answer_key; my $choices; if ( $is_multiple_choice ) { $choices = [ sort @suggested_answers ]; $prompt = $self->build_prompt( $prompt, $default, [] ); } else { $prompt = $self->build_prompt( $prompt, $default, \@suggested_answers ); } while (1) { $self->output( $try_count++ % 10 ? 2 : ( ! $always_verbose && $self->{UIManager}->{TersePrompts} ) ? 1 : 0, $description, $choices, $default, $prompt ); my $answer = $self->input; exit(0) unless defined $answer; # only when piping stdin (test scripts) _trim $answer; if ( $is_multiple_choice && ( length $answer || empty $default ) ) { if ( $answer !~ /\A\d+\z/ || $answer < 1 || $answer > $#suggested_answers + 1 ) { $self->emit_error( "Please enter a number between 1 and ", $#suggested_answers + 1, "." ); next; } $answer = $choices->[ $answer - 1 ]; } $answer = $default if defined $default && ! length $answer; my @results = eval { $self->validate( $answer, $answer_key ) }; return @results if @results > 1; $self->emit_error( @results ? !length $answer ? "Please enter a value." : "Invalid input." : $@ ); } } } =item input my $line = $text_ui->input; Gets the user's input with or without surrounding whitespace and newline. =cut sub input { my VCP::UI::Text $self = shift; return scalar <STDIN>; } =item output $text_ui->output( $terseness, $description, $choices, $default, $prompt ); Outputs the parameters to the user; defaults to print()ing it with stdout buffering off. $description will be undef after the first call until ask() decides that the user needs to see it again. =cut sub output { my VCP::UI::Text $self = shift; my ( $terse, $description, $choices, $default, $prompt ) = @_; local $| = 1; if ( ! $terse && defined $description ) { $description =~ s/^/ /mg; print "\n\n$description\n"; } print "\n"; if ( $terse < 2 && $choices && @$choices ) { my $format = do { my $iw = length( $#$choices + 1 ); my $ow = 0; for ( @$choices ) { $ow = length if ! $ow || length > $ow; } " %${iw}d) %-${ow}s%s\n"; }; my $counter = 0; print map( sprintf( $format, ++$counter, $_, defined $default && $_ eq $default ? " <--default" : "", ), @$choices ), "\n"; } print $prompt, " "; } =item emit_error Prints a message. Defaults to warn()ing. =cut sub emit_error { shift; my $msg = join "", @_; 1 while chomp $msg; $msg =~ s/^/*** /mg; warn $msg, "\n"; } =item build_prompt $text_ui->build_prompt( $prompt, \@suggested_answers ); Assembed $prompt and possibly the strings in \@suggested_answers in to a single string fit for a user. =cut sub build_prompt { my VCP::UI::Text $self = shift; my ( $prompt, $default, $suggested_answers ) = @_; my @s = grep length, @$suggested_answers; return join "", $prompt, @s ? ( " (", join( ", ", sort @s ), ")" ) : (), defined $default ? " [$default]" : "", "?"; } =item validate $text_ui->validate( $answer, $answer_key ); Returns a two element list ( $answer, $matching_answer_key_entry ) or dies with an error message. =cut sub validate { my VCP::UI::Text $self = shift; my ( $answer, $answer_key ) = @_; my @msgs; for my $entry ( @$answer_key ) { debug "checking '$answer' against $entry->[1]" if debugging; return ( $answer, $entry ) if ( ! defined $entry->[1] && ( ! defined $entry->[0] || $answer eq $entry->[0] ) ) || ( ref $entry->[1] eq "" && $answer eq $entry->[1] ) || ( ref $entry->[1] eq "Regexp" && $answer =~ $entry->[1] ) || ( ref $entry->[1] eq "CODE" && do { local $_ = $answer; my $ok = eval { $entry->[1]->() || 0 }; push @msgs, $@ unless defined $ok; $ok; } ); } die join "", @msgs if @msgs; return 0; } sub run { my VCP::UI::Text $self = shift; my $m = VCP::UIMachines->new; $m->run( $self ); return( $self->{Source}, $self->{Dest} ); } =back =head1 COPYRIGHT Copyright 2000, Perforce Software, Inc. All Rights Reserved. This module and the VCP::UI::Text package are licensed according to the terms given in the file LICENSE accompanying this distribution, a copy of which is included in L<vcp>. =head1 AUTHOR Barrie Slaymaker <barries@slaysys.com> =cut 1
# | Change | User | Description | Committed | |
---|---|---|---|---|---|
#17 | 5401 | Barrie Slaymaker | - UI updated | ||
#16 | 4064 | Barrie Slaymaker |
- RevML is no longer offered in the UI - Sources and dests are given an id in the UI - The .vcp file name defaulting now works |
||
#15 | 4021 | Barrie Slaymaker |
- Remove all phashes and all base & fields pragmas - Work around SWASHGET error |
||
#14 | 4012 | Barrie Slaymaker | - Remove dependance on pseudohashes (deprecated Perl feature) | ||
#13 | 3666 | Barrie Slaymaker | - vcp can now edit existing .vcp files, for VSS sources and revml dests | ||
#12 | 3663 | Barrie Slaymaker |
- Yes/no questions may be answered 'y' or 'n' (case insensitive) - Multiple choice questions may be answered by typing in full text of an answer (case insensitive) |
||
#11 | 3646 | Barrie Slaymaker | - Further UI improvements | ||
#10 | 3643 | Barrie Slaymaker | - UI formatting cleanup | ||
#9 | 3640 | Barrie Slaymaker |
- xmllint no longer require to build UI - UI now offers multiple choices where appropriate |
||
#8 | 3567 | John Fetkovich |
- added the field UIManager in VCP::UI::Text.pm - added the fields UIImplementation and TersePrompts in UI.pm - removed Source and Dest fields in VCP::UI.pm - UI.pm now returns the result of running the UI implementation. - VCP::UI::Text->run return a list of (source, dest) all future UI implementations must do the same. - bin/vcp gets (source, dest) list from VCP::UI->run. - added --terse (or -t) command line option to vcp to remove verbose help from interactive UI. |
||
#7 | 3560 | John Fetkovich |
make text UI ready for testing via piping from stdin. VCP::TestUtils::Run now optionally may use IPC::Run rather than IPC::Run3. |
||
#6 | 3499 | John Fetkovich |
- implement recoverable and non-recoverable exceptions in arc handlers. A user may accept a value that generated a recoverable exception. Otherwise, the question will be re-asked. - changed exceptions text in ui_set_revml_repo_spec. |
||
#5 | 3494 | John Fetkovich | default values in interactive ui partially implemented | ||
#4 | 3375 | John Fetkovich | more ui changes | ||
#3 | 3288 | John Fetkovich | Add Source and Dest fields | ||
#2 | 3244 | Barrie Slaymaker |
Integrate VCP::UI with bin/vcp. Type 'vcp' to run the UI. |
||
#1 | 3237 | Barrie Slaymaker | More work on the UI StateML conventions |