Rainy Day Template Fun

Randal L. Schwartz

I grew up (and still reside) in Oregon, well known for having rain nearly all parts of the year. However, the months around April seem to have been particularly wet, and as a child, I'd often end up doing “indoor” activities during the heaviest rainy days.

One of the things I remember doing was playing a game (whose name I won't mention so as not to infringe on any trademark) that consisted of two people taking turns asking each other for various items, like “a noun” or “a verb ending in -ed”. Besides teaching us the parts of speech, it also delighted us to know that we had constructed a story by filling in the blanks of a complete story in an unexpected way. Of course, as we got more creative with the answers, we got better stories.

Now, what does this have to do with Perl? Well, I often see questions online about “how do I create a fill-in-the-blank template”? For general applications, the answer is “go see one of the templating solutions in the CPAN”. That is, go to http://search.cpan.org and enter template in the search box on the left. You'll see a dozen or two different ways to take advantage of existing code.

For simple problems, though, an ad hoc approach may be best. Our story creator software is simple enough that we can code it from scratch, also to show there's nothing magic about the approach. Let's start with a simple template:

The [person] went to the [place].

How do we turn [person] into the question “give me a person” and put the response back in the string? Well, something like this will work:

$_ = "The [person] went to the [place].";
s/\[(.*?)\]/&process($1)/eg;
sub process {
  print "give me a $_[0]: ";
  chomp(my $response = <STDIN>);
  $response;
}
print;

What we're doing here is going through the value of $_ with the global substitution. Each time a bracketed item is found, we'll evaluate the right side of the substitution as Perl code. In this case, it'll be an invocation of the process subroutine, passing $1 as the parameter. The subroutine takes the input parameter to create a prompt, then reads my response from the result. The return value of the subroutine becomes the replacement value for the bracketed item. Note the /eg on the end of the substitution: for this, we get the right side as evaluated code, with the substitution executed globally.

To get a little more flexible, we might also allow multiple words, including newlines, inside the brackets. That'd look like this:

{ local $/; $_ = <DATA> }
s/\[(.*?)\]/&process($1)/egs;
sub process {
  my $prompt = shift;
  $prompt =~ s/\s+/ /g;
  print "give me a $prompt: ";
  chomp(my $response = <STDIN>);
  $response;
}
print;
__END__
The [sad person] went to the [fun
place to go].

Now, we'll get the prompts like so:

give me a sad person: ____
give me a fun place to go: ____

And the right values will be filled in appropriately. The addition of the s suffix to the substitution operator enables . to match an embedded newline. Inside the subroutine, we crunch all embedded newlines into single spaces. Also note that we're fetching the template from the DATA filehandle, which begins at the end of the program immediately after the __END__ marker.

Now, let's look at a further complication. Suppose I want to ask the questions in an order different from how they'll be used in the story. That makes it more fun, because having an unexpected response to the ordering is often an interesting surprise.

To do this, I'll need a way of asking a prompt, but storing the value instead of immediately substituting it. Let's introduce a variable syntax, like so:

[person=person]
[place1=nearby place]
[place2=far away place]
[$person] went to [$place1], and then to [$place2].
[$person] was [emotion after a long trip].

Here, I'm expecting that we'll ask for a person, two places, then do some substitution, then ask for an emotion and substitute that directly. Note that the person is used twice.

We'll say that a variable has to be a Perl identifier (alphas, numerics, and underscores), conveniently matched by \w in a regular expression. So, brackets can now contain three things, and the processing subroutine has to distinguish three cases: (1) a simple prompt, to be substituted, (2) a variable to be prompted for, and remembered, or (3) a reference to a previously established variable.

We'll hold the variable values in a hash called %value. So, process will look like this:

sub process {
  my $thing = shift;
  if ($thing =~ /^\$(\w+)$/) { # variable reference
    return $value{$1};
  }

So far, we'll take the value between the brackets (coming in as $thing), and if it's a dollar followed by a variable name, then we'll return its current value. Next, we fix the embedded newlines, in case the starting bracket is on a different line from the ending bracket:

  $thing =~ s/\s+/ /g;  # handle wrapping

And then we'll handle the “defining” case:

  my $variable;
  $variable = $1 if $thing =~ s/^(\w+)=//; 

    # may be undef

At this point, $variable is either undef or the name of a variable to define and remember. What's left in $thing is now the prompt to issue, and that comes next:

  print "Give me a", $thing =~ /^[aeiou]/i ? 
    "n " : " ", $thing, ": ";

Note the extra logic here to make it “an apple” or “a carrot” when given “apple” and “carrot”. Finally, let's finish up the prompting:

  chomp(my $response = <STDIN>);
  if (defined $variable) {
    $value{$variable} = $response;
    return "";
  }
  return $response;
}

Note that if it's a bracketed item defining a variable, no value is returned. If you'd rather make a definition also be an invocation automatically, you can leave out the return "". Either way, it's nice.

So, we've now got some nice code, and it works against our example earlier. If you run this code, however, you may notice that there are some extra newlines in the output. Why is this so? Well, the definition lines:

[person=person]
[place1=nearby place]
[place2=far away place]

are in fact replaced with “nothing” followed by newline, three times. (If you've hacked m4 before, you may recall this as the need for frequent dnl() constructs in your input.) That's a bit messy, so let's special-case that. If a line consists entirely of a bracketed item, the trailing newline is automatically swallowed up. Not tough, but we have to get a bit messy:

s<^\[([^]]+)\]\s*\n|\[([^]]+)\]>
 {&process(defined $1 ? $1 : $2)}meg;

Here, I again have effectively an s/old/new/eg operation, split over two lines, using alternate delimiters. Note that the pattern to be matched consists of two separate regular expressions joined by the vertical bar:

^\[([^]]+)\]\s*\n

and

\[([^]]+)\]

The latter should be familiar... it's similar to what we've been using all along. The first one is a match for an entire line consisting only of the bracketed item, so that we can also scarf down the newline.

The right-side replacement text, as code, becomes slightly more complicated, because we need to use either $1 or $2, depending on which item on the left matched. The defined() took care of that. And finally, the substitution uses the additional suffix of m, meaning that ^ in the regular expression matches any embedded newline, and coincidentally spelling meg, because I watched a Meg Ryan movie last night on DVD.

One final nicety: we have no way to include a literal left or right bracket in the text, so let's let [LEFT] and [RIGHT] stand for those. That'll work by including these lines early in process:

  return "[" if $thing eq "LEFT";
  return "]" if $thing eq "RIGHT";

So, let's put it all together. And as a way of demonstrating how easy it is to get stories to feed into this, I found an archive with several “fill in the blank” stories at http://www.mit.edu/storyfun/, and stole the following story to tack onto the end of the program:

{ local $/; $_ = <DATA> }
s/^\[([^]]+)\]\s*\n|\[([^]]+)\]/&process(defined $1 ? $1 : $2)/meg;
sub process {
  my $thing = shift;
  return "[" if $thing eq "LEFT";
  return "]" if $thing eq "RIGHT";
  if ($thing =~ /^\$(\w+)$/) { # variable reference
    return $value{$1};
  }
  $thing =~ s/\s+/ /g;  # handle wrapping
  my $variable;
  $variable = $1 if $thing =~ s/^(\w+)=//; # may be undef
  print "Give me a", $thing =~ /^[aeiou]/i ? "n " : " ", $thing, ": ";
  chomp(my $response = <STDIN>);
  if (defined $variable) {
    $value{$variable} = $response;
    return "";
  }
  return $response;
}
print;

__END__
[LEFT]... from http://www.mit.edu/storyfun/I_went_for_a_walk[RIGHT]
[adj1=adjective]
[place=place]
[verbed=verb (ending in -ed)]
[adj2=adjective]
[nouns=plural noun]
[plants=plural plant]
[adj3=adjective]
[adj4=adjective]
[adj5=adjective]
[noun=noun]
[verbing=verb (ending in -ing)]
[verb_past=verb (past tense)]
[animals=plural animal]

[your name] went for a walk

Yesterday, I went out walking, and somehow ended up in [$place]. I saw
[$plants] and [$animals] -- it was [$adj2]! But I started getting
[$adj5] hungry, and needed to find my way home. But no matter where I
[$verb_past], I couldn't see the path. I decided to go around the
[$adj1] [$noun] up ahead, and discovered that it led back home! I was
[$verbed]. At dinner, when I told my [$adj3] story, my [$nouns] looked
at me with [$adj4] expressions. Then they forbade me from ever
[$verbing] again.

So, never again will you need to worry about those rainy days, or whenever you need to have “fill in the blank” templates. Perl can help you pass the time away, and do those tasks more efficiently. Until next time, enjoy!

About the Author

Randal L. Schwartz is a two-decade veteran of the software industry -- skilled in software design, system administration, security, technical writing, and training. He has coauthored the “must-have” standards: Programming Perl, Learning Perl, Learning Perl for Win32 Systems, and Effective Perl Programming, as well as writing regular columns for WebTechniques and Unix Review magazines. He's also a frequent contributor to the Perl newsgroups, and has moderated comp.lang.perl.announce since its inception. His offbeat humor and technical mastery have reached legendary proportions worldwide (but he probably started some of those legends himself). Randal's desire to give back to the Perl community inspired him to help create and provide initial funding for The Perl Institute (perl.org). He is also a founding board member of the Perl Mongers (pm.org), the worldwide association of “Perl users groups”. Since 1985, Randal has owned and operated Stonehenge Consulting Services, Inc.