package VCP::UIMachines;
=begin hackers
DO NOT EDIT!!! GENERATED FROM ui_machines/vcp_ui.tt2 by C:\Perl\bin\stml AT Wed Apr 12 12:07:29 2006
=end hackers
=head1 NAME
VCP::UIMachines - State machines for user interface
=head1 SYNOPSIS
Called by VCP::UI
=head1 DESCRIPTION
The user interface module L<VCP::UI|VCP::UI> is a framework that bolts
the implementation of the user interface to a state machine representing
the user interface.
Each state in this state machine is a method that runs the state and
returns a result (or dies to exit the program).
=cut
use strict;
use VCP::Debug qw( :debug );
use VCP::Utils qw( empty is_win32 );
=head1 API
=over
=item new
Creates a new user interface object.
=cut
sub new {
my $class = ref $_[0] ? ref shift : shift;
my $self = bless { @_ }, $class;
}
=item run
Executes the user interface.
=cut
sub run {
my $self = shift;
my ( $ui ) = @_;
$self->{STATE} = "init";
while ( defined $self->{STATE} ) {
debug "UI entering state $self->{STATE}" if debugging;
no strict "refs";
$self->{STATE} = $self->{STATE}->( $ui );
}
return;
}
=back
=head2 Interactive Methods
=over
=cut
use strict;
=item init
Initialize the machine
Next state: source_id_prompt
=cut
sub init {
return 'source_id_prompt';
}
=item source_id_prompt: Source ID
The source ID is used internally by VCP to organize the VCP
databases and to refer to the source repository. The source ID
need not appear in your source repository, nor does it appear in
your destination repository after conversion.
A source ID must start with an alphabetic character, and
can include alphanumeric characters, underscores, and dashes.
Do not use spaces and punctuation characters in source IDs.
Enter a symbolic name for the source repository.
Valid answers ("answer (regexp) => next prompt"):
(qr{\A[a-z][a-z_0-9-]*\z}i) => source_type_prompt
=cut
sub source_id_prompt {
my ( $ui ) = @_;
my $default = undef;
my $is_current_value = undef;
## Use single-quotish HERE docs as the most robust form of quoting
## so we don't have to mess with escaping.
my $prompt = <<'END_PROMPT';
Source ID
END_PROMPT
chomp $prompt;
my @valid_answers = (
[ '', qr{\A[a-z][a-z_0-9-]*\z}i, 'source_type_prompt',
sub {
my ( $ui, $answer, $answer_record ) = @_;
## Set the UI's source_repo_id. This will write-through to
## the underlying source if it's been loaded already,
## otherwise the call to new_source() will do the write-through
## when it is loaded later.
$ui->source_repo_id( $answer )
unless ! empty $ui->source_repo_id and empty $answer;
},
],
);
my $description = <<'END_DESCRIPTION';
The source ID is used internally by VCP to organize the VCP
databases and to refer to the source repository. The source ID
need not appear in your source repository, nor does it appear in
your destination repository after conversion.
A source ID must start with an alphabetic character, and
can include alphanumeric characters, underscores, and dashes.
Do not use spaces and punctuation characters in source IDs.
Enter a symbolic name for the source repository.
END_DESCRIPTION
$default = $ui->source_repo_id && $ui->source_repo_id;
$is_current_value = $ui->{EditMode} = 1 unless empty $default;
while (1) {
my ( $answer, $answer_record ) =
$ui->ask(
0,
$description,
0,
$prompt,
$prompt,
$default,
$is_current_value,
\@valid_answers
);
## Run handlers for this arc, redo question if exceptions generated
my $ok = eval {
$answer_record->[-1]->( $ui, $answer, $answer_record )
if defined $answer_record->[-1];
1;
};
unless ( $ok ) {
my $eval_error = $@;
if ( $eval_error =~ /^warning:/i ) {
## recoverable error, ask if user wants to accept value anyway?
my ( undef, $r ) = $ui->ask(
'error',
$eval_error,
1,
"Warning",
"Accept this value anyway",
"no",
0,
[
[ "yes", "yes", undef ],
[ "no", "no", undef ],
]
);
next unless $r->[0] eq "yes";
}
else {
## completely un-acceptable exception, re-ask question.
chomp $eval_error;
warn "\n\n $eval_error\n\n";
next;
}
}
## The next state
return $answer_record->[-2];
}
}
=item source_type_prompt: Source type
What type of repository are you copying revisions from?
Valid answers ("answer (regexp) => next prompt"):
p4 ('p4') => source_p4_run_p4d_prompt
vss ('vss') => source_vss_vssroot_prompt
cvs ('cvs') => source_cvs_cvsroot_prompt
=cut
sub source_type_prompt {
my ( $ui ) = @_;
my $default = undef;
my $is_current_value = undef;
## Use single-quotish HERE docs as the most robust form of quoting
## so we don't have to mess with escaping.
my $prompt = <<'END_PROMPT';
Source type
END_PROMPT
chomp $prompt;
my @valid_answers = (
[ 'p4', 'p4', 'source_p4_run_p4d_prompt',
sub {
my ( $ui, $answer, $answer_record ) = @_;
$ui->new_source( $answer );
},
],
[ 'vss', 'vss', 'source_vss_vssroot_prompt',
sub {
my ( $ui, $answer, $answer_record ) = @_;
$ui->new_source( $answer );
},
],
[ 'cvs', 'cvs', 'source_cvs_cvsroot_prompt',
sub {
my ( $ui, $answer, $answer_record ) = @_;
$ui->new_source( $answer );
},
],
);
my $description = <<'END_DESCRIPTION';
What type of repository are you copying revisions from?
END_DESCRIPTION
$default = $ui->source && $ui->source->repo_scheme;
$is_current_value = $ui->{EditMode} = 1 unless empty $default;
while (1) {
my ( $answer, $answer_record ) =
$ui->ask(
0,
$description,
0,
$prompt,
$prompt,
$default,
$is_current_value,
\@valid_answers
);
## Run handlers for this arc, redo question if exceptions generated
my $ok = eval {
$answer_record->[-1]->( $ui, $answer, $answer_record )
if defined $answer_record->[-1];
1;
};
unless ( $ok ) {
my $eval_error = $@;
if ( $eval_error =~ /^warning:/i ) {
## recoverable error, ask if user wants to accept value anyway?
my ( undef, $r ) = $ui->ask(
'error',
$eval_error,
1,
"Warning",
"Accept this value anyway",
"no",
0,
[
[ "yes", "yes", undef ],
[ "no", "no", undef ],
]
);
next unless $r->[0] eq "yes";
}
else {
## completely un-acceptable exception, re-ask question.
chomp $eval_error;
warn "\n\n $eval_error\n\n";
next;
}
}
## The next state
return $answer_record->[-2];
}
}
=item dest_id_prompt: Destination ID
The destination ID is used internally by VCP to organize the VCP
databases and to refer to the destination repository. The destination
ID does not appear in your destination repository after conversion.
A destination ID must start with an alphabetic character, and
can include alphanumeric characters, underscores, and dashes.
Do not use spaces and punctuation characters in destination IDs.
Enter a symbolic name for the destination repository.
Valid answers ("answer (regexp) => next prompt"):
(qr{\A[a-z][a-z_0-9-]*\z}i) => dest_type_prompt
=cut
sub dest_id_prompt {
my ( $ui ) = @_;
my $default = undef;
my $is_current_value = undef;
## Use single-quotish HERE docs as the most robust form of quoting
## so we don't have to mess with escaping.
my $prompt = <<'END_PROMPT';
Destination ID
END_PROMPT
chomp $prompt;
my @valid_answers = (
[ '', qr{\A[a-z][a-z_0-9-]*\z}i, 'dest_type_prompt',
sub {
my ( $ui, $answer, $answer_record ) = @_;
## Set the UI's dest_repo_id. This will write-through to
## the underlying destination if it's been loaded already,
## otherwise the call to new_dest() will do the write-through
## when it is loaded later.
$ui->dest_repo_id( $answer )
unless ! empty $ui->dest_repo_id and empty $answer;
},
],
);
my $description = <<'END_DESCRIPTION';
The destination ID is used internally by VCP to organize the VCP
databases and to refer to the destination repository. The destination
ID does not appear in your destination repository after conversion.
A destination ID must start with an alphabetic character, and
can include alphanumeric characters, underscores, and dashes.
Do not use spaces and punctuation characters in destination IDs.
Enter a symbolic name for the destination repository.
END_DESCRIPTION
$default = $ui->dest_repo_id && $ui->dest_repo_id;
$is_current_value = $ui->{EditMode} = 1 unless empty $default;
while (1) {
my ( $answer, $answer_record ) =
$ui->ask(
0,
$description,
0,
$prompt,
$prompt,
$default,
$is_current_value,
\@valid_answers
);
## Run handlers for this arc, redo question if exceptions generated
my $ok = eval {
$answer_record->[-1]->( $ui, $answer, $answer_record )
if defined $answer_record->[-1];
1;
};
unless ( $ok ) {
my $eval_error = $@;
if ( $eval_error =~ /^warning:/i ) {
## recoverable error, ask if user wants to accept value anyway?
my ( undef, $r ) = $ui->ask(
'error',
$eval_error,
1,
"Warning",
"Accept this value anyway",
"no",
0,
[
[ "yes", "yes", undef ],
[ "no", "no", undef ],
]
);
next unless $r->[0] eq "yes";
}
else {
## completely un-acceptable exception, re-ask question.
chomp $eval_error;
warn "\n\n $eval_error\n\n";
next;
}
}
## The next state
return $answer_record->[-2];
}
}
=item dest_type_prompt: Destination SCM type
What type of repository are you copying revisions to?
Valid answers ("answer (regexp) => next prompt"):
cvs ('cvs') => dest_cvs_cvsroot_prompt
p4 ('p4') => dest_p4_run_p4d_prompt
vss ('vss') => dest_vss_vssroot_prompt
=cut
sub dest_type_prompt {
my ( $ui ) = @_;
my $default = undef;
my $is_current_value = undef;
## Use single-quotish HERE docs as the most robust form of quoting
## so we don't have to mess with escaping.
my $prompt = <<'END_PROMPT';
Destination SCM type
END_PROMPT
chomp $prompt;
my @valid_answers = (
[ 'cvs', 'cvs', 'dest_cvs_cvsroot_prompt',
sub {
my ( $ui, $answer, $answer_record ) = @_;
$ui->new_dest( $answer );
},
],
[ 'p4', 'p4', 'dest_p4_run_p4d_prompt',
sub {
my ( $ui, $answer, $answer_record ) = @_;
$ui->new_dest( $answer );
},
],
[ 'vss', 'vss', 'dest_vss_vssroot_prompt',
sub {
my ( $ui, $answer, $answer_record ) = @_;
$ui->new_dest( $answer );
},
],
);
my $description = <<'END_DESCRIPTION';
What type of repository are you copying revisions to?
END_DESCRIPTION
$default = $ui->dest && $ui->dest->repo_scheme;
$is_current_value = $ui->{EditMode} = 1 unless empty $default;
while (1) {
my ( $answer, $answer_record ) =
$ui->ask(
0,
$description,
0,
$prompt,
$prompt,
$default,
$is_current_value,
\@valid_answers
);
## Run handlers for this arc, redo question if exceptions generated
my $ok = eval {
$answer_record->[-1]->( $ui, $answer, $answer_record )
if defined $answer_record->[-1];
1;
};
unless ( $ok ) {
my $eval_error = $@;
if ( $eval_error =~ /^warning:/i ) {
## recoverable error, ask if user wants to accept value anyway?
my ( undef, $r ) = $ui->ask(
'error',
$eval_error,
1,
"Warning",
"Accept this value anyway",
"no",
0,
[
[ "yes", "yes", undef ],
[ "no", "no", undef ],
]
);
next unless $r->[0] eq "yes";
}
else {
## completely un-acceptable exception, re-ask question.
chomp $eval_error;
warn "\n\n $eval_error\n\n";
next;
}
}
## The next state
return $answer_record->[-2];
}
}
=item wrapup: Next step
Based on the information you have provided, VCP is now ready
to start converting revisions from the source repository to
the destination repository. Choose an option:
Valid answers ("answer (regexp) => next prompt"):
Save config file and run ('Save config file and run') => save_config_file
Save config file and exit ('Save config file and exit') => save_config_file
=cut
sub wrapup {
my ( $ui ) = @_;
my $default = undef;
my $is_current_value = undef;
## Use single-quotish HERE docs as the most robust form of quoting
## so we don't have to mess with escaping.
my $prompt = <<'END_PROMPT';
Next step
END_PROMPT
chomp $prompt;
my @valid_answers = (
[ 'Save config file and run', 'Save config file and run', 'save_config_file',
sub {
my ( $ui, $answer, $answer_record ) = @_;
$ui->{Run} = 1;
},
],
[ 'Save config file and exit', 'Save config file and exit', 'save_config_file',
undef,
],
);
my $description = <<'END_DESCRIPTION';
Based on the information you have provided, VCP is now ready
to start converting revisions from the source repository to
the destination repository. Choose an option:
END_DESCRIPTION
$default = "Save config file and run";
while (1) {
my ( $answer, $answer_record ) =
$ui->ask(
0,
$description,
0,
$prompt,
$prompt,
$default,
$is_current_value,
\@valid_answers
);
## Run handlers for this arc, redo question if exceptions generated
my $ok = eval {
$answer_record->[-1]->( $ui, $answer, $answer_record )
if defined $answer_record->[-1];
1;
};
unless ( $ok ) {
my $eval_error = $@;
if ( $eval_error =~ /^warning:/i ) {
## recoverable error, ask if user wants to accept value anyway?
my ( undef, $r ) = $ui->ask(
'error',
$eval_error,
1,
"Warning",
"Accept this value anyway",
"no",
0,
[
[ "yes", "yes", undef ],
[ "no", "no", undef ],
]
);
next unless $r->[0] eq "yes";
}
else {
## completely un-acceptable exception, re-ask question.
chomp $eval_error;
warn "\n\n $eval_error\n\n";
next;
}
}
## The next state
return $answer_record->[-2];
}
}
=item save_config_file: Config file name
Specify the name of the configuration file to which VCP saves
the conversion options you have specified.
Config file name (Config filename) [Default: AllVSS_to_MyP4D.vcp]?
(( after creation ))
To convert your repository, use VCP with this configuration file
by invoking VCP on the command line as follows:
vcp allvss_to_myp4d.vcp
Valid answers ("answer (regexp) => next prompt"):
Config filename (qr/./) => convert
=cut
sub save_config_file {
my ( $ui ) = @_;
my $default = undef;
my $is_current_value = undef;
## Use single-quotish HERE docs as the most robust form of quoting
## so we don't have to mess with escaping.
my $prompt = <<'END_PROMPT';
Config file name
END_PROMPT
chomp $prompt;
my @valid_answers = (
[ 'Config filename', qr/./, 'convert',
sub {
my ( $ui, $answer, $answer_record ) = @_;
$ui->{SaveAsConfigFileName} = $answer;
if ( -e $answer ) {
die "Warning: '$answer' exists but is a directory!\n"
if -d $answer;
die "Warning: '$answer' exists but is not a regular file!\n"
unless -f $answer;
die "Warning: '$answer' exists but is not writable!\n"
unless -w $answer;
die "Warning: '$answer' already exists!\n";
}
},
],
);
my $description = <<'END_DESCRIPTION';
Specify the name of the configuration file to which VCP saves
the conversion options you have specified.
Config file name (Config filename) [Default: AllVSS_to_MyP4D.vcp]?
(( after creation ))
To convert your repository, use VCP with this configuration file
by invoking VCP on the command line as follows:
vcp allvss_to_myp4d.vcp
END_DESCRIPTION
if ( ! empty $ui->{Filename} ) {
$default = $ui->{Filename};
$is_current_value = 1;
}
else {
$default = $ui->source->repo_id . "_to_" . $ui->dest->repo_id . ".vcp";
}
while (1) {
my ( $answer, $answer_record ) =
$ui->ask(
0,
$description,
0,
$prompt,
$prompt,
$default,
$is_current_value,
\@valid_answers
);
## Run handlers for this arc, redo question if exceptions generated
my $ok = eval {
$answer_record->[-1]->( $ui, $answer, $answer_record )
if defined $answer_record->[-1];
1;
};
unless ( $ok ) {
my $eval_error = $@;
if ( $eval_error =~ /^warning:/i ) {
## recoverable error, ask if user wants to accept value anyway?
my ( undef, $r ) = $ui->ask(
'error',
$eval_error,
1,
"Warning",
"Accept this value anyway",
"no",
0,
[
[ "yes", "yes", undef ],
[ "no", "no", undef ],
]
);
next unless $r->[0] eq "yes";
}
else {
## completely un-acceptable exception, re-ask question.
chomp $eval_error;
warn "\n\n $eval_error\n\n";
next;
}
}
## The next state
return $answer_record->[-2];
}
}
=item convert
Run VCP with the options entered
=cut
sub convert {
return undef;
}
=item dest_p4_run_p4d_prompt: Launch a p4d for the destination
If you would like to insert into an offline repository in a
local directory, vcp can launch a 'p4d' daemon for you in that
directory. It will use a random high numbered TCP port.
Valid answers ("answer (regexp) => next prompt"):
yes ('yes') => dest_p4_p4d_dir_prompt
no ('no') => dest_p4_host_prompt
=cut
sub dest_p4_run_p4d_prompt {
my ( $ui ) = @_;
my $default = undef;
my $is_current_value = undef;
## Use single-quotish HERE docs as the most robust form of quoting
## so we don't have to mess with escaping.
my $prompt = <<'END_PROMPT';
Launch a p4d for the destination
END_PROMPT
chomp $prompt;
my @valid_answers = (
[ 'yes', 'yes', 'dest_p4_p4d_dir_prompt',
sub {
my ( $ui, $answer, $answer_record ) = @_;
my $old = $ui->dest->{P4_RUN_P4D} ? 1 : 0;
$answer = 1;
$ui->dest->repo_server( undef )
if $ui->in_edit_mode and $old != $answer;
$ui->dest->{P4_RUN_P4D} = $answer;
},
],
[ 'no', 'no', 'dest_p4_host_prompt',
sub {
my ( $ui, $answer, $answer_record ) = @_;
my $old = $ui->dest->{P4_RUN_P4D} ? 1 : 0;
$answer = 0 ;
$ui->dest->repo_server( undef )
if $ui->in_edit_mode and $old != $answer;
$ui->dest->{P4_RUN_P4D} = $answer;
},
],
);
my $description = <<'END_DESCRIPTION';
If you would like to insert into an offline repository in a
local directory, vcp can launch a 'p4d' daemon for you in that
directory. It will use a random high numbered TCP port.
END_DESCRIPTION
if ( $ui->in_edit_mode ) {
$default = $ui->dest->{P4_RUN_P4D} ? "yes" : "no" ;
$is_current_value = 1;
}
else {
$default = "no";
}
while (1) {
my ( $answer, $answer_record ) =
$ui->ask(
0,
$description,
0,
$prompt,
$prompt,
$default,
$is_current_value,
\@valid_answers
);
## Run handlers for this arc, redo question if exceptions generated
my $ok = eval {
$answer_record->[-1]->( $ui, $answer, $answer_record )
if defined $answer_record->[-1];
1;
};
unless ( $ok ) {
my $eval_error = $@;
if ( $eval_error =~ /^warning:/i ) {
## recoverable error, ask if user wants to accept value anyway?
my ( undef, $r ) = $ui->ask(
'error',
$eval_error,
1,
"Warning",
"Accept this value anyway",
"no",
0,
[
[ "yes", "yes", undef ],
[ "no", "no", undef ],
]
);
next unless $r->[0] eq "yes";
}
else {
## completely un-acceptable exception, re-ask question.
chomp $eval_error;
warn "\n\n $eval_error\n\n";
next;
}
}
## The next state
return $answer_record->[-2];
}
}
=item dest_p4_p4d_dir_prompt: Destination P4ROOT
The directory of the destination repository, p4d will be
launched here.
Valid answers ("answer (regexp) => next prompt"):
(qr/./) => dest_p4_user_prompt
=cut
sub dest_p4_p4d_dir_prompt {
my ( $ui ) = @_;
my $default = undef;
my $is_current_value = undef;
## Use single-quotish HERE docs as the most robust form of quoting
## so we don't have to mess with escaping.
my $prompt = <<'END_PROMPT';
Destination P4ROOT
END_PROMPT
chomp $prompt;
my @valid_answers = (
[ '', qr/./, 'dest_p4_user_prompt',
sub {
my ( $ui, $answer, $answer_record ) = @_;
# will set repo_server
$ui->dest->ui_set_p4d_dir( $answer );
},
],
);
my $description = <<'END_DESCRIPTION';
The directory of the destination repository, p4d will be
launched here.
END_DESCRIPTION
if ( $ui->in_edit_mode ) {
$default = $ui->dest->repo_server ;
$is_current_value = 1;
}
while (1) {
my ( $answer, $answer_record ) =
$ui->ask(
0,
$description,
0,
$prompt,
$prompt,
$default,
$is_current_value,
\@valid_answers
);
## Run handlers for this arc, redo question if exceptions generated
my $ok = eval {
$answer_record->[-1]->( $ui, $answer, $answer_record )
if defined $answer_record->[-1];
1;
};
unless ( $ok ) {
my $eval_error = $@;
if ( $eval_error =~ /^warning:/i ) {
## recoverable error, ask if user wants to accept value anyway?
my ( undef, $r ) = $ui->ask(
'error',
$eval_error,
1,
"Warning",
"Accept this value anyway",
"no",
0,
[
[ "yes", "yes", undef ],
[ "no", "no", undef ],
]
);
next unless $r->[0] eq "yes";
}
else {
## completely un-acceptable exception, re-ask question.
chomp $eval_error;
warn "\n\n $eval_error\n\n";
next;
}
}
## The next state
return $answer_record->[-2];
}
}
=item dest_p4_host_prompt: Destination P4PORT
Specify the hostname/IP address and TCP port of the destination
Perforce server (p4d). The default value is the current P4PORT
environment variable as reported by 'p4 set', or "perforce:1666"
if P4PORT is unset.
Valid answers ("answer (regexp) => next prompt"):
perforce:1666 (qr/./) => dest_p4_user_prompt
=cut
sub dest_p4_host_prompt {
my ( $ui ) = @_;
my $default = undef;
my $is_current_value = undef;
## Use single-quotish HERE docs as the most robust form of quoting
## so we don't have to mess with escaping.
my $prompt = <<'END_PROMPT';
Destination P4PORT
END_PROMPT
chomp $prompt;
my @valid_answers = (
[ 'perforce:1666', qr/./, 'dest_p4_user_prompt',
sub {
my ( $ui, $answer, $answer_record ) = @_;
$ui->dest->repo_server( $answer );
},
],
);
my $description = <<'END_DESCRIPTION';
Specify the hostname/IP address and TCP port of the destination
Perforce server (p4d). The default value is the current P4PORT
environment variable as reported by 'p4 set', or "perforce:1666"
if P4PORT is unset.
END_DESCRIPTION
my $h = $ui->dest->p4_get_settings;
if ($ui->in_edit_mode) {
$default = $ui->dest->repo_server ;
$is_current_value = 1;
}
else {
$default = empty( $h->{P4HOST} ) ? "perforce:1666" : $h->{P4HOST} ;
}
while (1) {
my ( $answer, $answer_record ) =
$ui->ask(
0,
$description,
0,
$prompt,
$prompt,
$default,
$is_current_value,
\@valid_answers
);
## Run handlers for this arc, redo question if exceptions generated
my $ok = eval {
$answer_record->[-1]->( $ui, $answer, $answer_record )
if defined $answer_record->[-1];
1;
};
unless ( $ok ) {
my $eval_error = $@;
if ( $eval_error =~ /^warning:/i ) {
## recoverable error, ask if user wants to accept value anyway?
my ( undef, $r ) = $ui->ask(
'error',
$eval_error,
1,
"Warning",
"Accept this value anyway",
"no",
0,
[
[ "yes", "yes", undef ],
[ "no", "no", undef ],
]
);
next unless $r->[0] eq "yes";
}
else {
## completely un-acceptable exception, re-ask question.
chomp $eval_error;
warn "\n\n $eval_error\n\n";
next;
}
}
## The next state
return $answer_record->[-2];
}
}
=item dest_p4_user_prompt: Destination P4USER
Specify the username with which to connect to the destination
Perforce server (p4d).
If you are connecting to an existing Perforce server (p4d),
you must specify a P4USER with administrative or superuser
privileges.
If you are launching a new p4d for the destination repository,
you may specify any name for P4USER, and this user will be
created for you on the destination repository.
The default value is the current P4USER environment variable
as reported by 'p4 set', or the current USER variable if P4USER
is unset.
Valid answers ("answer (regexp) => next prompt"):
(qr/./) => dest_p4_password_prompt
=cut
sub dest_p4_user_prompt {
my ( $ui ) = @_;
my $default = undef;
my $is_current_value = undef;
## Use single-quotish HERE docs as the most robust form of quoting
## so we don't have to mess with escaping.
my $prompt = <<'END_PROMPT';
Destination P4USER
END_PROMPT
chomp $prompt;
my @valid_answers = (
[ '', qr/./, 'dest_p4_password_prompt',
sub {
my ( $ui, $answer, $answer_record ) = @_;
$ui->dest->repo_user( $answer );
},
],
);
my $description = <<'END_DESCRIPTION';
Specify the username with which to connect to the destination
Perforce server (p4d).
If you are connecting to an existing Perforce server (p4d),
you must specify a P4USER with administrative or superuser
privileges.
If you are launching a new p4d for the destination repository,
you may specify any name for P4USER, and this user will be
created for you on the destination repository.
The default value is the current P4USER environment variable
as reported by 'p4 set', or the current USER variable if P4USER
is unset.
END_DESCRIPTION
if ( $ui->in_edit_mode ) {
$default = $ui->dest->repo_user;
$is_current_value = 1;
}
else {
my $h = $ui->dest->p4_get_settings;
$default = empty( $h->{P4USER} )
? ( empty( $ENV{USER} ) ? undef : $ENV{USER})
: $h->{P4USER} ;
}
while (1) {
my ( $answer, $answer_record ) =
$ui->ask(
0,
$description,
0,
$prompt,
$prompt,
$default,
$is_current_value,
\@valid_answers
);
## Run handlers for this arc, redo question if exceptions generated
my $ok = eval {
$answer_record->[-1]->( $ui, $answer, $answer_record )
if defined $answer_record->[-1];
1;
};
unless ( $ok ) {
my $eval_error = $@;
if ( $eval_error =~ /^warning:/i ) {
## recoverable error, ask if user wants to accept value anyway?
my ( undef, $r ) = $ui->ask(
'error',
$eval_error,
1,
"Warning",
"Accept this value anyway",
"no",
0,
[
[ "yes", "yes", undef ],
[ "no", "no", undef ],
]
);
next unless $r->[0] eq "yes";
}
else {
## completely un-acceptable exception, re-ask question.
chomp $eval_error;
warn "\n\n $eval_error\n\n";
next;
}
}
## The next state
return $answer_record->[-2];
}
}
=item dest_p4_password_prompt: Destination P4PASSWD
Specify the password with which to connect to the destination
Perforce server (p4d).
If you are connecting to an existing Perforce server (p4d), you
must specify the correct password for the P4USER you are using
to connect to the server. (If the P4USER you are using has no
password, enter any non-null P4PASSWD.)
If you are launching a new p4d for the destination repository,
enter any non-null password here.)
WARNING: Entering a password here causes the password to be echoed
in plain text to the terminal.
NOTE: When running VCP, if you have a P4PASSWD set in environment
or in the registry (on Win32, that is), it will be used by
the p4 command if you don't enter a password here.
Valid answers ("answer (regexp) => next prompt"):
=> dest_p4_filespec_prompt
=cut
sub dest_p4_password_prompt {
my ( $ui ) = @_;
my $default = undef;
my $is_current_value = undef;
## Use single-quotish HERE docs as the most robust form of quoting
## so we don't have to mess with escaping.
my $prompt = <<'END_PROMPT';
Destination P4PASSWD
END_PROMPT
chomp $prompt;
my @valid_answers = (
[ '', qr/^/, 'dest_p4_filespec_prompt',
sub {
my ( $ui, $answer, $answer_record ) = @_;
if ( $answer =~ /\A"?NONE"?\z/i ) {
$answer = undef;
print "\nP4PASSWD will not be set.\n";
}
elsif ( $answer eq "** current password **" ) {
$answer = $ui->dest->repo_password;
}
elsif ( $answer eq "** current P4PASSWD **" ) {
$answer = $ui->dest->p4_get_settings->{P4PASSWD};
}
$ui->dest->repo_password( $answer );
},
],
);
my $description = <<'END_DESCRIPTION';
Specify the password with which to connect to the destination
Perforce server (p4d).
If you are connecting to an existing Perforce server (p4d), you
must specify the correct password for the P4USER you are using
to connect to the server. (If the P4USER you are using has no
password, enter any non-null P4PASSWD.)
If you are launching a new p4d for the destination repository,
enter any non-null password here.)
WARNING: Entering a password here causes the password to be echoed
in plain text to the terminal.
NOTE: When running VCP, if you have a P4PASSWD set in environment
or in the registry (on Win32, that is), it will be used by
the p4 command if you don't enter a password here.
END_DESCRIPTION
if ($ui->in_edit_mode ) {
unless ( empty $ui->dest->repo_password ) {
$description .= "Enter \"NONE\" to use no password.\n\n";
$default = "** current password **";
$is_current_value = 1;
}
}
else {
my $h = $ui->dest->p4_get_settings;
unless ( empty $h->{P4PASSWD} ) {
$description .= "Enter \"NONE\" to use no password.\n\n";
$default = "** current P4PASSWD **"
}
}
while (1) {
my ( $answer, $answer_record ) =
$ui->ask(
0,
$description,
0,
$prompt,
$prompt,
$default,
$is_current_value,
\@valid_answers
);
## Run handlers for this arc, redo question if exceptions generated
my $ok = eval {
$answer_record->[-1]->( $ui, $answer, $answer_record )
if defined $answer_record->[-1];
1;
};
unless ( $ok ) {
my $eval_error = $@;
if ( $eval_error =~ /^warning:/i ) {
## recoverable error, ask if user wants to accept value anyway?
my ( undef, $r ) = $ui->ask(
'error',
$eval_error,
1,
"Warning",
"Accept this value anyway",
"no",
0,
[
[ "yes", "yes", undef ],
[ "no", "no", undef ],
]
);
next unless $r->[0] eq "yes";
}
else {
## completely un-acceptable exception, re-ask question.
chomp $eval_error;
warn "\n\n $eval_error\n\n";
next;
}
}
## The next state
return $answer_record->[-2];
}
}
=item dest_p4_filespec_prompt: Destination File Specification
For Perforce destination servers, specify the path in Perforce
depot syntax. Paths in Perforce depot syntax begin with "//",
and are followed by a depot name (by default, "depot"). Do not
use local filesystem specifications, client specifications, or
label specifications.
Specify the location on the destination server to place the
converted file revisions.
Valid answers ("answer (regexp) => next prompt"):
//depot/directory-path/... (qr#\A//#) => wrapup
=cut
sub dest_p4_filespec_prompt {
my ( $ui ) = @_;
my $default = undef;
my $is_current_value = undef;
## Use single-quotish HERE docs as the most robust form of quoting
## so we don't have to mess with escaping.
my $prompt = <<'END_PROMPT';
Destination File Specification
END_PROMPT
chomp $prompt;
my @valid_answers = (
[ '//depot/directory-path/...', qr#\A//#, 'wrapup',
sub {
my ( $ui, $answer, $answer_record ) = @_;
$ui->dest->repo_filespec( $answer );
},
],
);
my $description = <<'END_DESCRIPTION';
For Perforce destination servers, specify the path in Perforce
depot syntax. Paths in Perforce depot syntax begin with "//",
and are followed by a depot name (by default, "depot"). Do not
use local filesystem specifications, client specifications, or
label specifications.
Specify the location on the destination server to place the
converted file revisions.
END_DESCRIPTION
if ( $ui->in_edit_mode ) {
$default = $ui->dest->repo_filespec;
$is_current_value = 1;
}
while (1) {
my ( $answer, $answer_record ) =
$ui->ask(
0,
$description,
0,
$prompt,
$prompt,
$default,
$is_current_value,
\@valid_answers
);
## Run handlers for this arc, redo question if exceptions generated
my $ok = eval {
$answer_record->[-1]->( $ui, $answer, $answer_record )
if defined $answer_record->[-1];
1;
};
unless ( $ok ) {
my $eval_error = $@;
if ( $eval_error =~ /^warning:/i ) {
## recoverable error, ask if user wants to accept value anyway?
my ( undef, $r ) = $ui->ask(
'error',
$eval_error,
1,
"Warning",
"Accept this value anyway",
"no",
0,
[
[ "yes", "yes", undef ],
[ "no", "no", undef ],
]
);
next unless $r->[0] eq "yes";
}
else {
## completely un-acceptable exception, re-ask question.
chomp $eval_error;
warn "\n\n $eval_error\n\n";
next;
}
}
## The next state
return $answer_record->[-2];
}
}
=item dest_cvs_cvsroot_prompt: Destination CVSROOT
Specifies the destination CVS repository location and protocol.
Defaults to the CVSROOT environment variable. If this is a
local directory, VCP can initialize it for you.
Valid answers ("answer (regexp) => next prompt"):
(qr/./) => dest_cvs_filespec_prompt
=cut
sub dest_cvs_cvsroot_prompt {
my ( $ui ) = @_;
my $default = undef;
my $is_current_value = undef;
## Use single-quotish HERE docs as the most robust form of quoting
## so we don't have to mess with escaping.
my $prompt = <<'END_PROMPT';
Destination CVSROOT
END_PROMPT
chomp $prompt;
my @valid_answers = (
[ '', qr/./, 'dest_cvs_filespec_prompt',
sub {
my ( $ui, $answer, $answer_record ) = @_;
$ui->dest->repo_server( $answer )
unless empty $answer;
},
],
);
my $description = <<'END_DESCRIPTION';
Specifies the destination CVS repository location and protocol.
Defaults to the CVSROOT environment variable. If this is a
local directory, VCP can initialize it for you.
END_DESCRIPTION
if ( $ui->in_edit_mode ) {
$default = $ui->dest->repo_server;
$is_current_value = 1;
}
else {
$default = empty ( $ENV{CVSROOT} ) ? undef : $ENV{CVSROOT};
}
while (1) {
my ( $answer, $answer_record ) =
$ui->ask(
0,
$description,
0,
$prompt,
$prompt,
$default,
$is_current_value,
\@valid_answers
);
## Run handlers for this arc, redo question if exceptions generated
my $ok = eval {
$answer_record->[-1]->( $ui, $answer, $answer_record )
if defined $answer_record->[-1];
1;
};
unless ( $ok ) {
my $eval_error = $@;
if ( $eval_error =~ /^warning:/i ) {
## recoverable error, ask if user wants to accept value anyway?
my ( undef, $r ) = $ui->ask(
'error',
$eval_error,
1,
"Warning",
"Accept this value anyway",
"no",
0,
[
[ "yes", "yes", undef ],
[ "no", "no", undef ],
]
);
next unless $r->[0] eq "yes";
}
else {
## completely un-acceptable exception, re-ask question.
chomp $eval_error;
warn "\n\n $eval_error\n\n";
next;
}
}
## The next state
return $answer_record->[-2];
}
}
=item dest_cvs_filespec_prompt: Destination CVS filespec
Where to copy revisions to in the destination specified by
CVSROOT. This must start with a CVS module name and may be in a
subdirectory of the result:
module/...
module/path/to/directory/...
module/path/to/file
For directories, this should contain a trailing "..." wildcard,
like "module/b/..." to indicate that the path is a directory.
Valid answers ("answer (regexp) => next prompt"):
module/filepath/... (qr/./) => dest_cvs_init_cvsroot_prompt
=cut
sub dest_cvs_filespec_prompt {
my ( $ui ) = @_;
my $default = undef;
my $is_current_value = undef;
## Use single-quotish HERE docs as the most robust form of quoting
## so we don't have to mess with escaping.
my $prompt = <<'END_PROMPT';
Destination CVS filespec
END_PROMPT
chomp $prompt;
my @valid_answers = (
[ 'module/filepath/...', qr/./, 'dest_cvs_init_cvsroot_prompt',
sub {
my ( $ui, $answer, $answer_record ) = @_;
$ui->dest->repo_filespec( $answer );
},
],
);
my $description = <<'END_DESCRIPTION';
Where to copy revisions to in the destination specified by
CVSROOT. This must start with a CVS module name and may be in a
subdirectory of the result:
module/...
module/path/to/directory/...
module/path/to/file
For directories, this should contain a trailing "..." wildcard,
like "module/b/..." to indicate that the path is a directory.
END_DESCRIPTION
if ( $ui->in_edit_mode ) {
$default = $ui->dest->repo_filespec;
$is_current_value = 1;
}
while (1) {
my ( $answer, $answer_record ) =
$ui->ask(
0,
$description,
0,
$prompt,
$prompt,
$default,
$is_current_value,
\@valid_answers
);
## Run handlers for this arc, redo question if exceptions generated
my $ok = eval {
$answer_record->[-1]->( $ui, $answer, $answer_record )
if defined $answer_record->[-1];
1;
};
unless ( $ok ) {
my $eval_error = $@;
if ( $eval_error =~ /^warning:/i ) {
## recoverable error, ask if user wants to accept value anyway?
my ( undef, $r ) = $ui->ask(
'error',
$eval_error,
1,
"Warning",
"Accept this value anyway",
"no",
0,
[
[ "yes", "yes", undef ],
[ "no", "no", undef ],
]
);
next unless $r->[0] eq "yes";
}
else {
## completely un-acceptable exception, re-ask question.
chomp $eval_error;
warn "\n\n $eval_error\n\n";
next;
}
}
## The next state
return $answer_record->[-2];
}
}
=item dest_cvs_init_cvsroot_prompt: 'cvs init' the destination CVSROOT
If the destination CVSROOT is a local directory, should VCP
initialize a cvs repository in it?
Valid answers ("answer (regexp) => next prompt"):
yes ('yes') => wrapup
no ('no') => wrapup
=cut
sub dest_cvs_init_cvsroot_prompt {
my ( $ui ) = @_;
my $default = undef;
my $is_current_value = undef;
## Use single-quotish HERE docs as the most robust form of quoting
## so we don't have to mess with escaping.
my $prompt = <<'END_PROMPT';
'cvs init' the destination CVSROOT
END_PROMPT
chomp $prompt;
my @valid_answers = (
[ 'yes', 'yes', 'wrapup',
sub {
my ( $ui, $answer, $answer_record ) = @_;
$ui->dest->{CVS_INIT_CVSROOT} = 1;
},
],
[ 'no', 'no', 'wrapup',
sub {
my ( $ui, $answer, $answer_record ) = @_;
$ui->dest->{CVS_INIT_CVSROOT} = 0;
},
],
);
my $description = <<'END_DESCRIPTION';
If the destination CVSROOT is a local directory, should VCP
initialize a cvs repository in it?
END_DESCRIPTION
if ( $ui->in_edit_mode ) {
$default = $ui->dest->{CVS_INIT_CVSROOT} ? "yes" : "no" ;
$is_current_value = 1;
}
else {
$default = "no";
}
while (1) {
my ( $answer, $answer_record ) =
$ui->ask(
0,
$description,
0,
$prompt,
$prompt,
$default,
$is_current_value,
\@valid_answers
);
## Run handlers for this arc, redo question if exceptions generated
my $ok = eval {
$answer_record->[-1]->( $ui, $answer, $answer_record )
if defined $answer_record->[-1];
1;
};
unless ( $ok ) {
my $eval_error = $@;
if ( $eval_error =~ /^warning:/i ) {
## recoverable error, ask if user wants to accept value anyway?
my ( undef, $r ) = $ui->ask(
'error',
$eval_error,
1,
"Warning",
"Accept this value anyway",
"no",
0,
[
[ "yes", "yes", undef ],
[ "no", "no", undef ],
]
);
next unless $r->[0] eq "yes";
}
else {
## completely un-acceptable exception, re-ask question.
chomp $eval_error;
warn "\n\n $eval_error\n\n";
next;
}
}
## The next state
return $answer_record->[-2];
}
}
=item dest_vss_vssroot_prompt: Destination SSDIR
The directory that will contain the srcsafe.ini file for the
destination repostiory.
Valid answers ("answer (regexp) => next prompt"):
(qr/./) => dest_vss_user_prompt
=cut
sub dest_vss_vssroot_prompt {
my ( $ui ) = @_;
my $default = undef;
my $is_current_value = undef;
## Use single-quotish HERE docs as the most robust form of quoting
## so we don't have to mess with escaping.
my $prompt = <<'END_PROMPT';
Destination SSDIR
END_PROMPT
chomp $prompt;
my @valid_answers = (
[ '', qr/./, 'dest_vss_user_prompt',
sub {
my ( $ui, $answer, $answer_record ) = @_;
$ui->dest->repo_server( $answer )
unless empty $answer;
},
],
);
my $description = <<'END_DESCRIPTION';
The directory that will contain the srcsafe.ini file for the
destination repostiory.
END_DESCRIPTION
if ( $ui->in_edit_mode ) {
$default = $ui->dest->repo_server;
$is_current_value = 1;
}
while (1) {
my ( $answer, $answer_record ) =
$ui->ask(
0,
$description,
0,
$prompt,
$prompt,
$default,
$is_current_value,
\@valid_answers
);
## Run handlers for this arc, redo question if exceptions generated
my $ok = eval {
$answer_record->[-1]->( $ui, $answer, $answer_record )
if defined $answer_record->[-1];
1;
};
unless ( $ok ) {
my $eval_error = $@;
if ( $eval_error =~ /^warning:/i ) {
## recoverable error, ask if user wants to accept value anyway?
my ( undef, $r ) = $ui->ask(
'error',
$eval_error,
1,
"Warning",
"Accept this value anyway",
"no",
0,
[
[ "yes", "yes", undef ],
[ "no", "no", undef ],
]
);
next unless $r->[0] eq "yes";
}
else {
## completely un-acceptable exception, re-ask question.
chomp $eval_error;
warn "\n\n $eval_error\n\n";
next;
}
}
## The next state
return $answer_record->[-2];
}
}
=item dest_vss_user_prompt: Destination SSUSER
Enter the SSUSER value needed to access the destination server. Defaults to
the current environment's SSUSER or 'Admin'.
Valid answers ("answer (regexp) => next prompt"):
(qr/./) => dest_vss_password_prompt
=cut
sub dest_vss_user_prompt {
my ( $ui ) = @_;
my $default = undef;
my $is_current_value = undef;
## Use single-quotish HERE docs as the most robust form of quoting
## so we don't have to mess with escaping.
my $prompt = <<'END_PROMPT';
Destination SSUSER
END_PROMPT
chomp $prompt;
my @valid_answers = (
[ '', qr/./, 'dest_vss_password_prompt',
sub {
my ( $ui, $answer, $answer_record ) = @_;
$ui->dest->repo_user( $answer )
unless empty $answer;
},
],
);
my $description = <<'END_DESCRIPTION';
Enter the SSUSER value needed to access the destination server. Defaults to
the current environment's SSUSER or 'Admin'.
END_DESCRIPTION
if ( $ui->in_edit_mode ) {
$default = $ui->dest->repo_user;
$is_current_value = 1;
}
else {
$default = empty( $ENV{SSUSER} ) ? "Admin" : $ENV{SSUSER} ;
}
while (1) {
my ( $answer, $answer_record ) =
$ui->ask(
0,
$description,
0,
$prompt,
$prompt,
$default,
$is_current_value,
\@valid_answers
);
## Run handlers for this arc, redo question if exceptions generated
my $ok = eval {
$answer_record->[-1]->( $ui, $answer, $answer_record )
if defined $answer_record->[-1];
1;
};
unless ( $ok ) {
my $eval_error = $@;
if ( $eval_error =~ /^warning:/i ) {
## recoverable error, ask if user wants to accept value anyway?
my ( undef, $r ) = $ui->ask(
'error',
$eval_error,
1,
"Warning",
"Accept this value anyway",
"no",
0,
[
[ "yes", "yes", undef ],
[ "no", "no", undef ],
]
);
next unless $r->[0] eq "yes";
}
else {
## completely un-acceptable exception, re-ask question.
chomp $eval_error;
warn "\n\n $eval_error\n\n";
next;
}
}
## The next state
return $answer_record->[-2];
}
}
=item dest_vss_password_prompt: Destination SSPWD
If a password (SSPWD) is needed to access the destination server, enter
it here. Defaults to the current SSPWD if one is set.
WARNING: entering a password will cause it to be echoed in plain text
to the terminal.
Valid answers ("answer (regexp) => next prompt"):
=> dest_vss_filespec_prompt
=cut
sub dest_vss_password_prompt {
my ( $ui ) = @_;
my $default = undef;
my $is_current_value = undef;
## Use single-quotish HERE docs as the most robust form of quoting
## so we don't have to mess with escaping.
my $prompt = <<'END_PROMPT';
Destination SSPWD
END_PROMPT
chomp $prompt;
my @valid_answers = (
[ '', qr/^/, 'dest_vss_filespec_prompt',
sub {
my ( $ui, $answer, $answer_record ) = @_;
if ( $ui->in_edit_mode ) {
$answer = $ui->dest->repo_password
if $answer eq "** current password **";
}
else {
$answer = $ENV{SSPWD}
if $answer eq "** current SSPWD **";
}
$ui->dest->repo_password( $answer )
unless empty $answer;
},
],
);
my $description = <<'END_DESCRIPTION';
If a password (SSPWD) is needed to access the destination server, enter
it here. Defaults to the current SSPWD if one is set.
WARNING: entering a password will cause it to be echoed in plain text
to the terminal.
END_DESCRIPTION
if ( $ui->in_edit_mode ) {
unless ( empty $ui->dest->repo_password ) {
$default = "** current password **";
$is_current_value = 1;
}
}
else {
$default = "** current SSPWD **"
unless empty $ENV{SSPWD};
}
while (1) {
my ( $answer, $answer_record ) =
$ui->ask(
0,
$description,
0,
$prompt,
$prompt,
$default,
$is_current_value,
\@valid_answers
);
## Run handlers for this arc, redo question if exceptions generated
my $ok = eval {
$answer_record->[-1]->( $ui, $answer, $answer_record )
if defined $answer_record->[-1];
1;
};
unless ( $ok ) {
my $eval_error = $@;
if ( $eval_error =~ /^warning:/i ) {
## recoverable error, ask if user wants to accept value anyway?
my ( undef, $r ) = $ui->ask(
'error',
$eval_error,
1,
"Warning",
"Accept this value anyway",
"no",
0,
[
[ "yes", "yes", undef ],
[ "no", "no", undef ],
]
);
next unless $r->[0] eq "yes";
}
else {
## completely un-acceptable exception, re-ask question.
chomp $eval_error;
warn "\n\n $eval_error\n\n";
next;
}
}
## The next state
return $answer_record->[-2];
}
}
=item dest_vss_filespec_prompt: Destination VSS filespec
Enter the vss filespec of the destination directory, with or
without a leading "$/" or "/" (all names are taken as
absolute).
Valid answers ("answer (regexp) => next prompt"):
(qr/./) => dest_vss_mkss_prompt
=cut
sub dest_vss_filespec_prompt {
my ( $ui ) = @_;
my $default = undef;
my $is_current_value = undef;
## Use single-quotish HERE docs as the most robust form of quoting
## so we don't have to mess with escaping.
my $prompt = <<'END_PROMPT';
Destination VSS filespec
END_PROMPT
chomp $prompt;
my @valid_answers = (
[ '', qr/./, 'dest_vss_mkss_prompt',
sub {
my ( $ui, $answer, $answer_record ) = @_;
$ui->dest->repo_filespec( $answer );
},
],
);
my $description = <<'END_DESCRIPTION';
Enter the vss filespec of the destination directory, with or
without a leading "$/" or "/" (all names are taken as
absolute).
END_DESCRIPTION
if ( $ui->in_edit_mode ) {
$default = $ui->dest->repo_filespec ;
$is_current_value = 1;
}
while (1) {
my ( $answer, $answer_record ) =
$ui->ask(
0,
$description,
0,
$prompt,
$prompt,
$default,
$is_current_value,
\@valid_answers
);
## Run handlers for this arc, redo question if exceptions generated
my $ok = eval {
$answer_record->[-1]->( $ui, $answer, $answer_record )
if defined $answer_record->[-1];
1;
};
unless ( $ok ) {
my $eval_error = $@;
if ( $eval_error =~ /^warning:/i ) {
## recoverable error, ask if user wants to accept value anyway?
my ( undef, $r ) = $ui->ask(
'error',
$eval_error,
1,
"Warning",
"Accept this value anyway",
"no",
0,
[
[ "yes", "yes", undef ],
[ "no", "no", undef ],
]
);
next unless $r->[0] eq "yes";
}
else {
## completely un-acceptable exception, re-ask question.
chomp $eval_error;
warn "\n\n $eval_error\n\n";
next;
}
}
## The next state
return $answer_record->[-2];
}
}
=item dest_vss_mkss_prompt: 'mkss' the destination SSDIR
If the destination SSDIR is a local directory, should VCP
use mkss to initialize a vss repository in it?
Valid answers ("answer (regexp) => next prompt"):
yes ('yes') => wrapup
no ('no') => wrapup
=cut
sub dest_vss_mkss_prompt {
my ( $ui ) = @_;
my $default = undef;
my $is_current_value = undef;
## Use single-quotish HERE docs as the most robust form of quoting
## so we don't have to mess with escaping.
my $prompt = <<'END_PROMPT';
'mkss' the destination SSDIR
END_PROMPT
chomp $prompt;
my @valid_answers = (
[ 'yes', 'yes', 'wrapup',
sub {
my ( $ui, $answer, $answer_record ) = @_;
$ui->dest->{VSS_MKSS_SSDIR} = 1 ;
},
],
[ 'no', 'no', 'wrapup',
sub {
my ( $ui, $answer, $answer_record ) = @_;
$ui->dest->{VSS_MKSS_SSDIR} = 0 ;
},
],
);
my $description = <<'END_DESCRIPTION';
If the destination SSDIR is a local directory, should VCP
use mkss to initialize a vss repository in it?
END_DESCRIPTION
if ($ui->in_edit_mode ) {
$default = $ui->dest->{VSS_MKSS_SSDIR} ? "yes" : "no" ;
$is_current_value = 1;
}
else {
$default = "no";
}
while (1) {
my ( $answer, $answer_record ) =
$ui->ask(
0,
$description,
0,
$prompt,
$prompt,
$default,
$is_current_value,
\@valid_answers
);
## Run handlers for this arc, redo question if exceptions generated
my $ok = eval {
$answer_record->[-1]->( $ui, $answer, $answer_record )
if defined $answer_record->[-1];
1;
};
unless ( $ok ) {
my $eval_error = $@;
if ( $eval_error =~ /^warning:/i ) {
## recoverable error, ask if user wants to accept value anyway?
my ( undef, $r ) = $ui->ask(
'error',
$eval_error,
1,
"Warning",
"Accept this value anyway",
"no",
0,
[
[ "yes", "yes", undef ],
[ "no", "no", undef ],
]
);
next unless $r->[0] eq "yes";
}
else {
## completely un-acceptable exception, re-ask question.
chomp $eval_error;
warn "\n\n $eval_error\n\n";
next;
}
}
## The next state
return $answer_record->[-2];
}
}
=item source_p4_run_p4d_prompt: Launch a p4d for the source
In order to convert to a Perforce (p4) destination repository, you
must have a Perforce server (p4d) running and accessible to VCP.
If you do not have a p4d running, select "yes". VCP will
automatically start a p4d daemon listening on a random high-
numbered TCP port. This daemon will create an offline Perforce
repository in a local directory that you specify.
If you already have a p4d server running, and you want to store
your converted repository in this server, select "no". You will
be prompted for the P4PORT of the server.
Launch a new p4d for the destination repository?
Valid answers ("answer (regexp) => next prompt"):
no ('no') => source_p4_host_prompt
yes ('yes') => source_p4_p4d_dir_prompt
=cut
sub source_p4_run_p4d_prompt {
my ( $ui ) = @_;
my $default = undef;
my $is_current_value = undef;
## Use single-quotish HERE docs as the most robust form of quoting
## so we don't have to mess with escaping.
my $prompt = <<'END_PROMPT';
Launch a p4d for the source
END_PROMPT
chomp $prompt;
my @valid_answers = (
[ 'no', 'no', 'source_p4_host_prompt',
sub {
my ( $ui, $answer, $answer_record ) = @_;
my $old = $ui->source->{P4_RUN_P4D} ? 1 : 0;
$answer = 0;
$ui->source->repo_server( undef )
if $ui->in_edit_mode and $old != $answer;
$ui->source->{P4_RUN_P4D} = $answer;
},
],
[ 'yes', 'yes', 'source_p4_p4d_dir_prompt',
sub {
my ( $ui, $answer, $answer_record ) = @_;
my $old = $ui->source->{P4_RUN_P4D} ? 1 : 0;
$answer = 1;
$ui->source->repo_server( undef )
if $ui->in_edit_mode and $old != $answer;
$ui->source->{P4_RUN_P4D} = $answer;
},
],
);
my $description = <<'END_DESCRIPTION';
In order to convert to a Perforce (p4) destination repository, you
must have a Perforce server (p4d) running and accessible to VCP.
If you do not have a p4d running, select "yes". VCP will
automatically start a p4d daemon listening on a random high-
numbered TCP port. This daemon will create an offline Perforce
repository in a local directory that you specify.
If you already have a p4d server running, and you want to store
your converted repository in this server, select "no". You will
be prompted for the P4PORT of the server.
Launch a new p4d for the destination repository?
END_DESCRIPTION
if ( $ui->in_edit_mode ) {
$default = $ui->source->{P4_RUN_P4D} ? "yes" : "no" ;
$is_current_value = 1;
}
else {
$default = "no";
}
while (1) {
my ( $answer, $answer_record ) =
$ui->ask(
0,
$description,
0,
$prompt,
$prompt,
$default,
$is_current_value,
\@valid_answers
);
## Run handlers for this arc, redo question if exceptions generated
my $ok = eval {
$answer_record->[-1]->( $ui, $answer, $answer_record )
if defined $answer_record->[-1];
1;
};
unless ( $ok ) {
my $eval_error = $@;
if ( $eval_error =~ /^warning:/i ) {
## recoverable error, ask if user wants to accept value anyway?
my ( undef, $r ) = $ui->ask(
'error',
$eval_error,
1,
"Warning",
"Accept this value anyway",
"no",
0,
[
[ "yes", "yes", undef ],
[ "no", "no", undef ],
]
);
next unless $r->[0] eq "yes";
}
else {
## completely un-acceptable exception, re-ask question.
chomp $eval_error;
warn "\n\n $eval_error\n\n";
next;
}
}
## The next state
return $answer_record->[-2];
}
}
=item source_p4_p4d_dir_prompt: Source P4ROOT
The directory of the source repository. The source p4d will be
launched here.
Valid answers ("answer (regexp) => next prompt"):
(qr/./) => source_p4_user_prompt
=cut
sub source_p4_p4d_dir_prompt {
my ( $ui ) = @_;
my $default = undef;
my $is_current_value = undef;
## Use single-quotish HERE docs as the most robust form of quoting
## so we don't have to mess with escaping.
my $prompt = <<'END_PROMPT';
Source P4ROOT
END_PROMPT
chomp $prompt;
my @valid_answers = (
[ '', qr/./, 'source_p4_user_prompt',
sub {
my ( $ui, $answer, $answer_record ) = @_;
# will set repo_server
$ui->source->ui_set_p4d_dir( $answer ) ;
},
],
);
my $description = <<'END_DESCRIPTION';
The directory of the source repository. The source p4d will be
launched here.
END_DESCRIPTION
if ( $ui->in_edit_mode ) {
$default = $ui->source->repo_server ;
$is_current_value = 1;
}
while (1) {
my ( $answer, $answer_record ) =
$ui->ask(
0,
$description,
0,
$prompt,
$prompt,
$default,
$is_current_value,
\@valid_answers
);
## Run handlers for this arc, redo question if exceptions generated
my $ok = eval {
$answer_record->[-1]->( $ui, $answer, $answer_record )
if defined $answer_record->[-1];
1;
};
unless ( $ok ) {
my $eval_error = $@;
if ( $eval_error =~ /^warning:/i ) {
## recoverable error, ask if user wants to accept value anyway?
my ( undef, $r ) = $ui->ask(
'error',
$eval_error,
1,
"Warning",
"Accept this value anyway",
"no",
0,
[
[ "yes", "yes", undef ],
[ "no", "no", undef ],
]
);
next unless $r->[0] eq "yes";
}
else {
## completely un-acceptable exception, re-ask question.
chomp $eval_error;
warn "\n\n $eval_error\n\n";
next;
}
}
## The next state
return $answer_record->[-2];
}
}
=item source_p4_host_prompt: Source P4PORT
Enter the name and port of the p4d to read from, separated by a colon.
Defaults to what is in config file, then the P4HOST environment variable if
set or "perforce:1666" if not.
Valid answers ("answer (regexp) => next prompt"):
perforce:1666 (qr/./) => source_p4_user_prompt
=cut
sub source_p4_host_prompt {
my ( $ui ) = @_;
my $default = undef;
my $is_current_value = undef;
## Use single-quotish HERE docs as the most robust form of quoting
## so we don't have to mess with escaping.
my $prompt = <<'END_PROMPT';
Source P4PORT
END_PROMPT
chomp $prompt;
my @valid_answers = (
[ 'perforce:1666', qr/./, 'source_p4_user_prompt',
sub {
my ( $ui, $answer, $answer_record ) = @_;
$ui->source->repo_server( $answer );
},
],
);
my $description = <<'END_DESCRIPTION';
Enter the name and port of the p4d to read from, separated by a colon.
Defaults to what is in config file, then the P4HOST environment variable if
set or "perforce:1666" if not.
END_DESCRIPTION
my $h = $ui->source->p4_get_settings;
if ( $ui->in_edit_mode ) {
$default = $ui->source->repo_server ;
$is_current_value = 1;
}
else {
$default = empty $h->{P4HOST} ? "perforce:1666" : $h->{P4HOST} ;
}
while (1) {
my ( $answer, $answer_record ) =
$ui->ask(
0,
$description,
0,
$prompt,
$prompt,
$default,
$is_current_value,
\@valid_answers
);
## Run handlers for this arc, redo question if exceptions generated
my $ok = eval {
$answer_record->[-1]->( $ui, $answer, $answer_record )
if defined $answer_record->[-1];
1;
};
unless ( $ok ) {
my $eval_error = $@;
if ( $eval_error =~ /^warning:/i ) {
## recoverable error, ask if user wants to accept value anyway?
my ( undef, $r ) = $ui->ask(
'error',
$eval_error,
1,
"Warning",
"Accept this value anyway",
"no",
0,
[
[ "yes", "yes", undef ],
[ "no", "no", undef ],
]
);
next unless $r->[0] eq "yes";
}
else {
## completely un-acceptable exception, re-ask question.
chomp $eval_error;
warn "\n\n $eval_error\n\n";
next;
}
}
## The next state
return $answer_record->[-2];
}
}
=item source_p4_user_prompt: Source P4USER
Enter the P4USER value needed to access the server. Defaults to
the P4USER value reported by p4 set (with a final default to the
USER environment variable if p4 set does not return anything).
Valid answers ("answer (regexp) => next prompt"):
(qr/./) => source_p4_password_prompt
=cut
sub source_p4_user_prompt {
my ( $ui ) = @_;
my $default = undef;
my $is_current_value = undef;
## Use single-quotish HERE docs as the most robust form of quoting
## so we don't have to mess with escaping.
my $prompt = <<'END_PROMPT';
Source P4USER
END_PROMPT
chomp $prompt;
my @valid_answers = (
[ '', qr/./, 'source_p4_password_prompt',
sub {
my ( $ui, $answer, $answer_record ) = @_;
$ui->source->repo_user( $answer );
},
],
);
my $description = <<'END_DESCRIPTION';
Enter the P4USER value needed to access the server. Defaults to
the P4USER value reported by p4 set (with a final default to the
USER environment variable if p4 set does not return anything).
END_DESCRIPTION
if ( $ui->in_edit_mode ) {
$default = $ui->source->repo_user;
$is_current_value = 1;
}
else {
my $h = $ui->source->p4_get_settings;
$default = empty $h->{P4USER}
? ( empty $ENV{USER} ? undef : $ENV{USER} )
: $h->{P4USER} ;
}
while (1) {
my ( $answer, $answer_record ) =
$ui->ask(
0,
$description,
0,
$prompt,
$prompt,
$default,
$is_current_value,
\@valid_answers
);
## Run handlers for this arc, redo question if exceptions generated
my $ok = eval {
$answer_record->[-1]->( $ui, $answer, $answer_record )
if defined $answer_record->[-1];
1;
};
unless ( $ok ) {
my $eval_error = $@;
if ( $eval_error =~ /^warning:/i ) {
## recoverable error, ask if user wants to accept value anyway?
my ( undef, $r ) = $ui->ask(
'error',
$eval_error,
1,
"Warning",
"Accept this value anyway",
"no",
0,
[
[ "yes", "yes", undef ],
[ "no", "no", undef ],
]
);
next unless $r->[0] eq "yes";
}
else {
## completely un-acceptable exception, re-ask question.
chomp $eval_error;
warn "\n\n $eval_error\n\n";
next;
}
}
## The next state
return $answer_record->[-2];
}
}
=item source_p4_password_prompt: Source P4PASSWD
If a password (P4PASSWD) is needed to access the server, enter
it here. Defaults to the current P4PASSWD if one is set.
WARNING: entering a password will cause it to be echoed in
plain text to the terminal.
NOTE: When running VCP, if you have a P4PASSWD set in environment
or in the registry (on Win32, that is), it will be used by
the p4 command if you don't enter a password here.
Valid answers ("answer (regexp) => next prompt"):
=> source_p4_filespec_prompt
=cut
sub source_p4_password_prompt {
my ( $ui ) = @_;
my $default = undef;
my $is_current_value = undef;
## Use single-quotish HERE docs as the most robust form of quoting
## so we don't have to mess with escaping.
my $prompt = <<'END_PROMPT';
Source P4PASSWD
END_PROMPT
chomp $prompt;
my @valid_answers = (
[ '', qr/^/, 'source_p4_filespec_prompt',
sub {
my ( $ui, $answer, $answer_record ) = @_;
if ( $answer =~ /\A"?NONE"?\z/i ) {
$answer = undef;
print "\nP4PASSWD will not be set.\n";
}
elsif ( $answer eq "** current password **" ) {
$answer = $ui->source->repo_password;
}
elsif ( $answer eq "** current P4PASSWD **" ) {
$answer = $ui->source->p4_get_settings->{P4PASSWD};
}
$ui->source->repo_password( $answer );
},
],
);
my $description = <<'END_DESCRIPTION';
If a password (P4PASSWD) is needed to access the server, enter
it here. Defaults to the current P4PASSWD if one is set.
WARNING: entering a password will cause it to be echoed in
plain text to the terminal.
NOTE: When running VCP, if you have a P4PASSWD set in environment
or in the registry (on Win32, that is), it will be used by
the p4 command if you don't enter a password here.
END_DESCRIPTION
if ( $ui->in_edit_mode ) {
unless ( empty $ui->source->repo_password ) {
$description .= "Enter \"NONE\" to use no password.\n\n";
$default = "** current password **";
$is_current_value = 1;
}
}
else {
my $h = $ui->source->p4_get_settings;
unless ( empty $h->{P4PASSWD} ) {
$description .= "Enter \"NONE\" to use no password.\n\n";
$default = "** current P4PASSWD **"
}
}
while (1) {
my ( $answer, $answer_record ) =
$ui->ask(
0,
$description,
0,
$prompt,
$prompt,
$default,
$is_current_value,
\@valid_answers
);
## Run handlers for this arc, redo question if exceptions generated
my $ok = eval {
$answer_record->[-1]->( $ui, $answer, $answer_record )
if defined $answer_record->[-1];
1;
};
unless ( $ok ) {
my $eval_error = $@;
if ( $eval_error =~ /^warning:/i ) {
## recoverable error, ask if user wants to accept value anyway?
my ( undef, $r ) = $ui->ask(
'error',
$eval_error,
1,
"Warning",
"Accept this value anyway",
"no",
0,
[
[ "yes", "yes", undef ],
[ "no", "no", undef ],
]
);
next unless $r->[0] eq "yes";
}
else {
## completely un-acceptable exception, re-ask question.
chomp $eval_error;
warn "\n\n $eval_error\n\n";
next;
}
}
## The next state
return $answer_record->[-2];
}
}
=item source_p4_filespec_prompt: Source File specification
If you want to copy a portion of the source repository, enter a p4
filespec starting with the depot name. Do not enter any revision or
change number information.
Valid answers ("answer (regexp) => next prompt"):
//depot/directory-path/... (qr{\A//.+}) => dest_id_prompt
=cut
sub source_p4_filespec_prompt {
my ( $ui ) = @_;
my $default = undef;
my $is_current_value = undef;
## Use single-quotish HERE docs as the most robust form of quoting
## so we don't have to mess with escaping.
my $prompt = <<'END_PROMPT';
Source File specification
END_PROMPT
chomp $prompt;
my @valid_answers = (
[ '//depot/directory-path/...', qr{\A//.+}, 'dest_id_prompt',
sub {
my ( $ui, $answer, $answer_record ) = @_;
$ui->source->repo_filespec( $answer );
},
],
);
my $description = <<'END_DESCRIPTION';
If you want to copy a portion of the source repository, enter a p4
filespec starting with the depot name. Do not enter any revision or
change number information.
END_DESCRIPTION
if ( $ui->in_edit_mode ) {
$default = $ui->source->repo_filespec;
$is_current_value = 1;
}
while (1) {
my ( $answer, $answer_record ) =
$ui->ask(
0,
$description,
0,
$prompt,
$prompt,
$default,
$is_current_value,
\@valid_answers
);
## Run handlers for this arc, redo question if exceptions generated
my $ok = eval {
$answer_record->[-1]->( $ui, $answer, $answer_record )
if defined $answer_record->[-1];
1;
};
unless ( $ok ) {
my $eval_error = $@;
if ( $eval_error =~ /^warning:/i ) {
## recoverable error, ask if user wants to accept value anyway?
my ( undef, $r ) = $ui->ask(
'error',
$eval_error,
1,
"Warning",
"Accept this value anyway",
"no",
0,
[
[ "yes", "yes", undef ],
[ "no", "no", undef ],
]
);
next unless $r->[0] eq "yes";
}
else {
## completely un-acceptable exception, re-ask question.
chomp $eval_error;
warn "\n\n $eval_error\n\n";
next;
}
}
## The next state
return $answer_record->[-2];
}
}
=item source_cvs_cvsroot_prompt: Source CVSROOT
The CVSROOT to read revisions from. Defaults to the CVSROOT
environment variable.
Valid answers ("answer (regexp) => next prompt"):
cvsroot spec (qr/./) => source_cvs_filespec_prompt
=cut
sub source_cvs_cvsroot_prompt {
my ( $ui ) = @_;
my $default = undef;
my $is_current_value = undef;
## Use single-quotish HERE docs as the most robust form of quoting
## so we don't have to mess with escaping.
my $prompt = <<'END_PROMPT';
Source CVSROOT
END_PROMPT
chomp $prompt;
my @valid_answers = (
[ 'cvsroot spec', qr/./, 'source_cvs_filespec_prompt',
sub {
my ( $ui, $answer, $answer_record ) = @_;
$ui->source->repo_server( $answer )
unless empty $answer;
},
],
);
my $description = <<'END_DESCRIPTION';
The CVSROOT to read revisions from. Defaults to the CVSROOT
environment variable.
END_DESCRIPTION
if ( $ui->in_edit_mode ) {
$default = $ui->source->repo_server;
$is_current_value = 1;
}
else {
$default = empty( $ENV{CVSROOT} ) ? undef : $ENV{CVSROOT};
}
while (1) {
my ( $answer, $answer_record ) =
$ui->ask(
0,
$description,
0,
$prompt,
$prompt,
$default,
$is_current_value,
\@valid_answers
);
## Run handlers for this arc, redo question if exceptions generated
my $ok = eval {
$answer_record->[-1]->( $ui, $answer, $answer_record )
if defined $answer_record->[-1];
1;
};
unless ( $ok ) {
my $eval_error = $@;
if ( $eval_error =~ /^warning:/i ) {
## recoverable error, ask if user wants to accept value anyway?
my ( undef, $r ) = $ui->ask(
'error',
$eval_error,
1,
"Warning",
"Accept this value anyway",
"no",
0,
[
[ "yes", "yes", undef ],
[ "no", "no", undef ],
]
);
next unless $r->[0] eq "yes";
}
else {
## completely un-acceptable exception, re-ask question.
chomp $eval_error;
warn "\n\n $eval_error\n\n";
next;
}
}
## The next state
return $answer_record->[-2];
}
}
=item source_cvs_filespec_prompt: Source CVS filespec
Enter the cvs filespec of the file(s) to copy. This must start
with a CVS module name and end in a filename, directory
name, or "..." wildcard:
module/...
module/file
module/path/to/subdir/...
module/path/to/subdir/file
Valid answers ("answer (regexp) => next prompt"):
module/filepath/... (qr/./) => source_cvs_working_directory_prompt
=cut
sub source_cvs_filespec_prompt {
my ( $ui ) = @_;
my $default = undef;
my $is_current_value = undef;
## Use single-quotish HERE docs as the most robust form of quoting
## so we don't have to mess with escaping.
my $prompt = <<'END_PROMPT';
Source CVS filespec
END_PROMPT
chomp $prompt;
my @valid_answers = (
[ 'module/filepath/...', qr/./, 'source_cvs_working_directory_prompt',
sub {
my ( $ui, $answer, $answer_record ) = @_;
$ui->source->repo_filespec( $answer );
},
],
);
my $description = <<'END_DESCRIPTION';
Enter the cvs filespec of the file(s) to copy. This must start
with a CVS module name and end in a filename, directory
name, or "..." wildcard:
module/...
module/file
module/path/to/subdir/...
module/path/to/subdir/file
END_DESCRIPTION
if ( $ui->in_edit_mode ) {
$default = $ui->source->repo_filespec;
$is_current_value = 1;
}
while (1) {
my ( $answer, $answer_record ) =
$ui->ask(
0,
$description,
0,
$prompt,
$prompt,
$default,
$is_current_value,
\@valid_answers
);
## Run handlers for this arc, redo question if exceptions generated
my $ok = eval {
$answer_record->[-1]->( $ui, $answer, $answer_record )
if defined $answer_record->[-1];
1;
};
unless ( $ok ) {
my $eval_error = $@;
if ( $eval_error =~ /^warning:/i ) {
## recoverable error, ask if user wants to accept value anyway?
my ( undef, $r ) = $ui->ask(
'error',
$eval_error,
1,
"Warning",
"Accept this value anyway",
"no",
0,
[
[ "yes", "yes", undef ],
[ "no", "no", undef ],
]
);
next unless $r->[0] eq "yes";
}
else {
## completely un-acceptable exception, re-ask question.
chomp $eval_error;
warn "\n\n $eval_error\n\n";
next;
}
}
## The next state
return $answer_record->[-2];
}
}
=item source_cvs_working_directory_prompt: Source CVS working directory
Enter the CVS working directory (Optional). VCP::Source::cvs will cd
to this directory before calling cvs and won't initialize a CVS
workspace of its own. Leave blank to allow VCP to use a
temporary directory.
Valid answers ("answer (regexp) => next prompt"):
=> source_cvs_binary_checkout_prompt
=cut
sub source_cvs_working_directory_prompt {
my ( $ui ) = @_;
my $default = undef;
my $is_current_value = undef;
## Use single-quotish HERE docs as the most robust form of quoting
## so we don't have to mess with escaping.
my $prompt = <<'END_PROMPT';
Source CVS working directory
END_PROMPT
chomp $prompt;
my @valid_answers = (
[ '', qr/^/, 'source_cvs_binary_checkout_prompt',
sub {
my ( $ui, $answer, $answer_record ) = @_;
$ui->source->ui_set_cvs_work_dir( $answer )
unless empty $answer;
},
],
);
my $description = <<'END_DESCRIPTION';
Enter the CVS working directory (Optional). VCP::Source::cvs will cd
to this directory before calling cvs and won't initialize a CVS
workspace of its own. Leave blank to allow VCP to use a
temporary directory.
END_DESCRIPTION
if ( $ui->in_edit_mode ) {
$default = $ui->source->{CVS_WORK_DIR} ;
$is_current_value = 1;
}
while (1) {
my ( $answer, $answer_record ) =
$ui->ask(
0,
$description,
0,
$prompt,
$prompt,
$default,
$is_current_value,
\@valid_answers
);
## Run handlers for this arc, redo question if exceptions generated
my $ok = eval {
$answer_record->[-1]->( $ui, $answer, $answer_record )
if defined $answer_record->[-1];
1;
};
unless ( $ok ) {
my $eval_error = $@;
if ( $eval_error =~ /^warning:/i ) {
## recoverable error, ask if user wants to accept value anyway?
my ( undef, $r ) = $ui->ask(
'error',
$eval_error,
1,
"Warning",
"Accept this value anyway",
"no",
0,
[
[ "yes", "yes", undef ],
[ "no", "no", undef ],
]
);
next unless $r->[0] eq "yes";
}
else {
## completely un-acceptable exception, re-ask question.
chomp $eval_error;
warn "\n\n $eval_error\n\n";
next;
}
}
## The next state
return $answer_record->[-2];
}
}
=item source_cvs_binary_checkout_prompt: Force binary checkout
Pass the -kb option to cvs, to force a binary checkout. This is useful
when you want a text file to be checked out with Unix linends, or if
you know that some files in the repository are not flagged as binary
files and should be.
Valid answers ("answer (regexp) => next prompt"):
no ('no') => source_cvs_use_cvs_prompt
yes ('yes') => source_cvs_use_cvs_prompt
=cut
sub source_cvs_binary_checkout_prompt {
my ( $ui ) = @_;
my $default = undef;
my $is_current_value = undef;
## Use single-quotish HERE docs as the most robust form of quoting
## so we don't have to mess with escaping.
my $prompt = <<'END_PROMPT';
Force binary checkout
END_PROMPT
chomp $prompt;
my @valid_answers = (
[ 'no', 'no', 'source_cvs_use_cvs_prompt',
undef,
],
[ 'yes', 'yes', 'source_cvs_use_cvs_prompt',
sub {
my ( $ui, $answer, $answer_record ) = @_;
$ui->source->{CVS_K_OPTION} = "b"; },
],
);
my $description = <<'END_DESCRIPTION';
Pass the -kb option to cvs, to force a binary checkout. This is useful
when you want a text file to be checked out with Unix linends, or if
you know that some files in the repository are not flagged as binary
files and should be.
END_DESCRIPTION
if ( $ui->in_edit_mode ) {
$default = $ui->source->{CVS_K_OPTION} =~ /b/ ? "yes" : "no" ;
$is_current_value = 1;
}
else {
$default = "no";
}
while (1) {
my ( $answer, $answer_record ) =
$ui->ask(
0,
$description,
0,
$prompt,
$prompt,
$default,
$is_current_value,
\@valid_answers
);
## Run handlers for this arc, redo question if exceptions generated
my $ok = eval {
$answer_record->[-1]->( $ui, $answer, $answer_record )
if defined $answer_record->[-1];
1;
};
unless ( $ok ) {
my $eval_error = $@;
if ( $eval_error =~ /^warning:/i ) {
## recoverable error, ask if user wants to accept value anyway?
my ( undef, $r ) = $ui->ask(
'error',
$eval_error,
1,
"Warning",
"Accept this value anyway",
"no",
0,
[
[ "yes", "yes", undef ],
[ "no", "no", undef ],
]
);
next unless $r->[0] eq "yes";
}
else {
## completely un-acceptable exception, re-ask question.
chomp $eval_error;
warn "\n\n $eval_error\n\n";
next;
}
}
## The next state
return $answer_record->[-2];
}
}
=item source_cvs_use_cvs_prompt: Use cvs executable
This forces VCP to use the cvs executable rather than read local
CVSROOT directories directly. This is slower, but may be used
to work around any limitations that might crop up in VCP's RCS
file parser.
Valid answers ("answer (regexp) => next prompt"):
yes ('yes') => dest_id_prompt
no ('no') => dest_id_prompt
=cut
sub source_cvs_use_cvs_prompt {
my ( $ui ) = @_;
my $default = undef;
my $is_current_value = undef;
## Use single-quotish HERE docs as the most robust form of quoting
## so we don't have to mess with escaping.
my $prompt = <<'END_PROMPT';
Use cvs executable
END_PROMPT
chomp $prompt;
my @valid_answers = (
[ 'yes', 'yes', 'dest_id_prompt',
sub {
my ( $ui, $answer, $answer_record ) = @_;
$ui->source->{CVS_USE_CVS} = 1; },
],
[ 'no', 'no', 'dest_id_prompt',
sub {
my ( $ui, $answer, $answer_record ) = @_;
$ui->source->{CVS_USE_CVS} = 0; },
],
);
my $description = <<'END_DESCRIPTION';
This forces VCP to use the cvs executable rather than read local
CVSROOT directories directly. This is slower, but may be used
to work around any limitations that might crop up in VCP's RCS
file parser.
END_DESCRIPTION
if ( $ui->in_edit_mode ) {
$default = $ui->source->{CVS_USE_CVS} ? "yes" : "no" ;
$is_current_value = 1;
}
else {
$default = "no";
}
while (1) {
my ( $answer, $answer_record ) =
$ui->ask(
0,
$description,
0,
$prompt,
$prompt,
$default,
$is_current_value,
\@valid_answers
);
## Run handlers for this arc, redo question if exceptions generated
my $ok = eval {
$answer_record->[-1]->( $ui, $answer, $answer_record )
if defined $answer_record->[-1];
1;
};
unless ( $ok ) {
my $eval_error = $@;
if ( $eval_error =~ /^warning:/i ) {
## recoverable error, ask if user wants to accept value anyway?
my ( undef, $r ) = $ui->ask(
'error',
$eval_error,
1,
"Warning",
"Accept this value anyway",
"no",
0,
[
[ "yes", "yes", undef ],
[ "no", "no", undef ],
]
);
next unless $r->[0] eq "yes";
}
else {
## completely un-acceptable exception, re-ask question.
chomp $eval_error;
warn "\n\n $eval_error\n\n";
next;
}
}
## The next state
return $answer_record->[-2];
}
}
=item source_vss_vssroot_prompt: Source SSDIR
Enter the directory containing the SRCSAFE.INI file for the
SourceSafe source repository.
Valid answers ("answer (regexp) => next prompt"):
(qr/./) => source_vss_user_prompt
=cut
sub source_vss_vssroot_prompt {
my ( $ui ) = @_;
my $default = undef;
my $is_current_value = undef;
## Use single-quotish HERE docs as the most robust form of quoting
## so we don't have to mess with escaping.
my $prompt = <<'END_PROMPT';
Source SSDIR
END_PROMPT
chomp $prompt;
my @valid_answers = (
[ '', qr/./, 'source_vss_user_prompt',
sub {
my ( $ui, $answer, $answer_record ) = @_;
$ui->source->repo_server( $answer )
unless empty $answer;
},
],
);
my $description = <<'END_DESCRIPTION';
Enter the directory containing the SRCSAFE.INI file for the
SourceSafe source repository.
END_DESCRIPTION
if ( $ui->in_edit_mode ) {
$default = $ui->source->repo_server;
$is_current_value = 1;
}
else {
$default = empty( $ENV{SSDIR} ) ? undef : $ENV{SSDIR};
}
while (1) {
my ( $answer, $answer_record ) =
$ui->ask(
0,
$description,
0,
$prompt,
$prompt,
$default,
$is_current_value,
\@valid_answers
);
## Run handlers for this arc, redo question if exceptions generated
my $ok = eval {
$answer_record->[-1]->( $ui, $answer, $answer_record )
if defined $answer_record->[-1];
1;
};
unless ( $ok ) {
my $eval_error = $@;
if ( $eval_error =~ /^warning:/i ) {
## recoverable error, ask if user wants to accept value anyway?
my ( undef, $r ) = $ui->ask(
'error',
$eval_error,
1,
"Warning",
"Accept this value anyway",
"no",
0,
[
[ "yes", "yes", undef ],
[ "no", "no", undef ],
]
);
next unless $r->[0] eq "yes";
}
else {
## completely un-acceptable exception, re-ask question.
chomp $eval_error;
warn "\n\n $eval_error\n\n";
next;
}
}
## The next state
return $answer_record->[-2];
}
}
=item source_vss_user_prompt: Source SSUSER
Enter the user name (SSUSER) required to access the SourceSafe
server. The default value is the current environment's SSUSER,
or "Admin", if SSUSER is unset.
Valid answers ("answer (regexp) => next prompt"):
(qr/./) => source_vss_password_prompt
=cut
sub source_vss_user_prompt {
my ( $ui ) = @_;
my $default = undef;
my $is_current_value = undef;
## Use single-quotish HERE docs as the most robust form of quoting
## so we don't have to mess with escaping.
my $prompt = <<'END_PROMPT';
Source SSUSER
END_PROMPT
chomp $prompt;
my @valid_answers = (
[ '', qr/./, 'source_vss_password_prompt',
sub {
my ( $ui, $answer, $answer_record ) = @_;
$ui->source->repo_user( $answer )
unless empty $answer;
},
],
);
my $description = <<'END_DESCRIPTION';
Enter the user name (SSUSER) required to access the SourceSafe
server. The default value is the current environment's SSUSER,
or "Admin", if SSUSER is unset.
END_DESCRIPTION
if ( $ui->in_edit_mode ) {
$default = $ui->source->repo_user;
$is_current_value = 1;
}
else {
$default = empty( $ENV{SSUSER} ) ? "Admin" : $ENV{SSUSER} ;
}
while (1) {
my ( $answer, $answer_record ) =
$ui->ask(
0,
$description,
0,
$prompt,
$prompt,
$default,
$is_current_value,
\@valid_answers
);
## Run handlers for this arc, redo question if exceptions generated
my $ok = eval {
$answer_record->[-1]->( $ui, $answer, $answer_record )
if defined $answer_record->[-1];
1;
};
unless ( $ok ) {
my $eval_error = $@;
if ( $eval_error =~ /^warning:/i ) {
## recoverable error, ask if user wants to accept value anyway?
my ( undef, $r ) = $ui->ask(
'error',
$eval_error,
1,
"Warning",
"Accept this value anyway",
"no",
0,
[
[ "yes", "yes", undef ],
[ "no", "no", undef ],
]
);
next unless $r->[0] eq "yes";
}
else {
## completely un-acceptable exception, re-ask question.
chomp $eval_error;
warn "\n\n $eval_error\n\n";
next;
}
}
## The next state
return $answer_record->[-2];
}
}
=item source_vss_password_prompt: Source SSPWD
If a password (SSPWD) is needed to access the SourceSafe server,
enter the password here. The default value is the current SSPWD
if one is set.
WARNING: Entering a password here causes the password to be echoed
in plain text to the terminal.
Valid answers ("answer (regexp) => next prompt"):
=> source_vss_filespec_prompt
=cut
sub source_vss_password_prompt {
my ( $ui ) = @_;
my $default = undef;
my $is_current_value = undef;
## Use single-quotish HERE docs as the most robust form of quoting
## so we don't have to mess with escaping.
my $prompt = <<'END_PROMPT';
Source SSPWD
END_PROMPT
chomp $prompt;
my @valid_answers = (
[ '', qr/^/, 'source_vss_filespec_prompt',
sub {
my ( $ui, $answer, $answer_record ) = @_;
if ( $ui->in_edit_mode ) {
$answer = $ui->source->repo_password
if $answer eq "** current password **";
}
else {
$answer = $ENV{SSPWD}
if $answer eq "** current SSPWD **";
}
$ui->source->repo_password( $answer )
unless empty $answer;
},
],
);
my $description = <<'END_DESCRIPTION';
If a password (SSPWD) is needed to access the SourceSafe server,
enter the password here. The default value is the current SSPWD
if one is set.
WARNING: Entering a password here causes the password to be echoed
in plain text to the terminal.
END_DESCRIPTION
if ( $ui->in_edit_mode ) {
unless ( empty $ui->source->repo_password ) {
$default = "** current password **";
$is_current_value = 1;
}
}
else {
$default = "** current SSPWD **"
unless empty $ENV{SSPWD};
}
while (1) {
my ( $answer, $answer_record ) =
$ui->ask(
0,
$description,
0,
$prompt,
$prompt,
$default,
$is_current_value,
\@valid_answers
);
## Run handlers for this arc, redo question if exceptions generated
my $ok = eval {
$answer_record->[-1]->( $ui, $answer, $answer_record )
if defined $answer_record->[-1];
1;
};
unless ( $ok ) {
my $eval_error = $@;
if ( $eval_error =~ /^warning:/i ) {
## recoverable error, ask if user wants to accept value anyway?
my ( undef, $r ) = $ui->ask(
'error',
$eval_error,
1,
"Warning",
"Accept this value anyway",
"no",
0,
[
[ "yes", "yes", undef ],
[ "no", "no", undef ],
]
);
next unless $r->[0] eq "yes";
}
else {
## completely un-acceptable exception, re-ask question.
chomp $eval_error;
warn "\n\n $eval_error\n\n";
next;
}
}
## The next state
return $answer_record->[-2];
}
}
=item source_vss_filespec_prompt: Source VSS filespec
Enter the vss filespec of the file(s) to copy, with or
without a leading "$/" or "/" (all names are taken as
absolute). To copy more than one file, use a "..." or "*"
wildcard:
... Copy entire repository
project1/... Copy entire project
project1/file Copy one file
project1/dir/... Copy a subdirectory
project1/dir/file*.bas Copy a set of files
Valid answers ("answer (regexp) => next prompt"):
(qr/./) => source_vss_undocheckout_prompt
=cut
sub source_vss_filespec_prompt {
my ( $ui ) = @_;
my $default = undef;
my $is_current_value = undef;
## Use single-quotish HERE docs as the most robust form of quoting
## so we don't have to mess with escaping.
my $prompt = <<'END_PROMPT';
Source VSS filespec
END_PROMPT
chomp $prompt;
my @valid_answers = (
[ '', qr/./, 'source_vss_undocheckout_prompt',
sub {
my ( $ui, $answer, $answer_record ) = @_;
$ui->source->repo_filespec( $answer );
},
],
);
my $description = <<'END_DESCRIPTION';
Enter the vss filespec of the file(s) to copy, with or
without a leading "$/" or "/" (all names are taken as
absolute). To copy more than one file, use a "..." or "*"
wildcard:
... Copy entire repository
project1/... Copy entire project
project1/file Copy one file
project1/dir/... Copy a subdirectory
project1/dir/file*.bas Copy a set of files
END_DESCRIPTION
if ( $ui->in_edit_mode ) {
$default = $ui->source->repo_filespec;
$is_current_value = 1;
}
else {
$default = "...";
}
while (1) {
my ( $answer, $answer_record ) =
$ui->ask(
0,
$description,
0,
$prompt,
$prompt,
$default,
$is_current_value,
\@valid_answers
);
## Run handlers for this arc, redo question if exceptions generated
my $ok = eval {
$answer_record->[-1]->( $ui, $answer, $answer_record )
if defined $answer_record->[-1];
1;
};
unless ( $ok ) {
my $eval_error = $@;
if ( $eval_error =~ /^warning:/i ) {
## recoverable error, ask if user wants to accept value anyway?
my ( undef, $r ) = $ui->ask(
'error',
$eval_error,
1,
"Warning",
"Accept this value anyway",
"no",
0,
[
[ "yes", "yes", undef ],
[ "no", "no", undef ],
]
);
next unless $r->[0] eq "yes";
}
else {
## completely un-acceptable exception, re-ask question.
chomp $eval_error;
warn "\n\n $eval_error\n\n";
next;
}
}
## The next state
return $answer_record->[-2];
}
}
=item source_vss_undocheckout_prompt: Issue "ss undocheckout" as needed
If set to "yes", VCP undoes user checkout operations when it
encounters a "File [file] is checked out by [user]" error.
These errors can occur when VCP scans metadata for checked-out
files when deleted versions of the same file also exist.
Issue "ss undocheckout" commands as needed?
Valid answers ("answer (regexp) => next prompt"):
yes ('yes') => dest_id_prompt
no ('no') => dest_id_prompt
=cut
sub source_vss_undocheckout_prompt {
my ( $ui ) = @_;
my $default = undef;
my $is_current_value = undef;
## Use single-quotish HERE docs as the most robust form of quoting
## so we don't have to mess with escaping.
my $prompt = <<'END_PROMPT';
Issue "ss undocheckout" as needed
END_PROMPT
chomp $prompt;
my @valid_answers = (
[ 'yes', 'yes', 'dest_id_prompt',
sub {
my ( $ui, $answer, $answer_record ) = @_;
$ui->source->{VSS_UNDOCHECKOUT} = 1;
},
],
[ 'no', 'no', 'dest_id_prompt',
sub {
my ( $ui, $answer, $answer_record ) = @_;
$ui->source->{VSS_UNDOCHECKOUT} = 0;
},
],
);
my $description = <<'END_DESCRIPTION';
If set to "yes", VCP undoes user checkout operations when it
encounters a "File [file] is checked out by [user]" error.
These errors can occur when VCP scans metadata for checked-out
files when deleted versions of the same file also exist.
Issue "ss undocheckout" commands as needed?
END_DESCRIPTION
if ( $ui->in_edit_mode ) {
$default = $ui->source->{VSS_UNDOCHECKOUT} ? "yes" : "no";
$is_current_value = 1;
}
else {
$default = "no";
}
while (1) {
my ( $answer, $answer_record ) =
$ui->ask(
0,
$description,
0,
$prompt,
$prompt,
$default,
$is_current_value,
\@valid_answers
);
## Run handlers for this arc, redo question if exceptions generated
my $ok = eval {
$answer_record->[-1]->( $ui, $answer, $answer_record )
if defined $answer_record->[-1];
1;
};
unless ( $ok ) {
my $eval_error = $@;
if ( $eval_error =~ /^warning:/i ) {
## recoverable error, ask if user wants to accept value anyway?
my ( undef, $r ) = $ui->ask(
'error',
$eval_error,
1,
"Warning",
"Accept this value anyway",
"no",
0,
[
[ "yes", "yes", undef ],
[ "no", "no", undef ],
]
);
next unless $r->[0] eq "yes";
}
else {
## completely un-acceptable exception, re-ask question.
chomp $eval_error;
warn "\n\n $eval_error\n\n";
next;
}
}
## The next state
return $answer_record->[-2];
}
}
=back
=head1 WARNING: AUTOGENERATED
This module is autogenerated in the pre-distribution build process, so
to change it, you need the master repository files in ui_machines/...,
not a CPAN/PPM/tarball/.zip/etc. distribution.
=head1 COPYRIGHT
Copyright 2003, Perforce Software, Inc. All Rights Reserved.
This module and the VCP 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 | |
|---|---|---|---|---|---|
| #1 | 6118 | Dimitry Andric | Integ from //public/revml to //guest/dimitry_andric/revml/main. | ||
| //guest/perforce_software/revml/lib/VCP/UIMachines.pm | |||||
| #50 | 5401 | Barrie Slaymaker | - UI updated | ||
| #49 | 4502 | Barrie Slaymaker | - "Run without saving" option removed | ||
| #48 | 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 |
||
| #47 | 4002 | Barrie Slaymaker | - Interactive UI no longer prompts for CVS -r and -d options | ||
| #46 | 3863 | Barrie Slaymaker | - UIMachines.pm updated | ||
| #45 | 3675 | Barrie Slaymaker | - More of a .vcp file is now editable | ||
| #44 | 3671 | Barrie Slaymaker |
- Add user interface flow diagrams - User interface flow diagrams now generated without handlers by default, make ui-with-handlers.{png,ps} to see the handlers. |
||
| #43 | 3666 | Barrie Slaymaker | - vcp can now edit existing .vcp files, for VSS sources and revml dests | ||
| #42 | 3654 | Barrie Slaymaker |
- VCP-Source-vss UI prompt is more clear - VCP::Source::vss' --cd option removed until a need is found |
||
| #41 | 3650 | Barrie Slaymaker | - UIMachines now current | ||
| #40 | 3640 | Barrie Slaymaker |
- xmllint no longer require to build UI - UI now offers multiple choices where appropriate |
||
| #39 | 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. |
||
| #38 | 3547 | John Fetkovich | Added defaults to yes/no questions (no in all cases) | ||
| #37 | 3538 | John Fetkovich | bug fix P4PASSWD defaulting | ||
| #36 | 3523 | John Fetkovich | more ui defaults and checks added | ||
| #35 | 3522 | John Fetkovich | default cvsroot from $ENV{CVSROOT} | ||
| #34 | 3518 | John Fetkovich | more interactive ui improvements | ||
| #33 | 3517 | John Fetkovich | change mode to text+w | ||
| #32 | 3515 | John Fetkovich | added P4HOST default | ||
| #31 | 3514 | John Fetkovich | p4 password defaulting | ||
| #30 | 3513 | John Fetkovich | defaulting of p4 user variable | ||
| #29 | 3512 | John Fetkovich | enhanced ui checks on repo_server | ||
| #28 | 3503 | John Fetkovich | not sure if this was re-generated on last change | ||
| #27 | 3501 | John Fetkovich | added ui_set_revml_repo_spec, and caller in the stml file | ||
| #26 | 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. |
||
| #25 | 3494 | John Fetkovich | default values in interactive ui partially implemented | ||
| #24 | 3492 | John Fetkovich |
interative ui question re-asked if exception generated when arc handlers are run. a single test case for source revml input file has been tested. |
||
| #23 | 3486 | John Fetkovich | moved (source or dest)->init calls to bin/vcp | ||
| #22 | 3484 | John Fetkovich | fix a prompt name | ||
| #21 | 3481 | John Fetkovich |
intro text moved out of state machine to bin/vcp. no longer requires user interaction to move on. |
||
| #20 | 3455 | John Fetkovich | remove "change branch rev #1" yes/no option from interactive interface | ||
| #19 | 3403 | John Fetkovich |
options given on all multiple choice prompts, and most free-form prompts where it makes sense |
||
| #18 | 3399 | John Fetkovich | ui fixes | ||
| #17 | 3395 | John Fetkovich | various ui refinements | ||
| #16 | 3390 | John Fetkovich | handlers for cvs ui | ||
| #15 | 3389 | John Fetkovich | made change_branch_rev prompt have both yes & no exit arcs | ||
| #14 | 3387 | Barrie Slaymaker | Make always writable on client | ||
| #13 | 3383 | John Fetkovich |
removed setting of repo_id, it's now done in 'sub init' in the sources and dests |
||
| #12 | 3375 | John Fetkovich | more ui changes | ||
| #11 | 3374 | John Fetkovich | set repo_id in branch running in local directory also | ||
| #10 | 3362 | John Fetkovich | revml source and dest now works through interactive UI | ||
| #9 | 3331 | John Fetkovich |
Small change in source revml state machine. split 'sub init' from 'sub new' in Source/revml.pm and Dest/revml.pm |
||
| #8 | 3330 | John Fetkovich | Added revml source and dest to ui state machines | ||
| #7 | 3305 | John Fetkovich |
added calls to set fields in p4 source and dest state machines, and then call to init |
||
| #6 | 3255 | Barrie Slaymaker |
Add in support for <arc> <handler>s. Requires latest StateML. See VCP-Source-p4.stml for an example. Calls VCP::Source::p4 in an unsupported way resulting in death. |
||
| #5 | 3253 | John Fetkovich | Added source::vss user interface | ||
| #4 | 3252 | John Fetkovich | added state machine parts for these destinations | ||
| #3 | 3244 | Barrie Slaymaker |
Integrate VCP::UI with bin/vcp. Type 'vcp' to run the UI. |
||
| #2 | 3240 | Barrie Slaymaker | UI definition cleanup | ||
| #1 | 3237 | Barrie Slaymaker | More work on the UI StateML conventions | ||