1## 2## Helper module to do common methods used between test cases ... 3## So that the t/*.t programs don't get cluttered with these common functions! 4## Also assumes you are not precounting the exact number of tests! 5## 6## Finally, it assumes your test programs are not changing directories. 7## All file paths used are relative, not absolute paths! So changing 8## directories will break a lot of code in this test module! 9## 10 11package helper1234; 12 13use strict; 14use warnings; 15 16use vars qw( @ISA @EXPORT @EXPORT_OK $VERSION ); 17use Exporter; 18 19use Test::More 0.88; 20use File::Basename; 21use File::Spec; 22 23# Uses both IO::Socket::SSL & Net::SSLeay 24use Net::FTPSSL; 25 26$VERSION = "1.01"; 27@ISA = qw( Exporter ); 28 29@EXPORT = qw ( stop_testing 30 bail_testing 31 called_by_make_test 32 get_log_name 33 are_updates_allowed 34 get_opts_set_in_init 35 initialize_your_connection 36 should_we_ask_1st_question 37 should_we_run_test 38 ask_config_questions 39 write_to_log 40 ok2 41 add_extra_arguments_to_config 42 ); 43 44@EXPORT_OK = qw( ); 45 46 47# The global variables ... 48my $config_file; # The name of the config file! 49my %FTPSSL_Defaults; # Matches what's in the config file of previous answers! 50my $silent_mode; # Only true if running via "make test"! 51my $debug_log_file; # What to call the log file ... 52 53my $extra_args = 0; 54 55my %opts_used_in_initialize_func; 56 57 58# ===================================================================== 59# Since I don't count the test cases, I must end my test programs 60# with a call to one of these 2 methods. 61# Can't do any tests in any END blocks! 62# --------------------------------------------------------------------- 63# When you exit with a status of zero, Test::More overrides the exit 64# status with a count of test failure cases. 65# If you use an explicit non-zero value, it aborts with that value instead. 66 67sub stop_testing 68{ 69 done_testing (); 70 exit (0); # Always must be 0! 71} 72 73# If called, causes "make test" to stop calling test programs. 74# The error was just that damming! 75sub bail_testing 76{ 77 my $msg = shift || "Uspecified reason!"; 78 79 done_testing (); 80 BAIL_OUT ( $msg ); 81 exit (0); 82} 83 84# ===================================================================== 85# Tries to detect if called during "make test" or directly as perl t/xxxx.t 86# Need multiple ways for different OS. 87# No option is 100% reliable for everyone! 88# Used to help determine if we should ask our questions after 1st try! 89 90sub called_by_make_test 91{ 92 my $ignore = shift || 0; # Don't pass this arg from any t/xxx.t progs! 93 94 # Usually set by "make test" on Unix ... 95 return (1) if ( $ENV{PERL_DL_NONLAZY} ); 96 97 # Set internally by this module when same test program 98 # asks the same questions 2 or more times! 99 return (1) if ( $ENV{ALREADY_ASKED_ONCE_IN_PROGRAM} && ! $ignore ); 100 101 # Set during "gmake test" on windows (Strawberry Perl) .. 102 return (1) if ( $ENV{PERL_USE_UNSAFE_INC} ); 103 104 # ok (0, "PERL5LIB = $ENV{PERL5LIB}"); 105 106 # Last ditch effort to detect this ... 107 if ( exists $ENV{PERL5LIB} ) { 108 my $mod = 'Net-FTPSSL-[0-9]+[.][0-9]+'; 109 foreach my $dir ( File::Spec->catdir ($mod, "blib", "lib"), 110 File::Spec->catdir ($mod, "blib", "arch") ) { 111 if ( $ENV{PERL5LIB} =~ m/${dir}($|;|:)/ ) { 112 return (1); 113 } 114 } 115 } 116 117 # Assumes called directly via "perl t/xxx.t" ... 118 return (0); 119} 120 121# ===================================================================== 122 123BEGIN { 124 # Determine where to put the config file ... 125 # Should be in the same directory as the helper module! 126 foreach my $dir ( File::Spec->catdir (".", "t", "test-helper"), 127 File::Spec->catdir (".", "test-helper"), 128 "." ) { 129 my $mod = File::Spec->catfile ( $dir, "helper1234.pm" ); 130 my $cfg = File::Spec->catfile ( $dir, "ftpssl.cfg" ); 131 if ( -f $mod ) { 132 $config_file = $cfg; 133 last; 134 } 135 } 136 137 unless ( $config_file ) { 138 bail_teseting ("Can't locate the helper module to create the config file!"); 139 } 140 141 # If it's being run via a make file ... 142 # Then don't ask any questions unless we have to ... 143 $silent_mode = ( called_by_make_test(0) ) ? 1 : 0; 144 145 # Build the log filename to use based on the program name ... 146 my $log = basename ($0, '.t'); 147 $log = "perl" if ( $log eq "-e" ); 148 $log .= '.log.txt'; 149 150 foreach my $dir ( File::Spec->catdir (".", "t", "logs"), 151 File::Spec->catdir (".", "logs"), 152 File::Spec->catdir ("..", "logs") ) { 153 if ( -d $dir ) { 154 $debug_log_file = File::Spec->catfile ( $dir, $log ); 155 last; 156 } 157 } 158 159 unless ( $debug_log_file ) { 160 bail_testing ("Can't locate where to put the Net::FTPSSL log file!"); 161 } 162} 163 164 165# ===================================================================== 166sub get_log_name 167{ 168 return ( $debug_log_file ); 169} 170 171 172# ===================================================================== 173# Tells if we're allowed to upload files to the FTPS server or not. 174 175sub are_updates_allowed 176{ 177 return ( ! $FTPSSL_Defaults{READ_ONLY} ); 178} 179 180 181# ===================================================================== 182sub get_opts_set_in_init 183{ 184 # Save a local copy a user may safely modify ... 185 my %opts = %opts_used_in_initialize_func; 186 187 return ( \%opts ); 188} 189 190 191# ===================================================================== 192# Common initialization required by most test cases past t/07-prompt_validation.t. 193# If any issues are encountered with your answers, the program automatically dies. 194 195# Always returns a valid Net-FTPSSL object reference. 196 197sub initialize_your_connection 198{ 199 my $alt_log_file = shift; # Use to override log file to use. 200 my %extra_opts = @_; # Optional extra arguments needed for a particular test case. 201 202 # Only program "t/01-ask-questions.t" should ever set this value to "1"! 203 # All other test programs should set to zero! 204 my $force = 0; 205 206 if ( should_we_ask_1st_question ($force) ) { 207 should_we_run_test ("Gathering common setup options"); 208 } 209 210 my ( $host, $user, $pass, $dir, $ftps_opts, $psv_mode ) = ask_config_questions (); 211 212 # Did a test case require extra options? (not remembered between test runs) 213 foreach ( sort keys %extra_opts ) { 214 diag ("Overriding $_ => $extra_opts{$_}") unless ( called_by_make_test(1) ); 215 $ftps_opts->{$_} = $extra_opts{$_}; 216 } 217 218 # Save for later use by get_opts() ... 219 %opts_used_in_initialize_func = %{$ftps_opts}; 220 221 # Set so when the same program makes multiple connections, only asks the 1st time! 222 $silent_mode = $ENV{ALREADY_ASKED_ONCE_IN_PROGRAM} = 1; 223 224 # ------------------------------------- 225 ok ( 1, "User Input Accepted!" ); 226 # ------------------------------------- 227 228 # Overriding what to call the log file? 229 $ftps_opts->{DebugLogFile} = $alt_log_file if ( $alt_log_file ); 230 231 my $ftps = Net::FTPSSL->new ( $host, $ftps_opts ); 232 my $res = isa_ok ( $ftps, 'Net::FTPSSL', 'Net::FTPSSL object created' ) or 233 bail_testing ("Can't create a Net::FTPSSL object with the answers given!"); 234 235 $res = $ftps->trapWarn (); 236 ok ( $res, "Warnings Trapped!" ) or 237 bail_testing ("Net-FTPSSL can't trap any warinings!"); 238 239 $res = $ftps->login ($user, $pass); 240 ok ( $res, "Login Successful! Your credentials are good!" ) or 241 bail_testing ("Can't login to the SFTP server. Your credentials are probably bad!"); 242 243 if ( $psv_mode ne "P" ) { 244 # Set via t/07-prompt_validation.t ... (Should be 1 or 2.) 245 my $opt = $FTPSSL_Defaults{EXTRA_EPASV_OPT_VALUE} || 1; 246 $res = $ftps->force_epsv ( $opt ); 247 ok ( $res, "Force Extended Pasive MODE (EPSV $opt)" ) or 248 bail_testing ("EPSV ${opt} is not supported, please change your answer to use PASV instead!"); 249 } 250 251 $res = $ftps->cwd ($dir); 252 ok ( $res, "Change Dir Successful! ($dir)" ) or 253 bail_testing ("Can't change into the test directory on the SFTP server! Please change your answer for it!"); 254 255 if ( $ftps_opts->{Encryption} eq CLR_CRYPT ) { 256 ok (1, "FTP connection established ..."); 257 } else { 258 ok (1, "FTPSSL connection established ..."); 259 } 260 261 return ( $ftps ); # Everyting initialized just fine! 262} 263 264 265# ===================================================================== 266# Call to determine if we need to ask any questions ... 267# Never returns if the config file says to skip all tests! 268# Returns: 1 - You must call should_we_run_test() 269# 0 - Don't call it! 270 271sub should_we_ask_1st_question 272{ 273 my $force = shift || 0; 274 275 if ( $ENV{PERL_MM_USE_DEFAULT} ) { 276 ok (1, "Skipping all tests per smoke tester ENV setting ..."); 277 unlink ( $config_file ); 278 stop_testing (); 279 } 280 281 # Loads all defaults from a config file if it exists from a previous run. 282 # The results are all stored in the global %FTPSSL_Defaults hash. 283 my $status = read_config_file (); 284 285 unless ( $status ) { 286 ok ( 1, "No config file is present ..." ); 287 $silent_mode = 0; # No, force the asking of the questions ... 288 return (1); 289 } 290 291 if ( $force ) { 292 ok ( 1, "Forcing the re-asking of all questions ..." ); 293 $silent_mode = 0; 294 return (2); 295 } 296 297 return (3) unless ( $silent_mode ); 298 299 unless ( $FTPSSL_Defaults{FTPSSL_RUN_TESTS} ) { 300 ok ( 1, "Skipping all tests per config file settings ..." ); 301 stop_testing (); 302 } 303 304 # No need to call again ... 305 return (0); 306} 307 308 309# ===================================================================== 310# Never returns if you say not to run the tests ... 311 312sub should_we_run_test 313{ 314 # Do you wish to force asking all the questions ??? 315 my $custom_msg = shift; 316 317 diag ( "" ); 318 if ( $custom_msg ) { 319 diag ( ${custom_msg} ); 320 } else { 321 my $prog = basename ( $0 ); 322 diag ( "Preparing to run test t/${prog}" ); 323 } 324 325 diag ( "Some information will be required for running any FTPS tests:" ); 326 diag ( "A secure ftps server address, a user, a password and a directory" ); 327 diag ( "where the user has permissions to read and/or write files to." ); 328 diag ( "Hopefully only the Net::FTPSSL tests have access to to this dir." ); 329 proxy_supported (1); 330 331 my $copy = $silent_mode; 332 $silent_mode = 0; 333 my $ans = ask_yesno ("Do you want to run the server connectivity tests", 'FTPSSL_RUN_TESTS'); 334 $silent_mode = $copy; 335 336 unless ( $ans ) { 337 diag ( "Skipping all tests per user request ..." ); 338 write_config_file (); 339 stop_testing (); 340 } 341 342 return; 343} 344 345 346# ===================================================================== 347# Asks all the configuration questions required by the test cases ... 348# And then saves the answers to disk so that they are available 349# as defaults the next time this method is called! 350# These defaults can be found in the %FTPSSL_Defaults hash. 351# --------------------------------------------------------------------- 352# Returns: The options hash to use in call to Net::FTPSSL->new() 353# plus all other items prompted for. 354 355sub ask_config_questions 356{ 357 # The return values ... 358 my ( $host, $user, $pass, $dir, %ftps_opts ); 359 360 my $p_flag = proxy_supported (); 361 362 my $read_only = ask_yesno ("Are we restricted to read-only tests", 'READ_ONLY'); 363 364 my $server = askQW ("\tServer address ( host[:port] )", undef, undef, 'FTPSSL_SERVER'); 365 if ( $server =~ m/^([^:]+)[:](\d*)$/ ) { 366 $host = $1; 367 $ftps_opts{Port} = $2 if ( $2 ne "" ); 368 } else { 369 $host = $server; 370 } 371 372 $user = askQW ("\tUser", "anonymous", undef, 'FTPSSL_USER'); 373 $pass = askQW ("\tPassword [a space for no password]", "user\@localhost", undef, 'FTPSSL_PWD', 0, 1); 374 375 $dir = askQW ("\tDirectory", "<HOME>", undef, 'FTPSSL_DIR'); 376 $dir = "" if ($dir eq "<HOME>"); # Will ask server for it later on 377 378 my $mode = askQW ("\tConnection mode (I)mplicit, (E)xplicit, or (C)lear.", "E", "(I|E|C)", 'FTPSSL_Encryption', 1); 379 $ftps_opts{Encryption} = $mode; 380 381 # If the connection is to be encrypted ... 382 if ( $mode ne CLR_CRYPT ) { 383 my $ans = askQW ("\tData Connection mode (C)lear or (P)rotected.", "P", "(C|S|E|P)", 'FTPSSL_DataProtLevel', 1); 384 $ftps_opts{DataProtLevel} = $ans; 385 386 my $ver = $IO::Socket::SSL::VERSION; 387 my $opts; 388 my $def = "TLSv12"; 389 390 # Values from IO::Socket::SSL.pm ... 391 # Search for "my %SSL_OP_NO" initialization. 392 if ( Net::SSLeay->can ("OP_NO_TLSv1_3") && $ver >= 2.060 ) { 393 $opts = "(SSLv23|TLSv1|TLSv11|TLSv12|TLSv13)"; 394 } else { 395 $opts = "(SSLv23|TLSv1|TLSv11|TLSv12)"; 396 } 397 $ans = askQW ("\tWhat encryption protocal to use", $def, $opts, 'FTPSSL_SSL_version'); 398 $ftps_opts{SSL_version} = $ans; 399 400 } else { 401 delete $FTPSSL_Defaults{FTPSSL_DataProtLevel}; 402 delete $FTPSSL_Defaults{FTPSSL_SSL_version}; 403 delete $FTPSSL_Defaults{CERTIFICATE_USAGE}; 404 } 405 406 my $psv_mode = askQW("\tUse (P)ASV or (E)PSV for data connections", "P", "(P|E)", 'FTPSSL_PASIVE', 1); 407 408 if ( $p_flag ) { 409 my $res = ask_proxy_questions (); 410 $ftps_opts{ProxyArgs} = $res if ( $res ); 411 } 412 413 # Certificates require encrypted communication ... 414 if ( $mode ne CLR_CRYPT ) { 415 my %certificate; 416 if ( ask_certificate_questions ( \%certificate ) ) { 417 $ftps_opts{SSL_Client_Certificate} = \%certificate; 418 } 419 } 420 421 # Hard code these options ... 422 $ftps_opts{PreserveTimestamp} = 1; 423 $ftps_opts{Timeout} = 30; 424 $ftps_opts{Debug} = 1; 425 $ftps_opts{Croak} = 0; 426 # $ftps_opts{Trace} = 1; 427 428 # Assume help is broken for all connections & all FTP commands are supported. 429 # If not needed, it will be removed later via an auto-added extra argument! 430 # Found a server where HELP is broken for clear FTP as well. 431 $ftps_opts{OverrideHELP} = 1; 432 433 # The log file used by the Net::FTPSSL object in the current test program ... 434 $ftps_opts{DebugLogFile} = $debug_log_file; 435 436 # Do we keep any auto-added extra options? 437 # Always Assume Yes if there are extra arguments! 438 # No matter what was said last time! 439 $FTPSSL_Defaults{QUESTION_EXTRA} = 1; 440 441 if ( $extra_args ) { 442 my $ans = ask_yesno ("Should we keep automatically-added extra Net::FTPSSL options from previous test runs", 'QUESTION_EXTRA'); 443 foreach my $key ( keys %FTPSSL_Defaults ) { 444 next unless ( $key =~ m/^EXTRA_(.+)$/ ); 445 my $opt = $1; 446 unless ( $ans ) { 447 diag ("Removing: $opt = $FTPSSL_Defaults{$key}"); 448 delete $FTPSSL_Defaults{$key}; 449 } elsif ( $opt eq "OverrideHELP" && $FTPSSL_Defaults{$key} == 99 ) { 450 # diag ("OverrideHELP is no longer needed!"); 451 delete $ftps_opts{$opt}; 452 } else { 453 diag ("Keeping: $opt = $FTPSSL_Defaults{$key}"); 454 $ftps_opts{$opt} = $FTPSSL_Defaults{$key}; 455 } 456 } 457 } 458 459 # Save any changes to our answers ... 460 write_config_file (); 461 462 return ( $host, $user, $pass, $dir, \%ftps_opts, $psv_mode ); 463} 464 465 466# ===================================================================== 467# An undocumented way to write to Net::FTPSSL's log file ... 468# I don't really recommend using this function yourself. 469# But the test scripts are desparate to do this to ease validation 470# of all the test cases! 471 472sub write_to_log 473{ 474 my $ftpssl_obj = shift; 475 my $label = shift; 476 my $msg = shift; 477 478 if ( defined $ftpssl_obj && ref ($ftpssl_obj) eq "Net::FTPSSL" ) { 479 $ftpssl_obj->_print_LOG ($label . ": ", $msg, "\n"); 480 } else { 481 diag ($msg); 482 } 483 484 return; 485} 486 487 488# ===================================================================== 489# A replacement for Test::More::ok() ... 490# Where the results of ok() also gets written to the Net::FTPSSL log file ... 491 492sub ok2 493{ 494 my $ftpssl_obj = shift; 495 my $status = shift; 496 my $msg = shift; 497 498 my $sts = ok ( $status, $msg ); 499 500 my $lbl = ( $sts ) ? "OK" : "NOT OK"; 501 write_to_log ($ftpssl_obj, $lbl, $msg); 502} 503 504# ===================================================================== 505# Asks for the proxy information ... 506# Only called if the required module is installed. 507 508sub ask_proxy_questions 509{ 510 my $ans = ask_yesno ("Will you be FTP'ing through a proxy server", 'FTPSSL_PROXY_ASK_USE_PROXY'); 511 unless ( $ans ) { 512 delete $FTPSSL_Defaults{FTPSSL_PROXY_HOST}; 513 delete $FTPSSL_Defaults{FTPSSL_PROXY_PORT}; 514 delete $FTPSSL_Defaults{FTPSSL_PROXY_USER_PWD_REQUIRED}; 515 delete $FTPSSL_Defaults{FTPSSL_PROXY_USER}; 516 delete $FTPSSL_Defaults{FTPSSL_PROXY_PWD}; 517 return undef; 518 } 519 520 my %proxy_args; 521 $proxy_args{'proxy-host'} = askQW ("\tEnter your proxy server name", undef, undef, 'FTPSSL_PROXY_HOST'); 522 $proxy_args{'proxy-port'} = askQW ("\tEnter your proxy port", undef, undef, 'FTPSSL_PROXY_PORT'); 523 524 $ans = ask_yesno ("\tDoes your proxy server require a user name/password pair?", 'FTPSSL_PROXY_USER_PWD_REQUIRED'); 525 if ($ans) { 526 $proxy_args{'proxy-user'} = askQW ("\tEnter your proxy user name", undef, undef, 'FTPSSL_PROXY_USER'); 527 $proxy_args{'proxy-pass'} = askQW ("\tEnter your proxy password", undef, undef, 'FTPSSL_PROXY_PWD'); 528 } else { 529 delete $FTPSSL_Defaults{FTPSSL_PROXY_USER}; 530 delete $FTPSSL_Defaults{FTPSSL_PROXY_PWD}; 531 } 532 533 # diag ("Host: ", $proxy_args{'proxy-host'}, " Port: ", $proxy_args{'proxy-port'}, " User: ", ($proxy_args{'proxy-user'} || "undef"), " Pwd: ", ($proxy_args{'proxy-pwd'} || "undef")); 534 535 return \%proxy_args; 536} 537 538 539# ===================================================================== 540# Tells if we're allowed to use a proxy server ... 541 542sub proxy_supported 543{ 544 my $print_warn = shift; 545 546 eval { 547 require Net::HTTPTunnel; 548 }; 549 if ($@) { 550 if ( $print_warn ) { 551 diag ("NOTE: Using a proxy server is not supported without first installing Net::HTTPTunnel\n"); 552 } 553 return 0; 554 } 555 556 return 1; 557} 558 559 560# ===================================================================== 561# Ask for client certicate information ... 562# --------------------------------------------------------------------- 563# The client certificate is only used if your FTPS server 564# asks for a copy. Otherwise this certificate info is ignored! 565# See the examples in the IO-Socket-SSL distro for more details! 566# --------------------------------------------------------------------- 567# NOTE: You may use a separate certificate hash or merge it into 568# the main hash. It works either way these days. 569# --------------------------------------------------------------------- 570 571sub ask_certificate_questions 572{ 573 my $ftps_hash = shift; 574 575 my $ans = ask_yesno ("Will you be using Client Certificates", 'CERTIFICATE_USAGE'); 576 unless ( $ans ) { 577 delete $FTPSSL_Defaults{SSL_cert_file}; 578 delete $FTPSSL_Defaults{SSL_key_file}; 579 delete $FTPSSL_Defaults{CERTIFICATE_PASSWORD}; 580 delete $FTPSSL_Defaults{CERTIFICATE_PEER}; 581 delete $FTPSSL_Defaults{CERTIFICATE_PEER_OVERRIDE}; 582 return 0; 583 } 584 585 $ftps_hash->{SSL_use_cert} = 1; 586 $ftps_hash->{SSL_server} = 0; 587 588 # The developer's certificate location, not in the distribution! 589 my $pubkey = "$ENV{HOME}/Certificate/pubkey.pem"; 590 my $private = "$ENV{HOME}/Certificate/private.pem"; 591 592 # The hint to use when prompting for the password ... 593 my $hint_pwd = "my_password"; 594 595 # Asks for the Client Certificate information ... 596 $ftps_hash->{SSL_cert_file} = ask_for_file ("\tEnter path to public key (pubkey.pem)", 'SSL_cert_file', $pubkey); 597 $ftps_hash->{SSL_key_file} = ask_for_file ("\tEnter path to private key (private.pem)", 'SSL_key_file', $private); 598 599 # Detects if the hint was really needed ... 600 $hint_pwd = undef if ( $ftps_hash->{SSL_key_file} ne $private ); 601 602 my $my_pwd = askQW ("\tWhat is your Certificate's password [a space for no password]", $hint_pwd, undef, 'CERTIFICATE_PASSWORD', 0, 1); 603 $ftps_hash->{SSL_passwd_cb} = sub { return ( $my_pwd ); }; 604 605 $ftps_hash->{SSL_verify_callback} = \&check_certificate; 606 607 $ans = ask_yesno ("\tWill you be using Peer Validation", 'CERTIFICATE_PEER'); 608 $ftps_hash->{SSL_verify_mode} = $ans ? Net::SSLeay::VERIFY_PEER() : Net::SSLeay::VERIFY_NONE(); 609 610 # If using the callback function & selected peer validation ... 611 if ( $ans ) { 612 $ans = ask_yesno ("\tFor Peer Validation, do you want to override IO-Socket-SSL's decision on if it's a valid certificate", 'CERTIFICATE_PEER_OVERRIDE'); 613 } else { 614 delete $FTPSSL_Defaults{CERTIFICATE_PEER_OVERRIDE}; 615 } 616 617 return 1; 618} 619 620 621# ===================================================================== 622# The certificate callback function ... 623# -------------------------------------------------------------------------- 624# Only called if SSL_verify_mode => Net::SSLeay::VERIFY_PEER() is used! 625# -------------------------------------------------------------------------- 626# This callback function prints out the FTPS Server's Certificate information 627# and can also be used to override IO-Socket-SSL's decision on if the Server's 628# Certificate is valid or not! 629# -------------------------------------------------------------------------- 630sub check_certificate 631{ 632 my $ret = $_[0]; # What SSL thinks the status is ... (1-good, 0-bad) 633 634 my $lbl = "*** CALLBACK ***"; 635 my $len = length ($lbl); 636 my $ind = " "x${len}; 637 638 # Detects if you wish to accept the certificate as valid no mater what! 639 if ( $FTPSSL_Defaults{CERTIFICATE_PEER_OVERRIDE} ) { 640 $ret = 1; 641 } 642 643 my $msg = sprintf ( "\n%s: [%s]\n *** RETURN *** : %s\n\n", 644 $lbl, join ("],\n${ind}: [", @_), $ret ); 645 diag ( $msg ); 646 647 return ( $ret ); 648} 649 650 651# ===================================================================== 652# Returns 1/0 based on the quesion's answer. 653# It then updates the given key's value with the return value! 654 655sub ask_yesno 656{ 657 my $question = shift; 658 my $hash_key = shift || bail_testing ("Must provide a hash key!"); 659 660 my $default = ( $FTPSSL_Defaults{$hash_key} ) ? "Y" : "N"; 661 662 my $answer = promptW ($question, $default, "(Y|N)"); 663 664 if ( $answer =~ m/^y(es)*$/i ) { 665 $FTPSSL_Defaults{$hash_key} = 1; 666 } elsif ( $answer =~ m/^n(o)*$/i ) { 667 $FTPSSL_Defaults{$hash_key} = 0; 668 } else { 669 $FTPSSL_Defaults{$hash_key} = ($default eq "Y") ? 1 : 0; 670 diag (" *** Invalid Response [$answer]. Using \"$default\" instead!"); 671 } 672 673 return ( $FTPSSL_Defaults{$hash_key} ); 674} 675 676 677# ===================================================================== 678# A generic question is asked ... 679# An answer of " " means to return the empty string "" if no validation is done. 680 681# This is the wrapper function ... 682sub askQW 683{ 684 my $question = shift; 685 my $hard_coded_default = shift; 686 my $values_to_choose_from = shift; 687 my $hash_key = shift; 688 my $upshift = shift; 689 my $allow_empty_string = shift; 690 691 my ($dynamic_default, $flag); 692 if ( defined $hash_key && $hash_key !~ m/^\s*$/ ) { 693 $dynamic_default = $FTPSSL_Defaults{$hash_key}; 694 $flag = 1; 695 } 696 697 my $ans = askQX ($question, $hard_coded_default, $values_to_choose_from, $dynamic_default, $upshift, $allow_empty_string); 698 699 $FTPSSL_Defaults{$hash_key} = $ans if ( $flag ); 700 701 return ($ans); 702} 703 704 705# Does the actual asking ... 706sub askQX 707{ 708 my $question = shift; 709 my $hard_coded_default = shift; 710 my $values_to_choose_from = shift || ""; # Ex: (Y|N) 711 my $dynamic_default = shift; 712 my $upshift = shift || 0; 713 my $allow_empty_string = shift || 0; 714 715 # Protect against undef as an argument value ... 716 $hard_coded_default = "" unless (defined $hard_coded_default); 717 $dynamic_default = $hard_coded_default unless (defined $dynamic_default); 718 719 $dynamic_default = uc ($dynamic_default) if ( $upshift ); 720 721 my $answer = promptW ($question, $dynamic_default, $values_to_choose_from); 722 $answer = uc ($answer) if ( $upshift ); 723 724 if ( $allow_empty_string && $answer =~ m/^\s+$/ ) { 725 $answer = ""; # Overrides any validation checks and/or defaults. 726 727 # Validating the answer ??? 728 } elsif ( $values_to_choose_from ) { 729 my $val; 730 if ( $values_to_choose_from =~ m/^[(](.*)[)]$/ ) { 731 $val = "|" . $1 . "|"; 732 } else { 733 $val = "|" . $values_to_choose_from . "|"; 734 } 735 $val =~ s/[|]/#/g; 736 737 # If it's an invalid answer, use the default value instead! 738 my $ans = "#" . $answer . "#"; 739 if ( $val !~ m/${ans}/ ) { 740 diag (" *** Invalid Response [$answer]. Using \"$dynamic_default\" instead!"); 741 $answer = $dynamic_default; 742 } 743 } 744 745 # diag ("ANS: [$answer]"); 746 747 return $answer; 748} 749 750 751# ===================================================================== 752# Asks the user for a valid filename ... 753 754sub ask_for_file 755{ 756 my $question = shift; 757 my $hash_key = shift || bail_testing ("Must provide a hash key!"); 758 my $devDef = shift; 759 760 my $default = $FTPSSL_Defaults{$hash_key}; 761 762 unless ( defined $default ) { 763 if ( $devDef && -f $devDef && -r _ ) { 764 $default = $devDef; 765 } 766 } 767 768 my $answer = promptW ($question, $default); 769 770 while (! ( -f $answer && -r _ )) { 771 diag ("*** Invalid file name! ***"); 772 $answer = promptW ($question, $default); 773 } 774 775 $FTPSSL_Defaults{$hash_key} = $answer; 776 777 return ( $answer ); 778} 779 780 781# ===================================================================== 782# Prompts the user for a response to a question. 783# It doesn't validate the response. 784# It can never return undef! 785 786# Based on>> ExtUtils::MakeMaker::prompt (question, default) 787# (can't use it since "make test" doesn't display the questions!) 788 789sub prompt 790{ 791 my ($question, $default, $opts) = (shift, shift, shift); 792 793 my $isa_tty = -t STDIN && (-t STDOUT || !(-f STDOUT || -c STDOUT)); 794 795 my $dispdef = defined $default ? "[$default] " : " "; 796 $default = defined $default ? $default : ""; 797 798 if (defined $opts && $opts !~ m/^\s*$/) { 799 diag ("\n${question} ? $opts $dispdef"); 800 } else { 801 diag ("\n${question} ? $dispdef"); 802 } 803 804 my $ans; 805 if ( $ENV{PERL_MM_USE_DEFAULT} || (!$isa_tty && eof STDIN)) { 806 diag ("${default}\n"); 807 } else { 808 $ans = <STDIN>; 809 chomp ($ans); 810 unless (defined $ans) { 811 diag ("\n"); 812 } 813 } 814 815 $ans = $default unless ($ans); 816 817 return ( $ans ); 818} 819 820 821# ===================================================================== 822# As a wrapper ... 823 824sub promptW 825{ 826 my ($question, $default, $opts) = (shift, shift, shift); 827 828 my $ans; 829 if ( $silent_mode ) { 830 $ans = $default; # Silently use the default ... 831 # diag ("${ans}\n"); 832 833 } else { 834 $ans = prompt ( $question, $default, $opts ); 835 } 836 837 return ( $ans ); 838} 839 840 841# ===================================================================== 842# Tells us to add the requested option to the config file ... 843# Will show up as EXTRA_<option>. 844 845sub add_extra_arguments_to_config 846{ 847 my $option = shift; # The Net::FTPSSL option to add ... 848 my $value = shift; # The value to use ... 849 850 my $key = "EXTRA_" . $option; 851 $FTPSSL_Defaults{$key} = $value; 852 853 $extra_args = 1; 854 855 write_config_file (); 856 857 return; 858} 859 860 861# ===================================================================== 862# Create the config file shared between all the test cases! 863 864sub write_config_file 865{ 866 open (FH, ">", $config_file) or bail_testing ("Can't save FTPSSL config settings! ($config_file)"); 867 868 foreach my $k (sort keys %FTPSSL_Defaults) { 869 printf FH ("%s=%s\n", $k, $FTPSSL_Defaults{$k}); 870 } 871 872 close (FH); 873 874 # Make sure only readable by owner of file ... Unix: -rw-------. 875 # It contains passwords! 876 chmod (0600, $config_file); 877 878 return; 879} 880 881 882# ===================================================================== 883# Read the config file if it exists! 884# And then load all values into the %FTPSSL_Defaults hash. 885# Returns: 1 - Success, 0 - No config file or error reading it. 886 887sub read_config_file 888{ 889 unless ( -f $config_file && -r _ ) { 890 return (0); # No such config file or not readable. 891 } 892 893 # Reset global var to say no EXTRA_ tags found ... 894 $extra_args = 0; 895 896 open ( FH, "<", $config_file ) or return (0); 897 while (<FH>) { 898 chomp(); 899 my ($var, $val) = split (/\s*=\s*/, $_, 2); 900 $FTPSSL_Defaults{$var} = $val; 901 $extra_args = 1 if ( $var =~ m/^EXTRA_/ ); 902 } 903 close (FH); 904 905 return (1); # It's been read into memory! 906} 907 908 909#required if module is included w/ require command; 9101; 911 912