perl: need help making my program less clumsy

Question

I'm brand new to perl, and just know there are 100 ways to do this. If you like to teach (or just show off your perl prowess), I love to learn.

Basically, I'm looking for a cleaner way to generate and execute a set of actions based on input that I collect from the end user via a dynamically generated menu. I started off using a hash which made it easy to associate keys and values, but then displaying the values in a menu and then figuring out what value the user picked and correlating that with a key got ugly...

#!/usr/local/bin/perl5.8

use strict ;
use warnings ;
use English ;

package foo ;

sub main {
  my $actions = &collect_input() ;
  if ($actions eq 1) {
    return 1; # nothing to do
  }
  else {
    print qq(\$actions is "$actions"), "\n" ;
    # Do some stuff here based on what's in $actions, which has to be parsed
  }
}

sub collect_input {
  # Goal is for this function to dynamically generate a menu
  # based on some criteria. For sake of example, let's assume
  # that works fine and sets some variables to 0 or 1. Also assume
  # that $foo must always be in the menu if it's 0

  # my ($foo, $bar, $baz) = &check_criteria() ;
  my $foo = 1 ;
  my $bar = 0 ;
  my $baz = 0 ;

  # OK, this is my crappy solution. I'm sure someone with more
  # experience than my 1 month can show me a much less clumsy
  # solution using a hash or array of arrays, maybe?

  # secret decoder ring:
  #   ABC = do foo, bar, baz
  #   AB  = do foo, bar
  #   AC  = do foo, baz
  #   BC  = do bar, baz
  #   B   = do bar
  #   C   = do baz
  #   Q   = do nothing
  return 1 if (($foo) && ($bar) && ($baz)) ; # Nothing to do, all are true
  my @array ;
  push @array, qq(ABC:Do A, B, C) if ((!$foo) && (!$bar) && (!$baz)) ;
  push @array, qq(AB:Do A, B) if ((!$foo) && (!$bar)) ;
  push @array, qq(AC:Do A, C) if ((!$foo) && (!$baz)) ;
  push @array, qq(BC:Do B, C) if (($foo) && (!$bar) && (!$baz)) ;
  push @array, qq(B:Do B) if (($foo) && (!$bar)) ;
  push @array, qq(C:Do C) if (($foo) && (!$baz)) ;
  push @array, qq(Q:Do nothing) ;

  print "Choose:\n\n" ;

  # print a menu, but don't show the secret codes
  # all this string manipulation seems like a hack
  {
    my $i = 0 ;
    print ++$i, ") ", ((split(':',$_))[-1]), "\n" for @array ;
  }

  my $secret_code = undef;
  while (1) {
    print "\nSelection :> " ;
    chomp(my $reply = <STDIN>) ;
    next unless $reply =~ /^\d+$/ ; # proceed if we get a digit
    next if $reply eq 0 ; # 0 - 0 = 0
    if (defined $array[$reply-1]) { # process selection if it's valid
      $secret_code = ((split(':',$array[$reply-1]))[-2]) ;
      last ;
    }
  }
  if (defined $secret_code) {
    return "$secret_code" ;
  }
  else {
    return "Q" ;
  }
}

Output based on foo=1, bar=0, baz=0:

Choose:

1) Do B, C
2) Do B
3) Do C
4) Do nothing

Selection :> 1
$actions is "BC"

Answer 1

Ignoring $foo, $bar, and $baz, it's easy to recapture "ABC" from "Do A, B, C" and vice versa, so you can just populate @array with the shorter strings.

Then, you can do something like the following:

print "Choose:\n\n";

#iterate through the array, going from, for example, 
#"ABC" to "Do A, B, C" via join and split.
#split("",$array[$_]) takes the particular string in the array (eg "ABC"),
#and returns the array of letters (ie what you get when you match the empty regex of //).
#This is then passed to the join function which puts a ", " between each letter of 
#the returned array from the split function.

foreach(0..$#array)
{
  print ($_+1) . ") " . "Do " . join(", ",split(//,$array[$_])) . "\n";
}

print "\n\nSelection :>";

while(1)
{
  chomp(my $response=<STDIN>);

  #Note:  If you were to upgrade your version of Perl, 
  #you could use the smart match operator 
  #(http://perldoc.perl.org/perlsyn.html#Smart-matching-in-detail)
  #Then, you could merely test this via if($response~~1..scalar(@array))
  if($response=~/^[1-9]\d*$/ and $response<=scalar(@array))
  {
    print "You chose " . $array[$response-1] . "\n";
    last;
  }
  else
  {
    print "Uhhhhhh, no.  Try again.\n";
  }
}

Answer 2

use strict;
use warnings;
use Tie::IxHash;

{   package Tie::IxHash; 

    sub pairs { 
        my $self = shift;
        return map { [ $_ => $self->FETCH( $_ ) ] } $self->Keys; 
    }
}

my $menu = Tie::IxHash->new( 
    ABC => 'do foo, bar, baz'
  , AB  => 'do foo, bar'
  , AC  => 'do foo, baz'
  , BC  => 'do bar, baz'
  , B   => 'do bar'
  , C   => 'do baz'
  , Q   => ''
  );


sub get_input { 
    my $prompt
        = join( 
          "\n"
        , "Choose:\n"
        , ( map { sprintf "%-3s ) %s", ( $_->[0], $_->[1] || 'do nothing' ) } $menu->pairs )
        , "\nSelection :> "
        );
    while ( 1 ) { 
        print $prompt;
        my ( $choice ) = <> =~ /^\s*(\S.*)\s*$/;
        next unless defined( my $res = $menu->FETCH( uc $choice ));
        return $res || 'Q';
    }
}

my $response = get_input();
print "You chose to $response\n" if $response;