Building a Simple Menu With Perl

Question

I wrote a Perl script to implement a simple menu where you can call subroutines for each menu option. I created a Menu class that can be used to create new menus and a print method that will start the menu.

Is there any way I could simplify this?

# Menu.pm
#!/usr/bin/perl
package Menu;
use strict;
use warnings;
# Menu constructor
sub new {
 # Unpack input arguments
 my $class = shift;
 my (%args) = @_;
 my $title = $args{title};
 my $choices_ref = $args{choices};
 my $noexit = $args{noexit};
 # Bless the menu object
 my $self = bless {
 title => $title,
 choices => $choices_ref,
 noexit => $noexit,
 }, $class;
 return $self;
}
# Print the menu
sub print {
 # Unpack input arguments
 my $self = shift;
 my $title = $self->{title };
 my @choices = @{$self->{choices}};
 my $noexit = $self->{noexit };
 # Print menu
 for (;;) {
 # Clear the screen
 system 'cls';
 # Print menu title
 print "========================================\n";
 print " $title\n";
 print "========================================\n";
 # Print menu options
 my $counter = 0;
 for my $choice(@choices) {
 printf "%2d. %s\n", ++$counter, $choice->{text};
 }
 printf "%2d. %s\n", '0', 'Exit' unless $noexit;
 print "\n?: ";
 # Get user input
 chomp (my $input = <STDIN>);
 print "\n";
 # Process input
 if ($input =~ m/\d+/ && $input >= 1 && $input <= $counter) {
 return $choices[$input - 1]{code}->();
 } elsif ($input =~ m/\d+/ && !$input && !$noexit) {
 print "Exiting . . .\n";
 exit 0;
 } else {
 print "Invalid input.\n\n";
 system 'pause';
 }
 }
}
1;

I wrote up a quick test script to test the module:

# test.pl
#!/usr/bin/perl
use strict;
use warnings;
use Menu;
my $menu1;
my $menu2;
# define menu1 choices
my @menu1_choices = (
 { text => 'Choice1',
 code => sub { print "I did something!\n"; }},
 { text => 'Choice2',
 code => sub { print "I did something else!\n"; }},
 { text => 'Go to Menu2',
 code => sub { $menu2->print(); }},
);
# define menu2 choices
my @menu2_choices = (
 { text => 'Choice1',
 code => sub { print "I did something in menu 2!\n"; }},
 { text => 'Choice2',
 code => sub { print "I did something else in menu 2!\n"; }},
 { text => 'Go to Menu1',
 code => sub { $menu1->print(); }},
);
# Build menu1
$menu1 = Menu->new(
 title => 'Menu1',
 choices => \@menu1_choices,
);
# Build menu2
$menu2 = Menu->new(
 title => 'Menu2',
 choices => \@menu2_choices,
);
# Print menu1
$menu1->print();

I feel like there must be a simpler, more elegant (or maybe just more pleasing to the eye) way to pass in the menu options rather than using an array of hashes, but I can't seem to figure out any better way to do it.

---

EDIT:

After some careful code reworking and making the menu items into their own object I was able to create a much cleaner interface for creating menus. Here is my new code:

This is a test script showing an example of how to use the modules to build menus.

# test.pl
#!/usr/bin/perl
# Always use these
use strict;
use warnings;
# Other use statements
use Menu;
# Create a menu object
my $menu = Menu->new();
# Add a menu item
$menu->add(
 'Test' => sub { print "This is a test\n"; system 'pause'; },
 'Test2' => sub { print "This is a test2\n"; system 'pause'; },
 'Test3' => sub { print "This is a test3\n"; system 'pause'; },
);
# Allow the user to exit directly from the menu
$menu->exit(1);
# Disable a menu item
$menu->disable('Test2');
$menu->print();
# Do not allow the user to exit directly from the menu
$menu->exit(0);
# Enable a menu item
$menu->enable('Test2');
$menu->print();

The Menu.pm module is used to build menu objects. These menu objects can contain multiple Menu::Item objects. The objects are stored in an array so their order is preserved.

# Menu.pm
#!/usr/bin/perl
package Menu;
# Always use these
use strict;
use warnings;
# Other use statements
use Carp;
use Menu::Item;
# Menu constructor
sub new {
 # Unpack input arguments
 my ($class, $title) = @_;
 # Define a default title
 if (!defined $title) {
 $title = 'MENU';
 }
 # Bless the Menu object
 my $self = bless {
 _title => $title,
 _items => [],
 _exit => 0,
 }, $class;
 return $self;
}
# Title accessor method
sub title {
 my ($self, $title) = @_;
 $self->{_title} = $title if defined $title;
 return $self->{_title};
}
# Items accessor method
sub items {
 my ($self, $items) = @_;
 $self->{_items} = $items if defined $items;
 return $self->{_items};
}
# Exit accessor method
sub exit {
 my ($self, $exit) = @_;
 $self->{_exit} = $exit if defined $exit;
 return $self->{_exit};
}
# Add item(s) to the menu
sub add {
 # Unpack input arguments
 my ($self, @add) = @_;
 croak 'add() requires name-action pairs' unless @add % 2 == 0;
 # Add new items
 while (@add) {
 my ($name, $action) = splice @add, 0, 2;
 # If the item already exists, remove it
 for my $index(0 .. $#{$self->{_items}}) {
 if ($name eq $self->{_items}->[$index]->name()) {
 splice @{$self->{_items}}, $index, 1;
 }
 }
 # Add the item to the end of the menu
 my $item = Menu::Item->new($name, $action);
 push @{$self->{_items}}, $item;
 }
 return 0;
}
# Remove item(s) from the menu
sub remove {
 # Unpack input arguments
 my ($self, @remove) = @_;
 # Remove items
 for my $name(@remove) {
 # If the item exists, remove it
 for my $index(0 .. $#{$self->{_items}}) {
 if ($name eq $self->{_items}->[$index]->name()) {
 splice @{$self->{_items}}, $index, 1;
 }
 }
 }
 return 0;
}
# Disable item(s)
sub disable {
 # Unpack input arguments
 my ($self, @disable) = @_;
 # Disable items
 for my $name(@disable) {
 # If the item exists, disable it
 for my $index(0 .. $#{$self->{_items}}) {
 if ($name eq $self->{_items}->[$index]->name()) {
 $self->{_items}->[$index]->active(0);
 }
 }
 }
 return 0;
}
# Enable item(s)
sub enable {
 # Unpack input arguments
 my ($self, @enable) = @_;
 # Disable items
 for my $name(@enable) {
 # If the item exists, enable it
 for my $index(0 .. $#{$self->{_items}}) {
 if ($name eq $self->{_items}->[$index]->name()) {
 $self->{_items}->[$index]->active(1);
 }
 }
 }
}
# Print the menu
sub print {
 # Unpack input arguments
 my ($self) = @_;
 # Print the menu
 for (;;) {
 system 'cls';
 # Print the title
 print "========================================\n";
 print " $self->{_title}\n";
 print "========================================\n";
 # Print menu items
 for my $index(0 .. $#{$self->{_items}}) {
 my $name = $self->{_items}->[$index]->name();
 my $active = $self->{_items}->[$index]->active();
 if ($active) {
 printf "%2d. %s\n", $index + 1, $name;
 } else {
 print "\n";
 }
 }
 printf "%2d. %s\n", 0, 'Exit' if $self->{_exit};
 # Get user input
 print "\n?: ";
 chomp (my $input = <STDIN>);
 # Process user input
 if ($input =~ m/^\d+$/ && $input > 0 && $input <= scalar @{$self->{_items}}) {
 my $action = $self->{_items}->[$input - 1]->action();
 my $active = $self->{_items}->[$input - 1]->active();
 if ($active) {
 print "\n";
 return $action->();
 }
 } elsif ($input =~ m/^\d+$/ && $input == 0 && $self->{_exit}) {
 exit 0;
 }
 # Deal with invalid input
 print "\nInvalid input.\n\n";
 system 'pause';
 }
}
1;

The Item.pm Module must be stored in a subfolder called "Menu" In order for it to be referenced properly. This module lets you create Menu::Item objects that contain a name and a subroutine reference. These objects will be what the user selects from in the menu.

# Item.pm
#!/usr/bin/perl
package Menu::Item;
# Always use these
use strict;
use warnings;
# Menu::Item constructor
sub new {
 # Unpack input arguments
 my ($class, $name, $action) = @_;
 # Bless the Menu::Item object
 my $self = bless {
 _name => $name,
 _action => $action,
 _active => 1,
 }, $class;
 return $self;
}
# Name accessor method
sub name {
 my ($self, $name) = @_;
 $self->{_name} = $name if defined $name;
 return $self->{_name};
}
# Action accessor method
sub action {
 my ($self, $action) = @_;
 $self->{_action} = $action if defined $action;
 return $self->{_action};
}
# Active accessor method
sub active {
 my ($self, $active) = @_;
 $self->{_active} = $active if defined $active;
 return $self->{_active};
}
1;

This design is a vast improvement over my previous design and makes creating menus much easier and cleaner.

Let me know what you think.

Any comments, thoughts, or improvement ideas?

• M Conrad: BTW, you probably want /^\d+$/, because just /\d+/ will match things like "foo123bar"
• M Conrad: The modifier methods are a good call. I still recommend a framework like Moo though. Saves lots of typing and gives your class a more standard implementation. For example, most module authors use a hash-key name the same as the attribute name, rather than with an underscore. (not that the underscore is wrong, just less standard)
• tjwrona: @MConrad I've seen it done both ways. Adding the underscore just seems to discourage accessing the attributes without going through the accessor method. In a way it makes them a little more "private." And unfortunately I only have access to the default modules that come with an install of ActivePerl so stuff like Moo isn't available.

Answer 1

Making perl APIs convenient is a bit of an art form, and perl gives you a lot to work with.

If you just want to streamline your code a bit, you could make a convenience method for the common cases like this:

my $menu1= Menu->new_from_list(
 "Menu1",
 "Choice1" => sub { print "I did something!\n"; },
 "Choice2" => sub { print "I did something else!\n"; },
 "Go to Menu2" => sub { $menu2->print(); },
 "noexit"
);

Then the code in new_from_list() would take those arguments and build the proper attribute tree for new():

sub new_from_list {
 my $class= shift;
 my $title= shift;
 my @choices;
 my $noexit= 0;
 while (@_ > 1) {
 push @choices, { text => shift, code => shift };
 }
 if (@_) {
 if ($_[0] eq 'noexit') {
 $noexit= 1;
 }
 else {
 die "unknown final argument to new_from_list: $_[0]"
 }
 }
 return $class->new( title => $title, choices => \@choices, noexit => $noexit );
}

The new_from_list API can't be extended easily in the future, but that's ok because it just handles a common case, and you can fall back to the normal constructor any time you need to.

Also, for simplifying the code needed to define Menu class, consider using a framework like Moo.

package Menu;
use Moo;
has title => ( is => 'rw', required => 1 );
has choices => ( is => 'rw', required => 1 );
# choices is an arrayref. This convenience method returns it as a list
sub choices_list { @{ shift->choices } }
has noexit => ( is => 'rw' );
sub print {
 my $self= shift;
 ...
 for my $choice ($self->choices_list) {
 ...
 }
 ...
}

• tjwrona: I have begun to develop Perl packages using Moose, which appears to be very similar to Moo. I would guess it's the same thing just with more features judging by the name. It definitely simplifies code writing though!
• M Conrad: Moo is actually a simplified version of Moose, the purpose being to reduce the number of dependencies on other modules and the startup time.