s/// with asterisks and other chars

froglover has asked for the wisdom of the Perl Monks concerning the following question:

Another day has passed and much time was wasted trying to figure out why the following doesn't substitute the emoticons properly.

general:
This is a chatterbox with a username and message field, just like on PM. I want to add emoticons to the messages so things like :P and *tongue* will display an image. This is the only part giving me trouble and I can't for the life of me figure out why it won't catch on and add the emoticons.

Test prints were done with all the data. My test printout of the emoticons is as follows

:)
:(
:P
:O
*hug*
*flower*
;)
*evil*
*love*
*yawn*
*test*
*conf*
[download]

That's not what I expect to be in the emoticons list, that's the printout.

$face contains: *yawn*, :P, *conf*..
$name is the name: tongue, yawn..
$location is the full http://www url of the image

When the script is run, it prints out the face of each emoticon per message that it should be finding just to make sure it's looping over everything. It is. It refuses to make the s/// to the message though. Emoticons can happen ANYWHERE in the message.

Below is 90% of the complete code. Some of it is irrelevent but it may give you an idea of what the script is doing. Can anyone come up with an idea why I can swear filter but NOT emoticon filter?

if (param())
{
   my $username = param("name");
   my $message  = param("message");
   my $time     = localtime();
   my $ip       = $ENV{REMOTE_ADDR};


   ###
   # add their information to the db
   ###
   my $data = qq(INSERT INTO chat (username, ip, date, message) VALUES
+ (?,?,?,?));
   my $sth = $dbh->prepare($data);
   $sth->execute("$username","$ip","$time","$message") or die $dbh->er
+rstr;

   print "success!<p>";

}

#foreach (@a) { print "$_<br>"; }

####
# print chat
####

my $data = qq(SELECT id, username, ip, date, message FROM chat ORDER B
+Y id DESC LIMIT 10);

my $sth = $dbh->prepare($data);
$sth->execute() or die $dbh->errstr;

my ($id, $username, $ip, $date, $message);
$sth->bind_columns(\$id, \$username, \$ip, \$date, \$message);


######
# Because we need to reverse our SELECT we need to store it in @keep
######
my @keep;
my @keep_after_swear_words;
while ($sth->fetch)
{
  push(@keep, "$username<!!>$message<!!>$date<!!>$ip");
}

#######
# connecting to the DB again so we can filter swear words
#######
my $data = qq(SELECT id, word FROM swears);
my $sth = $dbh->prepare($data);
$sth->execute() or die $dbh->errstr;

my ($id, $badword);
$sth->bind_columns(\$id, \$badword);

foreach my $line (reverse @keep)
{
   my ($username, $message, $date, $ip) = split(/<!!>/, $line);
         #print "user: $username<br> message: $message<br> date: $date
+<br> ip: $ip<br><br>";
   while ($sth->fetch)
   {
      push (@badwords, $badword);
   }
     #print "message: $message<br>";
     #push(@keep_after_swear_words, "$username<!!>$message<!!>$date<!!
+>$ip");
}

foreach my $line (@keep)
{
  $line =~ s/\b$_\b/ **** /gi for @badwords;
}


####################
# connecting to the DB again so we can filter emoticons
####################
my $data = qq(SELECT id, name, location, face FROM emoticons);
my $sth = $dbh->prepare($data);
$sth->execute() or die $dbh->errstr;

my ($id, $name, $location, $face);
$sth->bind_columns(\$id, \$name, \$location, \$face);
while($sth->fetch)
{
  push (@emoticons, "$name<!!>$location<!!>$face");
}


foreach my $line (reverse @keep)
{
   my ($username, $message, $date, $ip) = split(/<!!>/, $line);

   foreach my $emoticon (@emoticons)
   {
      my ($name, $location, $face) = split(/<!!>/, $emoticon);
      if ($face)
      {
        $message =~ s/\b\Q$face\E\b/ <img src="\Q$location\E" alt="\Q$
+name\E"> /gi;
        print "<b>$face</b><br>";
      }
      #message =~ s/$face/ <img src="$location" alt="$name"> /gi;  
      # print "$emoticon<br>";
   }

   if ($message =~ m|^/me|i)
   {
      $message =~ s|^/me||i;
      print qq(<b><i><a href="#" TITLE="Message sent on $date by $ip">
+$username</a></i></b> <i>$message</i><br>);
   }
   else
   {
      print qq(<b><a href="#" TITLE="Message sent on $date by $ip">$us
+ername</a>:</b> $message<br>);
   }
}
[download]

2005-11-02 Retitled by planetscape, as per Monastery guidelines
Original title: 's/// with asterics and other chars'

Comment on s/// with asterisks and other chars Select or Download Code

Replies are listed 'Best First'.
Re: s/// with asterisks and other chars by Roy Johnson (Monsignor) on Nov 01, 2005 at 19:33 UTC
The faces are not at word boundaries. You should probably remove the `\b`s from that expression. Unlike badwords, emoticons are not words. Things like " ``" are not word boundaries (where letters and non-letters meet). Caution:* Contents may have been coded under pressure.	[reply] [d/l] [select]
Re^2: s/// with asterisks and other chars by froglover (Initiate) on Nov 01, 2005 at 19:40 UTC
I admit, I did overlook the \b but that wasn't the only problem. I removed them only leaving \Q$var\E and it's not catching on yet. Thank you.	[reply]
Re^3: s/// with asterisks and other chars by Roy Johnson (Monsignor) on Nov 01, 2005 at 20:34 UTC
This little excerpt should be a fair proof that the basic idea works: `my $message = 'one :-* smiley'; my ($face, $location, $name) = (':-', 'here', 'smoochie'); $message =~ s/\Q$face\E/ <img src="$location" alt="$name"> /gi; print $message, "\n";` [download] Now what you need to do is figure out how your situation differs. That means putting in print statements so you can see what's really going on every step of the way, and then examining the output for what wasn't what you expected it to be. Start by replacing your if-face-block with something like `if ($face) { if ($message =~ s/\Q$face\E/ <img src="$location" alt="$name"> + /gi) { print "Substituted for [$face] in [$message]\n"; } else { print "[$face] was not found in [$message]\n"; } } else { print "$face was not true!\n"; }` [download] That way, you get a definite indication of what path things took and what your variables were. Something will probably jump out at you. Caution:* Contents may have been coded under pressure.	[reply] [d/l] [select]
Re: s/// with asterisks and other chars by GrandFather (Saint) on Nov 01, 2005 at 19:46 UTC
If I use this code: use warnings; use strict; my @emoticons = ('fred::there:::P', 'fred::there::tounge'); while (my $line = <DATA>) { my ($username, $message, $date, $ip) = split(/<!!>/, $line); foreach my $emoticon (@emoticons) { my ($name, $location, $face) = split(/::/, $emoticon); $message =~ s\|(?<!\S)\Q$face\E(?!\S)\| <img src="$location" alt=" +$name"> \|gi; } if ($message =~ m\|^/me\|i) { $message =~ s\|^/me\|\|i; print qq(<b><i><a href="#" TITLE="Message sent on $date by $ip"> +$username</a></i></b> <i>$message</i><br>); } else { print qq(<b><a href="#" TITLE="Message sent on $date by $ip">$us +ername</a>:</b> $message<br>); } } __DATA__ success!<p>test<!!>yawn test yawn<!!>Mon Oct 31 15:15:12 2005<!!>2 +4.118.232.47 test<!!>yawn test yawn<!!>Mon Oct 31 15:07:12 2005<!!>24.118.232.4 +7 test<!!>hi there :)<!!>Mon Oct 31 14:48:59 2005<!!>24.118.232.47 admin<!!>hi :P<!!>Mon Oct 31 14:37:51 2005<!!>24.118.232.47 admin<!!> ** head<!!>Mon Oct 31 10:01:33 2005<!!>24.118.232.47 admin<!!>/me test<!!>Mon Oct 31 08:57:39 2005<!!>24.118.232.47 test<!!> monkey<!!>Mon Oct 31 08:39:54 2005<!!>24.118.232.47 test<!!> monkey<!!>Mon Oct 31 08:20:22 2005<!!>24.118.232.47 swear test<!!> you ** hole<!!>Sun Oct 30 12:06:50 2005<!!>24 +.118.232.47 [download] I get this output: <b><a href="#" TITLE="Message sent on Mon Oct 31 15:15:12 2005 by 24.1 +18.232.47 ">success!<p>test</a>:</b> yawn test yawn<br><b><a href="#" TITLE= +"Message sent on Mon Oct 31 15:07:12 2005 by 24.118.232.47 ">test</a>:</b> yawn test yawn<br><b><a href="#" TITLE="Message se +nt on Mon Oct 31 14:48:59 2005 by 24.118.232.47 ">test</a>:</b> hi there :)<br><b><a href="#" TITLE="Message sent on M +on Oct 31 14:37:51 2005 by 24.118.232.47 ">admin</a>:</b> hi <img src="there" alt="fred"> <br><b><a href="#" T +ITLE="Message sent on Mon Oct 31 10:01:33 2005 by 24.118.232.47 ">admin</a>:</b> ** head<br><b><i><a href="#" TITLE="Message sent +on Mon Oct 31 08:57:39 2005 by 24.118.232.47 ">admin</a></i></b> <i> test</i><br><b><a href="#" TITLE="Message sent + on Mon Oct 31 08:39:54 2005 by 24.118.232.47 ">test</a>:</b> monkey<br><b><a href="#" TITLE="Message sent on + Mon Oct 31 08:20:22 2005 by 24.118.232.47 ">test</a>:</b> monkey<br><b><a href="#" TITLE="Message sent on + Sun Oct 30 12:06:50 2005 by 24.118.232.47 ">swear test</a>:</b> you ** hole<br> [download] Note in particular that `my @emoticons = ('fred::there:::P', 'fred::there::tounge');` If that is not were your problem is, edit my example (derived from your scratch pad code) to show the problem. Perl is Huffman encoded by design.	[reply] [d/l] [select]
Re: s/// with asterisks and other chars by GrandFather (Saint) on Nov 01, 2005 at 19:51 UTC
~~Ah, got it. Change your splits to use `/\Q<!!>\E/`.~~ Update: I didn't got it :) Perl is Huffman encoded by design.	[reply] [d/l]