3
\$\begingroup\$

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?

\$\endgroup\$
  • 1
    \$\begingroup\$ BTW, you probably want /^\d+$/, because just /\d+/ will match things like "foo123bar" \$\endgroup\$ – M Conrad Feb 19 '15 at 8:06
  • 1
    \$\begingroup\$ 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) \$\endgroup\$ – M Conrad Feb 24 '15 at 7:37
  • \$\begingroup\$ @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. \$\endgroup\$ – tjwrona1992 Feb 24 '15 at 13:41
2
\$\begingroup\$

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) {
    ...
  }
  ...
}
\$\endgroup\$
  • \$\begingroup\$ 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! \$\endgroup\$ – tjwrona1992 Dec 2 '15 at 13:57
  • \$\begingroup\$ Moo is actually a simplified version of Moose, the purpose being to reduce the number of dependencies on other modules and the startup time. \$\endgroup\$ – M Conrad Dec 22 '15 at 3:40

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.