Perl replacement for choice.com

[onelander]

After running into the incompatibility of the choice.com program on Windows 64bit, I wondered if I could write a Perl replacement. I believe I have done it. I wanted to share what I created as this site has provided me so much help.

#!/usr/bin/perl

# This script was written to become a drop-in
# replacement for Microsoft's choice.com
# choice.com does not work on Win 64bit
# This script should provide the same funcationality
# as the existing usage of choice.com

use strict;
use warnings;
use Term::ReadKey;
use threads;
use threads::shared;
use Getopt::Long;

if ( $^O eq "MSWin32" ) {
    # this is needed here because signals on Windows
    # do not work properly
    $ENV{PERL_SIGNALS} = "unsafe";
}

$SIG{INT}=\&ctrl_c_handler;
    
# in order to see the prompt text correctly
# we need to turn buffering off
$| = 1;

# setup defaults when the user does not provide any
# arguments - choices is used in a subroutine so make
# it global
my $choices = "yn";
my $default;
my $timeout;
my $message = "Enter your choice";
my $help = 0;
my $debug = 0;
my $uc_default;

# command line arguments
Getopt::Long::Configure("prefix_pattern=(--|-|\/)");
GetOptions('c:s' => \$choices, 'd:s' => \$default, 't:i' => \$timeout,
+ 'm:s' => \$message, 'h|?' => \$help, 'x' => \$debug);

# show the usage if the user requests it
# pass the script name to the usage sub so
# it can be shown during the output
if ( $help ) {
    usage($0);
    exit;
}

# if the user wants to see what they entered onto the command
# line they can use -x to print out what variables contain
# what values
if ( $debug ) {

    print "
    choices: $choices
    default: $default
    timeout: $timeout
    message: $message
    help: $help
    \n";
    exit 0;
}

# if a default option is chosen by the user then it MUST
# have an accompanying timeout.  otherwise there is no
# point in having a default value
# the reverse is also true
# errors must exit with a return code of 255
if (  ( defined $default ) && ( ! defined $timeout )
      ||
      ( ! defined $default ) && ( defined $timeout )
   ) {
   print "\n\tYou must use -d and -t together\n";
   exit 255;
}

# make the default choice captial so it is obvious
# but only do this if a default value is provided
if ( defined $default ) {
    $uc_default = uc($default);
    $choices =~ s/$default/$uc_default/;
}

# the user output for choices needs to separate the characters
# by a comma
my $show_choices = $choices;

# regex to add a comma after each char
# the (.) captures each character and
# adds a comma after it
# $show_choices =~ s/(.)/$1,/g;
# $show_choices =~ s/,$//g;       # remove the last comma
#
# these two can be combined into one regex
# thanks Athanasius from PMo
# read Look-Around Assertions under the
# Extended Patterns section on perlre
$show_choices =~ s/(?<=.)(?=.)/,/g;

# if the default choice provided does not match the group
# of choices provided, error and exit
# errors must exit with a return code of 255
if ( ( defined $default ) && ( $choices !~ /$default/i ) ) {
    print "Your choices ($show_choices) do not match the default ($def
+ault)\n";
    exit 255;
}

# if a default value is provided then we must wrap the
# grabkey function in a timer so we can exit with the
# the proper default value if not entry is chosen by
# the user.  this is wrapping is done with via threading
# because a default value must exist with a timeout this
# will work correctly

if ( defined $default ) {

    # because we are using threads and one of them gets detached
    # when a ctrl-c is used it will kill the threads but throw
    # a "A thread exited while 2 threads were running." error
    # since we do not want to see that error we redirect
    # STDERR to a variable so that error is not seen on screen
    # anymore.  THIS IS NOT A GOOD WAY TO GO AS EVERY STDERR
    # ERROR IS HIDDEN.
    my $stderr;
    close STDERR;
    open(STDERR, ">", \$stderr);

    # create a thread to run the grabkey sub
    # this thread will watch the keyboard for the user
    # input - detach from the thread to let it run on
    # its own
    my $grabkey_thread = threads->create(\&grabkey);
    $grabkey_thread->detach();

    # setup a timer so that if the user does not provide
    # any input on the command line the script will exit
    # after the timeout has been reached
    # the exit return code will be the default choice
    for ( my $i = 0; $i <= $timeout; $i++ ) {
        sleep 1;
    }
    
    # to get here the timeout had to have occurred so
    # exit the script with the index of the value from
    # the choices provided to the user
    # index starts at 1
    # ex: choices abcd - default is c - index is 3
    my $pos = index( uc( $choices ), uc( $default ) ) + 1;
    print uc( $default ) . "\n";
    exit $pos;
    
}
    
# no default value exists so no timeout is required
# this will call the function which will wait forever
# until the user supplies a value
grabkey();

sub grabkey {

    # this sub will watch the keyboard for any user input
    # and then compare it to valid values
    # if the user value is wrong it will prompt again
    # once a valid value is entered the script will exit
    # with the return code of the user choice
    my $key;
    my $prompt;
    
    $prompt = "$message [$show_choices]?";
    
    do {
        print $prompt;
        while (not defined ($key = ReadKey(-1))) {} # watch the keyboa
+rd in a loop
        print "$key\n";
    } until ( ( ! defined $key ) || ( $key =~ m/[$choices]/i ) );
    
    my $pos = index( uc( $choices ), uc( $key ) ) + 1;
    
    exit $pos;

}

sub usage {

    my $script = shift;
    
    print "
    Usage:
    $script /c <choices> /d <default choice> /t <timeout> /m <message>
+ [-x|-?|-h]
    
    Each option is optional but /d and /t must be used together.
    
    Example:
    $script /c abcd /d c /t 10 /m \"Please choose from the following\"
    
    The prompt will look like the following
    Please choose from the following [a,b,C,d]?
    
    The script return code will be the index of the character chosen
    Example:
        Choices are: xyz    User Chooses x    %errorlevel% 1
        Choices are: xyz    User Chooses y    %errorlevel% 2
        Choices are: xyz    User Chooses z    %errorlevel% 3
        
        
    -h and -? show this help
    -x is a debug mode that will output the arguments you provided and
+ exit the script
    
    ";
}

# this will only be called if the Ctrl-C key command
# is pressed.  a ctrl-c or ctrl-break must exit
# with a return code of 0
sub ctrl_c_handler {
    exit 0;
}

[Athanasius]

A comment on the regexen:

# regex to add a comma after each char
# i believe you can think of it starting
# at the second character since
# ?<= means look to the left of the current
# position
# the . means to look at one character
# the () are required to capture each character
$show_choices =~ s/(?<=.)/,/g;
$show_choices =~ s/,$//g;       # remove the last comma

Actually, there is no capturing being done in the first regex; the parentheses are there only for grouping, i.e. to show where the positive look-behind assertion ends. (Try adding a $1 to the replacement part, and you will get a series of error messages beginning Use of uninitialized value $1.)

The first regex could also be written as:

$show_choices =~ s/(.)/$1,/g;

which does capture each character.

The two regexen can be combined into one using a negative look-ahead assertion:

$show_choices =~ s/(.)(?!$)/$1,/g;

See “Look-Around Assertions” under Extended Patterns in perlre.

Hope that helps,

[jwkrahn]

You don't have to capture a character at all:

$show_choices =~ s/(?<=.)(?=.)/,/g;

[onelander]

Thank you very much for the correction. It is much appreciated.

[onelander]

Code updated to reflect the suggested changes.

[Tux]

You ran into a pet peeve of mine (at least twice in presented code):

There shall be no else after leaving enclosing scope (exit, die, return, last …)

When using if … else …, the code after that is to be executed always, that is why you have if/else. If however the first part ENDs with an exit of the enclosing scope, there is no need whatsoever for the else. Removing else, the braces and the indent, make the code easier to read and maintain.

if (expression) {
    …
    exit;
    }
else {
    …
    …
    }

=>

if (expression) {
    …
    exit;
    }

…
…

See for slides from a talk here and here/here:

sub foo
{
    my $s = shift;

    if (defined $s) {

        if ($s ne "") {
            #
            # 150 lines of code
            #
            }
        else {
            die "String is empty";
            }
        }
    else {
        die "String is null";
        }
    }

=>

sub foo
{
    my $s = shift;

    unless (defined $s) {
        die "String is null";
        }

    if ($s eq "") {
        die "String is empty";
        }

    #
    # 150 lines of code
    #
    }

[onelander]

I believe I know one area you were talking about but I am not certain of the second. Removing all the comments, is this what you mean?

if ( defined $default ) {
    my $stderr;
    close STDERR;
    open(STDERR, ">", \$stderr);

    my $grabkey_thread = threads->create(\&grabkey);
    $grabkey_thread->detach();

    for ( my $i = 0; $i <= $timeout; $i++ ) {
        sleep 1;
    }
    
    my $pos = index( uc( $choices ), uc( $default ) ) + 1;
    print uc( $default ) . "\n";
    exit $pos;
    
} else {
    grabkey();
}

=>

if ( defined $default ) {

    my $stderr;
    close STDERR;
    open(STDERR, ">", \$stderr);
    
    my $grabkey_thread = threads->create(\&grabkey);
    $grabkey_thread->detach();

    for ( my $i = 0; $i <= $timeout; $i++ ) {
        sleep 1;
    }
    
    my $pos = index( uc( $choices ), uc( $default ) ) + 1;
    print uc( $default ) . "\n";
    exit $pos;
    
}

grabkey();

[Tux]

yes, you caught both

It is a bit of a shame you edited the original posted code, as now "new" readers will not see the changes you made based on the comments you got, and the comments now make no sense at all (for those people).

As you learn from perlmonks, readers that stumble on this post no wdo not learn from the code changes. (FWIW By learning from changes I do not imply that all changes are always correct, but discussion about them makes you take desicions that are more thought-through.

[onelander]

Thanks for the tip too. Being able to write better code is one reason I enjoy this site.

[onelander]

I found the two areas you were talking about and updated the code to reflect those changes.

[VinsWorldcom]

Windows 7 has choice.exe that should run fine in x64 environments:

VinsWorldcom@C:\Users\VinsWorldcom> ver

Microsoft Windows [Version 6.1.7601]

VinsWorldcom@C:\Users\VinsWorldcom> where choice
C:\Windows\System32\choice.exe

[onelander]

Curious, is that Windows 7 computer a 64bit version? I know the 32bit version has it. Either way, thank you very much. This gives me something to look into.

[BrowserUk]

All versions of Windows NT/XP/Vista/Windows7; 32- & 64-bit have choice.exe.