Beefy Boxes and Bandwidth Generously Provided by pair Networks
Your skill will accomplish
what the force of many cannot
 
PerlMonks  

Comment on

( #3333=superdoc: print w/ replies, xml ) Need Help??

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; }


In reply to Perl replacement for choice.com by onelander

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
  • Log In?
    Username:
    Password:

    What's my password?
    Create A New User
    Chatterbox?
    and the web crawler heard nothing...

    How do I use this? | Other CB clients
    Other Users?
    Others exploiting the Monastery: (8)
    As of 2015-07-04 18:05 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?

      The top three priorities of my open tasks are (in descending order of likelihood to be worked on) ...









      Results (60 votes), past polls