Beefy Boxes and Bandwidth Generously Provided by pair Networks
Pathologically Eclectic Rubbish Lister

Perl replacement for

by onelander (Sexton)
on Mar 02, 2013 at 04:48 UTC ( #1021383=CUFP: print w/replies, xml ) Need Help??

After running into the incompatibility of the 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 # does not work on Win 64bit # This script should provide the same funcationality # as the existing usage of 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; }

Replies are listed 'Best First'.
Re: Perl replacement for
by Athanasius (Chancellor) on Mar 02, 2013 at 07:21 UTC

    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,

    Athanasius <°(((><contra mundum Iustus alius egestas vitae, eros Piratica,

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

      $show_choices =~ s/(?<=.)(?=.)/,/g;
      Thank you very much for the correction. It is much appreciated.
      Code updated to reflect the suggested changes.
Re: Perl replacement for
by Tux (Abbot) on Mar 03, 2013 at 11:03 UTC

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

    Enjoy, Have FUN! H.Merijn

      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();

        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.

        Enjoy, Have FUN! H.Merijn
      Thanks for the tip too. Being able to write better code is one reason I enjoy this site.

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

Re: Perl replacement for
by VinsWorldcom (Parson) on Mar 02, 2013 at 14:51 UTC

    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
      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.

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

        With the rise and rise of 'Social' network sites: 'Computers are making people easier to use everyday'
        Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.
        "Science is about questioning the status quo. Questioning authority".
        In the absence of evidence, opinion is indistinguishable from prejudice.

Log In?

What's my password?
Create A New User
Node Status?
node history
Node Type: CUFP [id://1021383]
Approved by kcott
Front-paged by Arunbear
and all is quiet...

How do I use this? | Other CB clients
Other Users?
Others wandering the Monastery: (5)
As of 2018-04-26 17:30 GMT
Find Nodes?
    Voting Booth?