use Parse::RecDescent;
use strict;
use Data::Dumper;


sub is_valid_color
{
    my $color_to_test = shift();
    return $color_to_test if ($color_to_test =~ /red|green|blue/);

    return undef;
}


my $grammar = << 'GRAMMAR';

start :    order(s)
order: quantity color product
       {
       $return = {
           quant => $item{'quantity'},
           color => $item{'color'},
           item => $item{'product'},
       };
       }

quantity: /\d+/
color:    /\w+/
        {
           $return = main::is_valid_color($item[1]);
        }
          | <error>
          
product: 'pencil'
         | 'pen'


GRAMMAR


my $text;

$text = "1 red pencil\n";
$text .= "2 blue pencil\n";
$text .= "4 green pen\n";

my $parser = new Parse::RecDescent($grammar) || die "Bad Grammar";

my $product_list = $parser->start($text) || die "Bad Syntax";

print Dumper($product_list);
[download]

$VAR1 = [
          {
            'color' => 'red',
            'item' => 'pencil',
            'quant' => '1'
          },
          {
            'color' => 'blue',
            'item' => 'pencil',
            'quant' => '2'
          },
          {
            'color' => 'green',
            'item' => 'pen',
            'quant' => '4'
          }
        ];
[download]

Can you try running that $text .= "5 purple pen\n"; added? I don't think you'll get an error (although the colour will be 'undef' in the result). I can't verify this for myself since I don't have this module.

Update: Nevermind, I see something in the docs I didn't see before, concernign the returning values of actions.. I think the | <error> is unnecessary, btw. That's what confused me.

It will die with a bad syntax error I believe. There is more error handling that can be done I just didn't do it.

I think the error tag will give you a little more detail on where the error occured etc. I didn't have a ton of time to play around with it.

The real problem is deciding where the colour ends, since you want two word colours. (You mentioned 'burnt umber' as possibly being a valid colour.) What follows is a grammar that allows colours to be quoted. It's good practive to seperate token rules from the grammar rules.

--
grammar:

# grammar:
order:    quantity color item
quantity: number
color:    id | qstring
item:     id

# tokens:
number:  /\d+/
id:      /[a-zA-Z][-_a-zA-Z0-9]*/
qstring: /"(?:\\["\\]|[^"\\])*"/
            { $return = unquote($item[1]); }
       | /'(?:\\['\\]|[^'\\])*'/
            { $return = unquote($item[1]); }

--
helper (non-grammar) code:

sub unquote {
   local $_ = $_[0];
   s/^['"]//;
   s/['"]$//;
   s/\\(.)/\1/g;
   return $_;
}

--
[download]

Checking whether the colour is legit or not is usually done after the parsing is done, or at least, when the tokenizing is done. That allows you to find multiple errors while running the compiler only once. For example, if you've read Larry Walls's Apocolypses, you may have noticed he makes a few allusions to items that shouldn't be verified by the parser for just this reason. What follows is a piece of code that introduces validation of colours:

--
helper (non-grammar) code:

my @COLORS = (
   'red'
   'green'
   'blue'
   'cyan'
   'magenta'
   'burnt umber'
);

my %COLORS;
{
  my $idx = 0;
  %COLORS = map { $_ => $idx++ } @COLORS;
}

sub unquote {
   local $_ = $_[0];
   s/^['"]//;
   s/['"]$//;
   s/\\(.)/\1/g;
   return $_;
}

my $error = 0;

... parse ...

die("Validation errors were found.\n") if ($error);

--
grammar:

# grammar:
order:    quantity color item
quantity: number
color:    id | qstring
             { 
                $return = $COLORS{$item[1]};
# Uncomment the following if you want
# to have multiple errors listed.
#                unless (defined($return))
#                {
#                   warn("Line $thisline: Invalid color.\n");
#                   $error = 1;
#                   $return = undef;
#                }
#                1;
             }
item:     id
             { 
                ($return) = $item[1] =~ /^(pen|pencil)$/;
# Uncomment the following if you want
# to have multiple errors listed.
#                unless (defined($return))
#                {
#                   warn("Line $thisline: Invalid item.\n");
#                   $error = 1;
#                   $return = undef;
#                }
#                1;
             }

# tokens:
number:  /\d+/
id:      /[a-zA-Z][-_a-zA-Z0-9]*/
qstring: /"(?:\\["\\]|[^"\\])*"/
            { $return = unquote($item[1]); }
       | /'(?:\\['\\]|[^'\\])*'/
            { $return = unquote($item[1]); }

--
[download]

I don't have any experience with Parse::RecDescent, but couldn't you just use the array as the basis to generate a grammar rule? For example:

    my @colors = qw(red green blue);
    my $rule = "color: " . join " | ", map "'$_'", @colors;
[download]

use Parse::RecDescent;

my @colors = ('periwinkle','indigo');

my $grammar = q[
    order: quantity color item
    quantity: /\d+/
    color:
    item: 'pen' | 'pencil'
];

my $parser = new Parse::RecDescent ($grammar);
$parser->Extend("color: '" . join(q['|'],@colors) . "'" );
[download]

Or cram it in the grammar...

my $grammar = q[
    order: quantity color item
    quantity: /\d+/
    color: '] . join(q['|'],@colors) . q['
    item: 'pen' | 'pencil'
];
[download]

Update: revdiablo beat me to it... note to self: type less.

Thanks to all that replied. amw1's code was helpful but didn't deal with the possibility of multiple-word color names. I like how he got the completed order into a data structure though.

ikegami's advice to seperate tokenizing and parsing was good and I will probably have to go that way soon to deal with things like "burnt umber", "lt. blk" etc. It seems it will be easier and more modular. Unfortunately I have a lot of input already in a fixed format so I can't quote the color names. I'll see if it can be changed for future input.

In the end I went with a variation on solo and revdiablo's suggestions:

color: /(??{join ("|", @colors)})/
[download]