File Coverage

blib/lib/RiveScript.pm
Criterion Covered Total %
statement 907 1494 60.7
branch 365 682 53.5
condition 49 95 51.5
subroutine 33 50 66.0
pod 23 32 71.8
total 1377 2353 58.5


line stmt bran cond sub pod time code
1             package RiveScript;
2              
3 1     1   1627 use strict;
  1         2  
  1         30  
4 1     1   5 use warnings;
  1         1  
  1         23  
5              
6             # Version of the Perl RiveScript interpreter. This must be on a single line!
7             # See `perldoc version`
8 1     1   505 use version; our $VERSION = version->declare('v2.0.4');
  1         1832  
  1         5  
9              
10             our $SUPPORT = '2.0'; # Which RS standard we support.
11             our $basedir = (__FILE__ =~ /^(.+?)\.pm$/i ? $1 : '.');
12              
13             # Constants.
14 1     1   133 use constant RS_ERR_MATCH => "ERR: No Reply Matched";
  1         2  
  1         103  
15 1     1   7 use constant RS_ERR_REPLY => "ERR: No Reply Found";
  1         1  
  1         17693  
16              
17             # Exports
18             require Exporter;
19             our @ISA = qw(Exporter);
20             our @EXPORT_OK = qw(RS_ERR_MATCH RS_ERR_REPLY);
21             our %EXPORT_TAGS = (
22             standard => \@EXPORT_OK,
23             );
24              
25             =head1 NAME
26              
27             RiveScript - Rendering Intelligence Very Easily
28              
29             =head1 SYNOPSIS
30              
31             use RiveScript;
32              
33             # Create a new RiveScript interpreter.
34             my $rs = new RiveScript;
35              
36             # Load a directory of replies.
37             $rs->loadDirectory ("./replies");
38              
39             # Load another file.
40             $rs->loadFile ("./more_replies.rive");
41              
42             # Stream in some RiveScript code.
43             $rs->stream (q~
44             + hello bot
45             - Hello, human.
46             ~);
47              
48             # Sort all the loaded replies.
49             $rs->sortReplies;
50              
51             # Chat with the bot.
52             while (1) {
53             print "You> ";
54             chomp (my $msg = );
55             my $reply = $rs->reply ('localuser',$msg);
56             print "Bot> $reply\n";
57             }
58              
59             =head1 DESCRIPTION
60              
61             RiveScript is a simple trigger/response language primarily used for the creation
62             of chatting robots. It's designed to have an easy-to-learn syntax but provide a
63             lot of power and flexibility. For more information, visit
64             http://www.rivescript.com/
65              
66             =head1 METHODS
67              
68             =head2 GENERAL
69              
70             =over 4
71              
72             =cut
73              
74             ################################################################################
75             ## Constructor and Debug Methods ##
76             ################################################################################
77              
78             =item RiveScript new (hash %ARGS)
79              
80             Create a new instance of a RiveScript interpreter. The instance will become its
81             own "chatterbot," with its own set of responses and user variables. You can pass
82             in any global variables here. The two standard variables are:
83              
84             debug - Turns on debug mode (a LOT of information will be printed to the
85             terminal!). Default is 0 (disabled).
86             verbose - When debug mode is on, all debug output will be printed to the
87             terminal if 'verbose' is also true. The default value is 1.
88             debugfile - Optional: paired with debug mode, all debug output is also written
89             to this file name. Since debug mode prints such a large amount of
90             data, it is often more practical to have the output go to an
91             external file for later review. Default is '' (no file).
92             utf8 - Enable UTF-8 support for the RiveScript code. See the section on
93             UTF-8 support for details.
94             depth - Determines the recursion depth limit when following a trail of replies
95             that point to other replies. Default is 50.
96             strict - If this has a true value, any syntax errors detected while parsing
97             a RiveScript document will result in a fatal error. Set it to a
98             false value and only a warning will result. Default is 1.
99              
100             It's recommended that if you set any other global variables that you do so by
101             calling C or defining it within the RiveScript code. This will avoid
102             the possibility of overriding reserved globals. Currently, these variable names
103             are reserved:
104              
105             topics sorted sortsthat sortedthat thats
106             arrays subs person client bot
107             objects syntax sortlist reserved debugopts
108             frozen globals handlers objlangs
109              
110             Note: the options "verbose" and "debugfile", when provided, are noted and then
111             deleted from the root object space, so that if your RiveScript code uses variables
112             by the same values it won't conflict with the values that you passed here.
113              
114             =back
115              
116             =cut
117              
118             sub new {
119 26     26 1 15177 my $proto = shift;
120 26   50     469 my $class = ref($proto) || $proto || 'RiveScript';
121              
122 26         436 my $self = {
123             ###
124             # User configurable fields.
125             ###
126              
127             # Debugging
128             debug => 0,
129             debugopts => {
130             verbose => 1, # Print to the terminal
131             file => '', # Print to a filename
132             },
133              
134             # Unicode stuff
135             utf8 => 0, # UTF-8 support
136             unicode_punctuation => qr/[.,!?;:]/,
137              
138             # Misc.
139             depth => 50, # Recursion depth allowed.
140             strict => 1, # Strict syntax checking (causes a die)
141              
142             ###
143             # Internal fields.
144             ###
145             topics => {}, # Loaded replies under topics
146             lineage => {}, # Keep track of topics that inherit other topics
147             includes => {}, # Keep track of topics that include other topics
148             sorted => {}, # Sorted triggers
149             sortsthat => {}, # Sorted %previous's.
150             sortedthat => {}, # Sorted triggers that go with %previous's
151             thats => {}, # Reverse mapping for %previous, under topics
152             arrays => {}, # Arrays
153             subs => {}, # Substitutions
154             person => {}, # Person substitutions
155             client => {}, # User variables
156             frozen => {}, # Frozen (backed-up) user variables
157             bot => {}, # Bot variables
158             objects => {}, # Subroutines
159             syntax => {}, # Syntax tracking
160             sortlist => {}, # Sorted lists (i.e. person subs)
161             handlers => {}, # Object handlers
162             globals => {}, # Globals that conflict with reserved names go here
163             objlangs => {}, # Map object names to their programming languages
164             reserved => [ # Reserved global variable names.
165             qw(topics sorted sortsthat sortedthat thats arrays subs person
166             client bot objects syntax sortlist reserved debugopts frozen
167             handlers globals objlangs current_user)
168             ],
169             current_user => undef, # The user ID of the current chatter
170             @_,
171             };
172 26         67 bless ($self,$class);
173              
174             # Set the default object handler for Perl objects.
175             $self->setHandler (perl => sub {
176 9     9   22 my ($rs,$action,$name,$data) = @_;
177              
178             # $action will be "load" during the parsing phase, or "call"
179             # when called via .
180              
181             # Loading
182 9 100       27 if ($action eq "load") {
    50          
183             # Create a dynamic Perl subroutine.
184 4         12 my $code = "sub RSOBJ_$name {\n"
185             . $data
186             . "}";
187              
188             # Evaluate it.
189 4     1 0 305 eval ($code);
  1     1 0 3  
  1     1 0 3  
  1         4  
  1         6  
  1         5  
  1         4  
190 4 100       17 if ($@) {
191 1         5 $rs->issue("Perl object $name creation failed: $@");
192             }
193             else {
194             # Load it.
195 3         7 $rs->setSubroutine($name => \&{"RSOBJ_$name"});
  3         14  
196             }
197             }
198              
199             # Calling
200             elsif ($action eq "call") {
201             # Make sure the object exists.
202 5 100       11 if (exists $rs->{objects}->{$name}) {
203             # Call it.
204 4         7 my @args = @{$data};
  4         9  
205 4         7 my $return = &{ $rs->{objects}->{$name} } ($rs,@args);
  4         80  
206 4         29 return $return;
207             }
208             else {
209 1         3 return "[ERR: Object Not Found]";
210             }
211             }
212 26         157 });
213              
214             # See if any additional debug options were provided.
215 26 50       64 if (exists $self->{verbose}) {
216 0         0 $self->{debugopts}->{verbose} = delete $self->{verbose};
217             }
218 26 50       61 if (exists $self->{debugfile}) {
219 0         0 $self->{debugopts}->{file} = delete $self->{debugfile};
220             }
221              
222 26         212 $self->debug ("RiveScript $VERSION Initialized");
223              
224 26         69 return $self;
225             }
226              
227             sub debug {
228 3320     3320 0 5276 my ($self,$msg) = @_;
229 3320 100       6737 if ($self->{debug}) {
230             # Verbose debugging?
231 48 50       87 if ($self->{debugopts}->{verbose}) {
232 48         461 print "RiveScript: $msg\n";
233             }
234              
235             # Debugging to a file?
236 48 50       184 if (length $self->{debugopts}->{file}) {
237             # Get a real quick timestamp.
238 0         0 my @time = localtime(time());
239 0         0 my $stamp = join(":",$time[2],$time[1],$time[0]);
240 0         0 open (WRITE, ">>$self->{debugopts}->{file}");
241 0         0 print WRITE "[$stamp] RiveScript: $msg\n";
242 0         0 close (WRITE);
243             }
244             }
245             }
246              
247             sub issue {
248 3     3 0 9 my ($self,$msg) = @_;
249 3 50       10 if ($self->{debug}) {
250 0         0 print "# RiveScript::Warning: $msg\n";
251             }
252             else {
253 3         135 warn "RiveScript::Warning: $msg\n";
254             }
255             }
256              
257             ################################################################################
258             ## Parsing Methods ##
259             ################################################################################
260              
261             =head2 LOADING AND PARSING
262              
263             =over 4
264              
265             =item bool loadDirectory (string $PATH[, string @EXTS])
266              
267             Load a directory full of RiveScript documents. C<$PATH> must be a path to a
268             directory. C<@EXTS> is optionally an array containing file extensions, including
269             the dot. By default C<@EXTS> is C<('.rive', '.rs')>.
270              
271             Returns true on success, false on failure.
272              
273             =cut
274              
275             sub loadDirectory {
276 0     0 1 0 my $self = shift;
277 0   0     0 my $dir = shift || '.';
278 0   0     0 my (@exts) = @_ || ('.rive', '.rs');
279              
280 0 0       0 if (!-d $dir) {
281 0         0 $self->issue ("loadDirectory failed: $dir is not a directory!");
282 0         0 return 0;
283             }
284              
285 0         0 $self->debug ("loadDirectory: Open $dir - extensions: @exts");
286              
287              
288 0         0 opendir (my $dh, $dir);
289 0         0 foreach my $file (sort { $a cmp $b } readdir($dh)) {
  0         0  
290 0 0       0 next if $file eq '.';
291 0 0       0 next if $file eq '..';
292 0 0       0 next if $file =~ /\~$/i; # Skip backup files
293 0         0 my $goodExt = 0;
294 0         0 foreach (@exts) {
295 0         0 my $re = quotemeta($_);
296 0 0       0 $goodExt = 1 if $file =~ /$re$/;
297             }
298 0 0       0 next unless $goodExt;
299              
300 0         0 $self->debug ("loadDirectory: Read $file");
301              
302 0         0 $self->loadFile ("$dir/$file");
303             }
304 0         0 closedir ($dh);
305              
306 0         0 return 1;
307             }
308              
309              
310             =item bool loadFile (string $PATH)
311              
312             Load a single RiveScript document. C<$PATH> should be the path to a valid
313             RiveScript file. Returns true on success; false otherwise.
314              
315             =cut
316              
317             sub loadFile {
318 0     0 1 0 my ($self,$file) = @_;
319              
320 0 0       0 if (not defined $file) {
321 0         0 $self->issue ("loadFile requires a file path.");
322 0         0 return 0;
323             }
324              
325 0 0       0 if (!-f $file) {
326 0         0 $self->issue ("loadFile failed: $file is not a file!");
327 0         0 return 0;
328             }
329              
330 0         0 open (my $fh, "<:utf8", $file);
331 0         0 my @code = <$fh>;
332 0         0 close ($fh);
333 0         0 chomp @code;
334              
335             # Parse the file.
336 0         0 $self->debug ("loadFile: Parsing " . (scalar @code) . " lines from $file.");
337 0         0 $self->parse ($file,join("\n",@code));
338              
339 0         0 return 1;
340             }
341              
342              
343              
344             =item bool stream (arrayref $CODE)
345              
346             Stream RiveScript code directly into the module. This is for providing RS code
347             from within the Perl script instead of from an external file. Returns true on
348             success.
349              
350             =cut
351              
352             sub stream {
353 29     29 1 1261 my ($self,$code) = @_;
354              
355 29 50       62 if (not defined $code) {
356 0         0 $self->issue ("stream requires RiveScript code.");
357 0         0 return 0;
358             }
359              
360             # Stream the code.
361 29         65 $self->debug ("stream: Streaming code.");
362 29         84 $self->parse ("stream()",$code);
363              
364 29         74 return 1;
365             }
366              
367             sub parse {
368 29     29 0 61 my ($self,$fname,$code) = @_;
369              
370             # Track temporary variables.
371 29         38 my $topic = 'random'; # Default topic=random
372 29         38 my $lineno = 0; # Keep track of line numbers
373 29         40 my $comment = 0; # In a multi-line comment.
374 29         35 my $inobj = 0; # Trying to parse an object.
375 29         35 my $objname = ''; # Object name.
376 29         37 my $objlang = ''; # Object programming language.
377 29         39 my $objbuf = ''; # Object contents buffer.
378 29         35 my $ontrig = ''; # Current trigger.
379 29         38 my $repcnt = 0; # Reply counter.
380 29         41 my $concnt = 0; # Condition counter.
381 29         41 my $lastcmd = ''; # Last command code.
382 29         37 my $isThat = ''; # Is a %Previous trigger.
383              
384             # Local (file scoped) parser options.
385 29         88 my %local_options = (
386             concat => "none", # Concat mode for ^Continue command.
387             );
388              
389             # Concat mode characters.
390 29         82 my %concat_mode = (
391             none => "",
392             space => " ",
393             newline => "\n",
394             );
395              
396             # Split the RS code into lines.
397 29         351 $code =~ s/([\x0d\x0a])+/\x0a/ig;
398 29         148 my @lines = split(/\x0a/, $code);
399              
400             # Read each line.
401 29         90 $self->debug ("Parsing file data from $fname");
402 29         42 my $lp = 0; # line number index
403 29         82 for ($lp = 0; $lp < scalar(@lines); $lp++) {
404 326         441 $lineno++;
405 326         504 my $line = $lines[$lp];
406              
407             # Chomp the line further.
408 326         458 chomp $line;
409 326         1353 $line =~ s/^(\t|\x0a|\x0d|\s)+//ig;
410 326         1497 $line =~ s/(\t|\x0a|\x0d|\s)+$//ig;
411              
412 326         945 $self->debug ("Line: $line (topic: $topic)");
413              
414             # In an object?
415 326 100       610 if ($inobj) {
416 15 100       42 if ($line =~ /^<\s*object/i) {
417             # End the object.
418 6 100       14 if (length $objname) {
419             # Call this object's handler.
420 4 50       9 if (exists $self->{handlers}->{$objlang}) {
421 4         12 $self->{objlangs}->{$objname} = $objlang;
422 4         6 &{ $self->{handlers}->{$objlang} } ($self,"load",$objname,$objbuf);
  4         11  
423             }
424             else {
425 0         0 $self->issue ("Object creation failed: no handler for $objlang!");
426             }
427             }
428 6         13 $objname = '';
429 6         7 $objlang = '';
430 6         11 $objbuf = '';
431             }
432             else {
433 9         19 $objbuf .= "$line\n";
434 9         20 next;
435             }
436             }
437              
438             # Look for comments.
439 317 100       1030 if ($line =~ /^(\/\/|#)/i) {
    50          
    50          
440             # The "#" format for comments is deprecated.
441 8 50       22 if ($line =~ /^#/) {
442 0         0 $self->issue ("Using the # symbol for comments is deprecated at $fname line $lineno (near $line)");
443             }
444 8         21 next;
445             }
446             elsif ($line =~ /^\/\*/) {
447 0 0       0 if ($line =~ /\*\//) {
448             # Well this was a short comment.
449 0         0 next;
450             }
451              
452             # Start of a multi-line comment.
453 0         0 $comment = 1;
454 0         0 next;
455             }
456             elsif ($line =~ /\*\//) {
457 0         0 $comment = 0;
458 0         0 next;
459             }
460 309 50       542 if ($comment) {
461 0         0 next;
462             }
463              
464             # Skip blank lines.
465 309 100       713 next if length $line == 0;
466              
467             # Separate the command from the data.
468 251         584 my ($cmd) = $line =~ /^(.)/i;
469 251         657 $line =~ s/^.//i;
470 251         744 $line =~ s/^\s+?//ig;
471              
472             # Ignore inline comments if there's a space before and after
473             # the // or # symbols.
474 251         615 my $inline_comment_regexp = qr/(\s+#\s+|\s+\/\/)/;
475 251         418 $line =~ s/\\\/\//\\\/\\\//g; # Turn \// into \/\/
476 251 100       431 if ($cmd eq '+') {
477 87         202 $inline_comment_regexp = qr/(\s\s#|\s+\/\/)/;
478 87 50       201 if ($line =~ /\s\s#\s/) {
479             # Deprecated.
480 0         0 $self->issue ("Using the # symbol for comments is deprecated at $fname line $lineno (near: $line).");
481             }
482             }
483             else {
484 164 50       323 if ($line =~ /\s#\s/) {
485             # Deprecated.
486 0         0 $self->issue ("Using the # symbol for comments is deprecated at $fname line $lineno (near: $line).");
487             }
488             }
489 251 50       1523 if ($line =~ /$inline_comment_regexp/) {
490 0         0 my ($left,$comment) = split(/$inline_comment_regexp/, $line, 2);
491 0         0 $left =~ s/\s+$//g;
492 0         0 $line = $left;
493             }
494              
495 251         714 $self->debug ("\tCmd: $cmd");
496              
497             # Run a syntax check on this line. We put this into a separate function so that
498             # we can have all the syntax logic all in one place.
499 251         488 my $syntax_error = $self->checkSyntax($cmd,$line);
500 251 50       446 if ($syntax_error) {
501             # There was a syntax error! Are we enforcing "strict"?
502 0         0 $syntax_error = "Syntax error in $fname line $lineno: $syntax_error (near: $cmd $line)";
503 0 0       0 if ($self->{strict}) {
504             # This is fatal then!
505 0         0 die $syntax_error;
506             }
507             else {
508             # This is a warning; warn it, and then abort processing this file!
509 0         0 warn $syntax_error;
510 0         0 return;
511             }
512             }
513              
514             # Reset the %previous state if this is a new +Trigger.
515 251 100       460 if ($cmd eq '+') {
516 87         145 $isThat = '';
517             }
518              
519             # Do a lookahead for ^Continue and %Previous commands.
520 251         595 for (my $i = ($lp + 1); $i < scalar(@lines); $i++) {
521 267         407 my $lookahead = $lines[$i];
522 267         1212 $lookahead =~ s/^(\t|\x0a|\x0d|\s)+//g;
523 267         709 my ($lookCmd) = $lookahead =~ /^(.)/i;
524 267         696 $lookahead =~ s/^([^\s]+)\s+//i;
525              
526             # Only continue if the lookahead line has any data.
527 267 100 66     961 if (defined $lookahead && length $lookahead > 0) {
528             # The lookahead command has to be either a % or a ^.
529 234 100 100     634 if ($lookCmd ne '^' && $lookCmd ne '%') {
530             #$isThat = '';
531 211         335 last;
532             }
533              
534             # If the current command is a +, see if the following command
535             # is a % (previous)
536 23 100       45 if ($cmd eq '+') {
537             # Look for %Previous.
538 7 50       14 if ($lookCmd eq '%') {
539 7         33 $self->debug ("\tIs a %previous ($lookahead)");
540 7         16 $isThat = $lookahead;
541 7         14 last;
542             }
543             else {
544 0         0 $isThat = '';
545             }
546             }
547              
548             # If the current command is a ! and the next command(s) are
549             # ^, we'll tack each extension on as a line break (which is
550             # useful information for arrays; everything else is gonna ditch
551             # this info).
552 16 100       32 if ($cmd eq '!') {
553 1 50       4 if ($lookCmd eq '^') {
554 1         6 $self->debug ("\t^ [$lp;$i] $lookahead");
555 1         3 $line .= "$lookahead";
556 1         4 $self->debug ("\tLine: $line");
557             }
558 1         4 next;
559             }
560              
561             # If the current command is not a ^ and the line after is
562             # not a %, but the line after IS a ^, then tack it onto the
563             # end of the current line (this is fine for every other type
564             # of command that doesn't require special treatment).
565 15 100 66     49 if ($cmd ne '^' && $lookCmd ne '%') {
566 11 50       20 if ($lookCmd eq '^') {
567 11         40 $self->debug ("\t^ [$lp;$i] $lookahead");
568             my $concat = exists $concat_mode{$local_options{"concat"}}
569 11 100       32 ? $concat_mode{$local_options{"concat"}}
570             : "";
571 11         36 $line .= $concat . $lookahead;
572             }
573             else {
574 0         0 last;
575             }
576             }
577             }
578             }
579              
580 251 100       797 if ($cmd eq '!') {
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
581             # ! DEFINE
582 17         82 my ($left,$value) = split(/\s*=\s*/, $line, 2);
583 17         54 my ($type,$var) = split(/\s+/, $left, 2);
584 17         29 $ontrig = '';
585 17         38 $self->debug ("\t! DEFINE");
586              
587             # Remove line breaks unless this is an array.
588 17 100       36 if ($type ne 'array') {
589 16         31 $value =~ s///ig;
590             }
591              
592 17 50       77 if ($type eq 'version') {
    100          
    100          
    100          
    100          
    100          
    50          
593 0         0 $self->debug ("\tUsing RiveScript version $value");
594 0 0       0 if ($value > $SUPPORT) {
595 0         0 $self->issue ("Unsupported RiveScript Version. Skipping file $fname.");
596 0         0 return;
597             }
598             }
599             elsif ($type eq 'local') {
600 5         17 $self->debug ("\tSet local parser option $var = $value");
601 5         19 $local_options{$var} = $value;
602             }
603             elsif ($type eq 'global') {
604 1 50       4 if (not defined $var) {
605 0         0 $self->issue ("Undefined global variable at $fname line $lineno.");
606 0         0 next;
607             }
608 1 50       2 if (not defined $value) {
609 0         0 $self->issue ("Undefined global value at $fname line $lineno.");
610 0         0 next;
611             }
612              
613 1         5 $self->debug ("\tSet global $var = $value");
614              
615             # Don't allow the overriding of a reserved global.
616 1         2 my $ok = 1;
617 1         2 foreach my $res (@{$self->{reserved}}) {
  1         2  
618 20 50       33 if ($var eq $res) {
619 0         0 $ok = 0;
620 0         0 last;
621             }
622             }
623              
624 1 50       3 if ($ok) {
625             # Allow in the global name space.
626 1 50       3 if ($value eq '') {
627 0         0 delete $self->{$var};
628             }
629             else {
630 1         4 $self->{$var} = $value;
631             }
632             }
633             else {
634             # Allow in the protected name space.
635 0 0       0 if ($value eq '') {
636 0         0 delete $self->{globals}->{$var};
637             }
638             else {
639 0         0 $self->{globals}->{$var} = $value;
640             }
641             }
642             }
643             elsif ($type eq 'var') {
644 2         6 $self->debug ("\tSet bot variable $var = $value");
645 2 50       4 if (not defined $var) {
646 0         0 $self->issue ("Undefined bot variable at $fname line $lineno.");
647 0         0 next;
648             }
649 2 50       4 if (not defined $value) {
650 0         0 $self->issue ("Undefined bot value at $fname line $lineno.");
651 0         0 next;
652             }
653              
654 2 50       4 if ($value eq '') {
655 0         0 delete $self->{bot}->{$var};
656             }
657             else {
658 2         8 $self->{bot}->{$var} = $value;
659             }
660             }
661             elsif ($type eq 'array') {
662 1         5 $self->debug ("\tSet array $var");
663 1 50       4 if (not defined $var) {
664 0         0 $self->issue ("Undefined array variable at $fname line $lineno.");
665 0         0 next;
666             }
667 1 50       4 if (not defined $value) {
668 0         0 $self->issue ("Undefined array value at $fname line $lineno.");
669 0         0 next;
670             }
671              
672 1 50       5 if ($value eq '') {
673 0         0 delete $self->{arrays}->{$var};
674 0         0 next;
675             }
676              
677             # Did this have multiple lines?
678 1         5 my @parts = split(//i, $value);
679 1         7 $self->debug("Array lines: " . join(";",@parts));
680              
681             # Process each line of array data.
682 1         2 my @fields = ();
683 1         3 foreach my $val (@parts) {
684             # Split at pipes or spaces?
685 2 100       6 if ($val =~ /\|/) {
686 1         5 push (@fields,split(/\|/, $val));
687             }
688             else {
689 1         7 push (@fields,split(/\s+/, $val));
690             }
691             }
692              
693             # Convert any remaining \s escape codes into spaces.
694 1         2 foreach my $f (@fields) {
695 7         11 $f =~ s/\\s/ /ig;
696             }
697              
698 1         7 $self->{arrays}->{$var} = [ @fields ];
699             }
700             elsif ($type eq 'sub') {
701 6         22 $self->debug ("\tSubstitution $var => $value");
702 6 50       16 if (not defined $var) {
703 0         0 $self->issue ("Undefined sub pattern at $fname line $lineno.");
704 0         0 next;
705             }
706 6 50       15 if (not defined $value) {
707 0         0 $self->issue ("Undefined sub replacement at $fname line $lineno.");
708 0         0 next;
709             }
710              
711 6 50       17 if ($value eq '') {
712 0         0 delete $self->{subs}->{$var};
713 0         0 next;
714             }
715 6         26 $self->{subs}->{$var} = $value;
716             }
717             elsif ($type eq 'person') {
718 2         8 $self->debug ("\tPerson substitution $var => $value");
719 2 50       6 if (not defined $var) {
720 0         0 $self->issue ("Undefined person sub pattern at $fname line $lineno.");
721 0         0 next;
722             }
723 2 50       6 if (not defined $value) {
724 0         0 $self->issue ("Undefined person sub replacement at $fname line $lineno.");
725 0         0 next;
726             }
727 2 50       3 if ($value eq '') {
728 0         0 delete $self->{person}->{$var};
729 0         0 next;
730             }
731 2         9 $self->{person}->{$var} = $value;
732             }
733             else {
734 0         0 $self->issue ("Unknown definition type \"$type\" at $fname line $lineno.");
735 0         0 next;
736             }
737             }
738             elsif ($cmd eq '>') {
739             # > LABEL
740 16         65 my ($type,$name,@fields) = split(/\s+/, $line);
741 16         32 $type = lc($type);
742              
743             # Handle the label types.
744 16 100       32 if ($type eq 'begin') {
745             # The BEGIN statement.
746 3         8 $self->debug ("Found the BEGIN Statement.");
747 3         4 $type = 'topic';
748 3         4 $name = '__begin__';
749             }
750 16 100       31 if ($type eq 'topic') {
751             # Starting a new topic.
752 10         34 $self->debug ("Set topic to $name.");
753 10         14 $ontrig = '';
754 10         16 $topic = $name;
755              
756             # Does this topic include or inherit another one?
757 10         15 my $mode = ''; # or 'inherits' || 'includes'
758 10 100       23 if (scalar(@fields) >= 2) {
759 4         8 foreach my $field (@fields) {
760 9 100       24 if ($field eq 'includes') {
    100          
    50          
761 2         5 $mode = 'includes';
762             }
763             elsif ($field eq 'inherits') {
764 2         4 $mode = 'inherits';
765             }
766             elsif ($mode ne '') {
767             # This topic is either inherited or included.
768 5 100       10 if ($mode eq 'includes') {
769 3         10 $self->{includes}->{$name}->{$field} = 1;
770             }
771             else {
772 2         6 $self->{lineage}->{$name}->{$field} = 1;
773             }
774             }
775             }
776             }
777             }
778 16 100       51 if ($type eq 'object') {
779             # If a field was provided, it should be the programming language.
780 6 100       17 my $lang = (scalar(@fields) ? $fields[0] : '');
781 6         12 $lang = lc($lang); $lang =~ s/\s+//g;
  6         12  
782              
783             # Only try to parse a language we support.
784 6         10 $ontrig = '';
785 6 100       12 if (not length $lang) {
786 1         6 $self->issue ("Trying to parse unknown programming language at $fname line $lineno.");
787 1         5 $lang = "perl"; # Assume it's Perl.
788             }
789              
790             # See if we have a defined handler for this language.
791 6 100       17 if (exists $self->{handlers}->{$lang}) {
792             # We have a handler, so load this object's code.
793 4         8 $objname = $name;
794 4         6 $objlang = $lang;
795 4         7 $objbuf = '';
796 4         15 $inobj = 1;
797             }
798             else {
799             # We don't have a handler, just ignore this code.
800 2         4 $objname = '';
801 2         3 $objlang = '';
802 2         4 $objbuf = '';
803 2         7 $inobj = 1;
804             }
805             }
806             }
807             elsif ($cmd eq '<') {
808             # < LABEL
809 16         25 my $type = $line;
810              
811 16 100 100     54 if ($type eq 'begin' || $type eq 'topic') {
    50          
812 10         26 $self->debug ("End topic label.");
813 10         30 $topic = 'random';
814             }
815             elsif ($type eq 'object') {
816 6         16 $self->debug ("End object label.");
817 6         18 $inobj = 0;
818             }
819             }
820             elsif ($cmd eq '+') {
821             # + TRIGGER
822 87         276 $self->debug ("\tTrigger pattern: $line");
823 87 100       165 if (length $isThat) {
824 7         16 $self->debug ("\t\tInitializing the \%previous structure.");
825 7         28 $self->{thats}->{$topic}->{$isThat}->{$line} = {};
826             }
827             else {
828 80         350 $self->{topics}->{$topic}->{$line} = {};
829 80         265 $self->{syntax}->{$topic}->{$line}->{ref} = "$fname line $lineno";
830 80         297 $self->debug ("\t\tSaved to \$self->{topics}->{$topic}->{$line}: "
831             . "$self->{topics}->{$topic}->{$line}");
832             }
833 87         145 $ontrig = $line;
834 87         118 $repcnt = 0;
835 87         273 $concnt = 0;
836             }
837             elsif ($cmd eq '-') {
838             # - REPLY
839 83 50       149 if ($ontrig eq '') {
840 0         0 $self->issue ("Response found before trigger at $fname line $lineno.");
841 0         0 next;
842             }
843 83         232 $self->debug ("\tResponse: $line");
844 83 100       174 if (length $isThat) {
845 7         25 $self->{thats}->{$topic}->{$isThat}->{$ontrig}->{reply}->{$repcnt} = $line;
846             }
847             else {
848 76         236 $self->{topics}->{$topic}->{$ontrig}->{reply}->{$repcnt} = $line;
849 76         248 $self->{syntax}->{$topic}->{$ontrig}->{reply}->{$repcnt}->{ref} = "$fname line $lineno";
850 76         304 $self->debug ("\t\tSaved to \$self->{topics}->{$topic}->{$ontrig}->{reply}->{$repcnt}: "
851             . "$self->{topics}->{$topic}->{$ontrig}->{reply}->{$repcnt}");
852             }
853 83         263 $repcnt++;
854             }
855             elsif ($cmd eq '%') {
856             # % PREVIOUS
857 7         25 $self->debug ("\t% Previous pattern: $line");
858              
859             # This was handled above.
860             }
861             elsif ($cmd eq '^') {
862             # ^ CONTINUE
863             # This should've been handled above...
864             }
865             elsif ($cmd eq '@') {
866             # @ REDIRECT
867 3         10 $self->debug ("\tRedirect the response to $line");
868 3 50       8 if (length $isThat) {
869 0         0 $self->{thats}->{$topic}->{$isThat}->{$ontrig}->{redirect} = $line;
870             }
871             else {
872 3         15 $self->{topics}->{$topic}->{$ontrig}->{redirect} = $line;
873             }
874             }
875             elsif ($cmd eq '*') {
876             # * CONDITION
877 10         23 $self->debug ("\tAdding condition.");
878 10 50       40 if (length $isThat) {
879 0         0 $self->{thats}->{$topic}->{$isThat}->{$ontrig}->{condition}->{$concnt} = $line;
880             }
881             else {
882 10         57 $self->{topics}->{$topic}->{$ontrig}->{condition}->{$concnt} = $line;
883             }
884 10         36 $concnt++;
885             }
886             else {
887 0         0 $self->issue ("Unrecognized command \"$cmd\" at $fname line $lineno.");
888 0         0 next;
889             }
890             }
891             }
892              
893             =item string checkSyntax (char $COMMAND, string $LINE)
894              
895             Check the syntax of a line of RiveScript code. This is called automatically
896             for each line parsed by the module. C<$COMMAND> is the command part of the
897             line, and C<$LINE> is the rest of the line following the command (and
898             excluding inline comments).
899              
900             If there is no problem with the line, this method returns C. Otherwise
901             it returns the text of the syntax error.
902              
903             If C mode is enabled in the constructor (which is on by default), a
904             syntax error will result in a fatal error. If it's not enabled, the error is
905             only sent via C and the file currently being processed is aborted.
906              
907             =cut
908              
909             sub checkSyntax {
910 251     251 1 449 my ($self,$cmd,$line) = @_;
911              
912             # This function returns undef when no syntax errors are present, otherwise
913             # returns the text of the syntax error.
914              
915             # Run syntax checks based on the type of command.
916 251 100 100     1222 if ($cmd eq '!') {
    100 100        
    100 100        
    100 66        
    100          
917             # ! Definition
918             # - Must be formatted like this:
919             # ! type name = value
920             # OR
921             # ! type = value
922             # - Type options are NOT enforceable, for future compatibility; if RiveScript
923             # encounters a new type that it can't handle, it can safely warn and skip it.
924 17 50       118 if ($line !~ /^.+(?:\s+.+|)\s*=\s*.+?$/) {
925 0         0 return "Invalid format for !Definition line: must be '! type name = value' OR '! type = value'";
926             }
927             }
928             elsif ($cmd eq '>') {
929             # > Label
930             # - The "begin" label must have only one argument ("begin")
931             # - "topic" labels must be lowercase but can inherit other topics ([A-Za-z0-9_\s])
932             # - "object" labels follow the same rules as "topic" labels, but don't need be lowercase
933 16 50 66     111 if ($line =~ /^begin/ && $line =~ /\s+/) {
    50 66        
    50          
934 0         0 return "The 'begin' label takes no additional arguments, should be verbatim '> begin'";
935             }
936             elsif ($line =~ /^topic/i && $line =~ /[^a-z0-9_\-\s]/) {
937 0         0 return "Topics should be lowercased and contain only numbers and letters!";
938             }
939             elsif ($line =~ /[^A-Za-z0-9_\-\s]/) {
940 0         0 return "Objects can only contain numbers and letters!";
941             }
942             }
943             elsif ($cmd eq '+' || $cmd eq '%' || $cmd eq '@') {
944             # + Trigger, % Previous, @ Redirect
945             # This one is strict. The triggers are to be run through Perl's regular expression
946             # engine. Therefore it should be acceptable by the regexp engine.
947             # - Entirely lowercase
948             # - No symbols except: ( | ) [ ] * _ # @ { } < > =
949             # - All brackets should be matched
950 97         130 my $parens = 0; # Open parenthesis
951 97         123 my $square = 0; # Open square brackets
952 97         116 my $curly = 0; # Open curly brackets
953 97         130 my $chevron = 0; # Open angled brackets
954              
955             # Look for obvious errors.
956 97 100       159 if ($self->{utf8}) {
957             # UTF-8 only restricts certain meta characters.
958 15 50       44 if ($line =~ /[A-Z\\.]/) {
959 0         0 return "Triggers can't contain uppercase letters, backslashes or dots in UTF-8 mode.";
960             }
961             } else {
962             # Only simple ASCIIs allowed.
963 82 50       205 if ($line =~ /[^a-z0-9(\|)\[\]*_#\@{}<>=\s]/) {
964 0         0 return "Triggers may only contain lowercase letters, numbers, and these symbols: ( | ) [ ] * _ # @ { } < > =";
965             }
966             }
967              
968             # Count brackets.
969 97         366 my @chr = split(//, $line);
970 97         249 for (my $i = 0; $i < scalar(@chr); $i++) {
971 1252         1648 my $char = $chr[$i];
972              
973             # Count brackets.
974 1252 100       1914 $parens++ if $char eq '('; $parens-- if $char eq ')';
  1252 100       1983  
975 1252 100       1869 $square++ if $char eq '['; $square-- if $char eq ']';
  1252 100       1902  
976 1252 100       1840 $curly++ if $char eq '{'; $curly-- if $char eq '}';
  1252 100       1920  
977 1252 50       1878 $chevron++ if $char eq '<'; $chevron-- if $char eq '>';
  1252 50       2705  
978             }
979              
980             # Any mismatches?
981 97 50       181 if ($parens) {
982 0 0       0 return "Unmatched " . ($parens > 0 ? "left" : "right") . " parenthesis bracket ()";
983             }
984 97 50       150 if ($square) {
985 0 0       0 return "Unmatched " . ($square > 0 ? "left" : "right") . " square bracket []";
986             }
987 97 50       160 if ($curly) {
988 0 0       0 return "Unmatched " . ($curly > 0 ? "left" : "right") . " curly bracket {}";
989             }
990 97 50       251 if ($chevron) {
991 0 0       0 return "Unmatched " . ($chevron > 0 ? "left" : "right" ) . " angled bracket <>";
992             }
993             }
994             elsif ($cmd eq '-' || $cmd eq '^' || $cmd eq '/') {
995             # - Trigger, ^ Continue, / Comment
996             # These commands take verbatim arguments, so their syntax is loose.
997             }
998             elsif ($cmd eq '*') {
999             # * Condition
1000             # Syntax for a conditional is as follows:
1001             # * value symbol value => response
1002 10 50       63 if ($line !~ /^.+?\s*(==|eq|!=|ne|<>|<|<=|>|>=)\s*.+?=>.+?$/) {
1003 0         0 return "Invalid format for !Condition: should be like `* value symbol value => response`";
1004             }
1005             }
1006              
1007             # All good? Return undef.
1008 251         458 return undef;
1009             }
1010              
1011             =item void sortReplies ()
1012              
1013             Call this method after loading replies to create an internal sort buffer. This
1014             is necessary for trigger matching purposes. If you fail to call this method
1015             yourself, RiveScript will call it once when you request a reply. However, it
1016             will complain loudly about it.
1017              
1018             =cut
1019              
1020             sub sortReplies {
1021 58     58 1 143 my $self = shift;
1022 58   100     143 my $thats = shift || 'no';
1023              
1024             # Make this method dynamic: allow it to sort both triggers and %previous.
1025             # To that end we need to make some more references.
1026 58         90 my $triglvl = {};
1027 58         92 my $sortlvl = 'sorted';
1028 58 100       107 if ($thats eq 'thats') {
1029 29         56 $triglvl = $self->{thats};
1030 29         43 $sortlvl = 'sortsthat';
1031             }
1032             else {
1033 29         57 $triglvl = $self->{topics};
1034             }
1035              
1036 58         118 $self->debug ("Sorting triggers...");
1037              
1038             # Loop through all the topics.
1039 58         95 foreach my $topic (keys %{$triglvl}) {
  58         150  
1040 42         120 $self->debug ("Analyzing topic $topic");
1041              
1042             # Create a priority map.
1043 42         93 my $prior = {
1044             0 => [], # Default
1045             };
1046              
1047             # Collect a list of all the triggers we're going to need to
1048             # worry about. If this topic inherits another topic, we need to
1049             # recursively add those to the list.
1050 42         98 my @alltrig = $self->_topicTriggers($topic,$triglvl,0,0,0);
1051             #foreach my $trig (keys %{$triglvl->{$topic}}) {
1052 42         74 foreach my $trig (@alltrig) {
1053 106 100       190 if ($trig =~ /\{weight=(\d+)\}/i) {
1054 3         9 my $weight = $1;
1055              
1056 3 50       10 if (!exists $prior->{$weight}) {
1057 3         6 $prior->{$weight} = [];
1058             }
1059              
1060 3         5 push (@{$prior->{$weight}}, $trig);
  3         8  
1061             }
1062             else {
1063 103         133 push (@{$prior->{0}}, $trig);
  103         198  
1064             }
1065             }
1066              
1067             # Keep in mind here that there is a difference between 'includes'
1068             # and 'inherits' -- topics that inherit other topics are able to
1069             # OVERRIDE triggers that appear in the inherited topic. This means
1070             # that if the top topic has a trigger of simply '*', then *NO* triggers
1071             # are capable of matching in ANY inherited topic, because even though
1072             # * has the lowest sorting priority, it has an automatic priority over
1073             # all inherited topics.
1074             #
1075             # The _topicTriggers method takes this into account. All topics that
1076             # inherit other topics will have their triggers prefixed with a fictional
1077             # {inherits} tag, which would start at {inherits=0} and increment if the
1078             # topic tree has other inheriting topics. So we can use this tag to
1079             # make sure topics that inherit things will have their triggers always
1080             # be on the top of the stack, from inherits=0 to inherits=n.
1081              
1082             # Keep a running list of sorted triggers for this topic.
1083 42         66 my @running = ();
1084              
1085             # Sort them by priority.
1086 42         64 foreach my $p (sort { $b <=> $a } keys %{$prior}) {
  4         12  
  42         113  
1087 45         126 $self->debug ("\tSorting triggers with priority $p.");
1088              
1089             # So, some of these triggers may include {inherits} tags, if they
1090             # came from a topic which inherits another topic. Lower inherits
1091             # values mean higher priority on the stack. Keep this in mind when
1092             # keeping track of how to sort these things.
1093 45         71 my $inherits = -1; # -1 means no {inherits} tag, for flexibility
1094 45         60 my $highest_inherits = -1; # highest inheritence # we've seen
1095              
1096             # Loop through and categorize these triggers.
1097 45         241 my $track = {
1098             $inherits => {
1099             atomic => {}, # Sort by # of whole words
1100             option => {}, # Sort optionals by # of words
1101             alpha => {}, # Sort alpha wildcards by # of words
1102             number => {}, # Sort numeric wildcards by # of words
1103             wild => {}, # Sort wildcards by # of words
1104             pound => [], # Triggers of just #
1105             under => [], # Triggers of just _
1106             star => [], # Triggers of just *
1107             },
1108             };
1109              
1110 45         112 foreach my $trig (@{$prior->{$p}}) {
  45         80  
1111 106         278 $self->debug("\t\tLooking at trigger: $trig");
1112              
1113             # See if this trigger has an inherits number.
1114 106 100       244 if ($trig =~ /{inherits=(\d+)}/) {
1115 10         22 $inherits = $1;
1116 10 100       24 if ($inherits > $highest_inherits) {
1117 4         7 $highest_inherits = $inherits;
1118             }
1119 10         31 $self->debug("\t\t\tTrigger belongs to a topic which inherits other topics: level=$inherits");
1120 10         40 $trig =~ s/{inherits=\d+}//g;
1121             }
1122             else {
1123 96         124 $inherits = -1;
1124             }
1125              
1126             # If this is the first time we've seen this inheritence priority
1127             # level, initialize its structure.
1128 106 100       214 if (!exists $track->{$inherits}) {
1129 5         23 $track->{$inherits} = {
1130             atomic => {},
1131             option => {},
1132             alpha => {},
1133             number => {},
1134             wild => {},
1135             pound => [],
1136             under => [],
1137             star => [],
1138             };
1139             }
1140              
1141 106 100       334 if ($trig =~ /\_/) {
    100          
    100          
    100          
1142             # Alphabetic wildcard included.
1143 1         10 my @words = split(/[\s\*\#\_]+/, $trig);
1144 1         3 my $cnt = scalar(@words);
1145 1         5 $self->debug("\t\tHas a _ wildcard with $cnt words.");
1146 1 50       3 if ($cnt > 1) {
1147 1 50       5 if (!exists $track->{$inherits}->{alpha}->{$cnt}) {
1148 1         3 $track->{$inherits}->{alpha}->{$cnt} = [];
1149             }
1150 1         3 push (@{$track->{$inherits}->{alpha}->{$cnt}}, $trig);
  1         4  
1151             }
1152             else {
1153 0         0 push (@{$track->{$inherits}->{under}}, $trig);
  0         0  
1154             }
1155             }
1156             elsif ($trig =~ /\#/) {
1157             # Numeric wildcard included.
1158 2         8 my @words = split(/[\s\*\#\_]+/, $trig);
1159 2         14 my $cnt = scalar(@words);
1160 2         12 $self->debug("\t\tHas a # wildcard with $cnt words.");
1161 2 50       7 if ($cnt > 1) {
1162 2 50       6 if (!exists $track->{$inherits}->{number}->{$cnt}) {
1163 2         6 $track->{$inherits}->{number}->{$cnt} = [];
1164             }
1165 2         5 push (@{$track->{$inherits}->{number}->{$cnt}}, $trig);
  2         9  
1166             }
1167             else {
1168 0         0 push (@{$track->{$inherits}->{pound}}, $trig);
  0         0  
1169             }
1170             }
1171             elsif ($trig =~ /\*/) {
1172             # Wildcards included.
1173 22         97 my @words = split(/[\s\*\#\_]+/, $trig);
1174 22         41 my $cnt = scalar(@words);
1175 22         69 $self->debug("Has a * wildcard with $cnt words.");
1176 22 100       46 if ($cnt > 1) {
1177 15 100       32 if (!exists $track->{$inherits}->{wild}->{$cnt}) {
1178 14         32 $track->{$inherits}->{wild}->{$cnt} = [];
1179             }
1180 15         19 push (@{$track->{$inherits}->{wild}->{$cnt}}, $trig);
  15         47  
1181             }
1182             else {
1183 7         11 push (@{$track->{$inherits}->{star}}, $trig);
  7         20  
1184             }
1185             }
1186             elsif ($trig =~ /\[(.+?)\]/) {
1187             # Optionals included.
1188 3         19 my @words = split(/[\s\*\#\_]+/, $trig);
1189 3         6 my $cnt = scalar(@words);
1190 3         12 $self->debug("Has optionals and $cnt words.");
1191 3 100       8 if (!exists $track->{$inherits}->{option}->{$cnt}) {
1192 2         5 $track->{$inherits}->{option}->{$cnt} = [];
1193             }
1194 3         5 push (@{$track->{$inherits}->{option}->{$cnt}}, $trig);
  3         10  
1195             }
1196             else {
1197             # Totally atomic.
1198 78         312 my @words = split(/[\s\*\#\_]+/, $trig);
1199 78         157 my $cnt = scalar(@words);
1200 78         222 $self->debug("Totally atomic and $cnt words.");
1201 78 100       171 if (!exists $track->{$inherits}->{atomic}->{$cnt}) {
1202 54         120 $track->{$inherits}->{atomic}->{$cnt} = [];
1203             }
1204 78         101 push (@{$track->{$inherits}->{atomic}->{$cnt}}, $trig);
  78         240  
1205             }
1206             }
1207              
1208             # Add this group to the sort list.
1209 45         113 $track->{ ($highest_inherits + 1) } = delete $track->{'-1'}; # Move the no-{inherits} group away for a sec
1210 45         68 foreach my $ip (sort { $a <=> $b } keys %{$track}) {
  6         16  
  45         156  
1211 50         134 $self->debug("ip=$ip");
1212 50         81 foreach my $kind (qw(atomic option alpha number wild)) {
1213 250         309 foreach my $wordcnt (sort { $b <=> $a } keys %{$track->{$ip}->{$kind}}) {
  20         67  
  250         560  
1214             # Triggers with a matching word count should be sorted
1215             # by length, descending.
1216 73         98 push (@running, sort { length($b) <=> length($a) } @{$track->{$ip}->{$kind}->{$wordcnt}});
  38         85  
  73         181  
1217             }
1218             }
1219 50         61 push (@running, sort { length($b) <=> length($a) } @{$track->{$ip}->{under}});
  0         0  
  50         98  
1220 50         62 push (@running, sort { length($b) <=> length($a) } @{$track->{$ip}->{pound}});
  0         0  
  50         97  
1221 50         77 push (@running, sort { length($b) <=> length($a) } @{$track->{$ip}->{star}});
  0         0  
  50         220  
1222             }
1223             }
1224              
1225             # Save this topic's sorted list.
1226 42         169 $self->{$sortlvl}->{$topic} = [ @running ];
1227             }
1228              
1229             # Also sort that's.
1230 58 100       142 if ($thats ne 'thats') {
1231             # This will sort the %previous lines to best match the bot's last reply.
1232 29         90 $self->sortReplies ('thats');
1233              
1234             # If any of those %previous's had more than one +trigger for them, this
1235             # will sort all those +trigger's to pair back the best human interaction.
1236 29         66 $self->sortThatTriggers;
1237              
1238             # Also sort both kinds of substitutions.
1239 29         36 $self->sortList ('subs', keys %{$self->{subs}});
  29         84  
1240 29         41 $self->sortList ('person', keys %{$self->{person}});
  29         74  
1241             }
1242             }
1243              
1244             sub sortThatTriggers {
1245 29     29 0 53 my ($self) = @_;
1246              
1247             # Usage case: if you have more than one +trigger with the same %previous,
1248             # this will create a sort buffer for all those +trigger's.
1249             # Ex:
1250             #
1251             # + how [are] you [doing]
1252             # - I'm doing great, how are you?
1253             # - Good -- how are you?
1254             # - Fine, how are you?
1255             #
1256             # + [*] @good [*]
1257             # % * how are you
1258             # - That's good. :-)
1259             #
1260             # # // TODO: why isn't this ever called?
1261             # + [*] @bad [*]
1262             # % * how are you
1263             # - Aww. :-( What's the matter?
1264             #
1265             # + *
1266             # % * how are you
1267             # - I see...
1268              
1269             # The sort buffer for this.
1270 29         52 $self->{sortedthat} = {};
1271             # Eventual structure:
1272             # $self->{sortedthat} = {
1273             # random => {
1274             # '* how are you' => [
1275             # '[*] @good [*]',
1276             # '[*] @bad [*]',
1277             # '*',
1278             # ],
1279             # },
1280             # };
1281              
1282 29         64 $self->debug ("Sorting reverse triggers for %previous groups...");
1283              
1284 29         38 foreach my $topic (keys %{$self->{thats}}) {
  29         64  
1285             # Create a running list of the sort buffer for this topic.
1286 2         5 my @running = ();
1287              
1288 2         10 $self->debug ("Sorting the 'that' triggers for topic $topic");
1289 2         4 foreach my $that (keys %{$self->{thats}->{$topic}}) {
  2         9  
1290 7         30 $self->debug ("Sorting triggers that go with the 'that' of \"$that\"");
1291             # Loop through and categorize these triggers.
1292 7         35 my $track = {
1293             atomic => {}, # Sort by # of whole words
1294             option => {}, # Sort optionals by # of words
1295             alpha => {}, # Sort letters by # of words
1296             number => {}, # Sort numbers by # of words
1297             wild => {}, # Sort wildcards by # of words
1298             pound => [], # Triggers of just #
1299             under => [], # Triggers of just _
1300             star => [], # Triggers of just *
1301             };
1302              
1303             # Loop through all the triggers for this %previous.
1304 7         13 foreach my $trig (keys %{$self->{thats}->{$topic}->{$that}}) {
  7         24  
1305 7 50       34 if ($trig =~ /\_/) {
    50          
    100          
    50          
1306             # Alphabetic wildcard included.
1307 0         0 my @words = split(/[\s\*\#\_]+/, $trig);
1308 0         0 my $cnt = scalar(@words);
1309 0 0       0 if ($cnt > 1) {
1310 0 0       0 if (!exists $track->{alpha}->{$cnt}) {
1311 0         0 $track->{alpha}->{$cnt} = [];
1312             }
1313 0         0 push (@{$track->{alpha}->{$cnt}}, $trig);
  0         0  
1314             }
1315             else {
1316 0         0 push (@{$track->{under}}, $trig);
  0         0  
1317             }
1318             }
1319             elsif ($trig =~ /\#/) {
1320             # Numeric wildcard included.
1321 0         0 my @words = split(/[\s\*\#\_]+/, $trig);
1322 0         0 my $cnt = scalar(@words);
1323 0 0       0 if ($cnt > 1) {
1324 0 0       0 if (!exists $track->{number}->{$cnt}) {
1325 0         0 $track->{number}->{$cnt} = [];
1326             }
1327 0         0 push (@{$track->{number}->{$cnt}}, $trig);
  0         0  
1328             }
1329             else {
1330 0         0 push (@{$track->{pound}}, $trig);
  0         0  
1331             }
1332             }
1333             elsif ($trig =~ /\*/) {
1334             # Wildcards included.
1335 4         16 my @words = split(/[\s\*\#\_]+/, $trig);
1336 4         8 my $cnt = scalar(@words);
1337 4 50       10 if ($cnt > 1) {
1338 0 0       0 if (!exists $track->{wild}->{$cnt}) {
1339 0         0 $track->{wild}->{$cnt} = [];
1340             }
1341 0         0 push (@{$track->{wild}->{$cnt}}, $trig);
  0         0  
1342             }
1343             else {
1344 4         7 push (@{$track->{star}}, $trig);
  4         11  
1345             }
1346             }
1347             elsif ($trig =~ /\[(.+?)\]/) {
1348             # Optionals included.
1349 0         0 my @words = split(/[\s\*\#\_]+/, $trig);
1350 0         0 my $cnt = scalar(@words);
1351 0 0       0 if (!exists $track->{option}->{$cnt}) {
1352 0         0 $track->{option}->{$cnt} = [];
1353             }
1354 0         0 push (@{$track->{option}->{$cnt}}, $trig);
  0         0  
1355             }
1356             else {
1357             # Totally atomic.
1358 3         10 my @words = split(/[\s\*\#\_]+/, $trig);
1359 3         7 my $cnt = scalar(@words);
1360 3 50       8 if (!exists $track->{atomic}->{$cnt}) {
1361 3         7 $track->{atomic}->{$cnt} = [];
1362             }
1363 3         4 push (@{$track->{atomic}->{$cnt}}, $trig);
  3         10  
1364             }
1365             }
1366              
1367             # Add this group to the sort list.
1368 7         13 my @running = ();
1369 7         10 foreach my $i (sort { $b <=> $a } keys %{$track->{atomic}}) {
  0         0  
  7         18  
1370 3         5 push (@running,@{$track->{atomic}->{$i}});
  3         9  
1371             }
1372 7         12 foreach my $i (sort { $b <=> $a } keys %{$track->{option}}) {
  0         0  
  7         16  
1373 0         0 push (@running,@{$track->{option}->{$i}});
  0         0  
1374             }
1375 7         10 foreach my $i (sort { $b <=> $a } keys %{$track->{alpha}}) {
  0         0  
  7         14  
1376 0         0 push (@running,@{$track->{alpha}->{$i}});
  0         0  
1377             }
1378 7         11 foreach my $i (sort { $b <=> $a } keys %{$track->{number}}) {
  0         0  
  7         11  
1379 0         0 push (@running,@{$track->{number}->{$i}});
  0         0  
1380             }
1381 7         12 foreach my $i (sort { $b <=> $a } keys %{$track->{wild}}) {
  0         0  
  7         15  
1382 0         0 push (@running,@{$track->{wild}->{$i}});
  0         0  
1383             }
1384 7         13 push (@running, sort { length($b) <=> length($a) } @{$track->{under}});
  0         0  
  7         12  
1385 7         10 push (@running, sort { length($b) <=> length($a) } @{$track->{pound}});
  0         0  
  7         12  
1386 7         11 push (@running, sort { length($b) <=> length($a) } @{$track->{star}});
  0         0  
  7         14  
1387              
1388             # Keep this buffer.
1389 7         32 $self->{sortedthat}->{$topic}->{$that} = [ @running ];
1390             }
1391             }
1392             }
1393              
1394             sub sortList {
1395 58     58 0 110 my ($self,$name,@list) = @_;
1396              
1397             # If a sorted list by this name already exists, delete it.
1398 58 100       121 if (exists $self->{sortlist}->{$name}) {
1399 6         13 delete $self->{sortlist}->{$name};
1400             }
1401              
1402             # Initialize the sorted list.
1403 58         100 $self->{sortlist}->{$name} = [];
1404              
1405             # Track by number of words.
1406 58         89 my $track = {};
1407              
1408             # Loop through each item in the list.
1409 58         95 foreach my $item (@list) {
1410             # Count the words.
1411 8         24 my @words = split(/\s+/, $item);
1412 8         13 my $cword = scalar(@words);
1413              
1414             # Store this by group of word counts.
1415 8 100       21 if (!exists $track->{$cword}) {
1416 4         10 $track->{$cword} = [];
1417             }
1418 8         13 push (@{$track->{$cword}}, $item);
  8         21  
1419             }
1420              
1421             # Sort them.
1422 58         70 my @sorted = ();
1423 58         77 foreach my $count (sort { $b <=> $a } keys %{$track}) {
  0         0  
  58         115  
1424 4         7 my @items = sort { length $b <=> length $a } @{$track->{$count}};
  5         15  
  4         12  
1425 4         10 push (@sorted,@items);
1426             }
1427              
1428             # Store this list.
1429 58         119 $self->{sortlist}->{$name} = [ @sorted ];
1430 58         139 return 1;
1431             }
1432              
1433             # Given one topic, walk the inheritence tree and return an array of all topics.
1434             sub _getTopicTree {
1435 37     37   62 my ($self,$topic,$depth) = @_;
1436              
1437             # Break if we're in too deep.
1438 37 50       71 if ($depth > $self->{depth}) {
1439 0         0 $self->issue ("Deep recursion while scanning topic inheritance (topic $topic was involved)");
1440 0         0 return ();
1441             }
1442              
1443             # Collect an array of topics.
1444 37         63 my @topics = ($topic);
1445              
1446 37         111 $self->debug ("_getTopicTree depth $depth; topics: @topics");
1447              
1448             # Does this topic include others?
1449 37 100       75 if (exists $self->{includes}->{$topic}) {
1450             # Try each of these.
1451 12         13 foreach my $includes (sort { $a cmp $b } keys %{$self->{includes}->{$topic}}) {
  6         22  
  12         43  
1452 18         50 $self->debug ("Topic $topic includes $includes");
1453 18         44 push (@topics, $self->_getTopicTree($includes,($depth + 1)));
1454             }
1455 12         35 $self->debug ("_getTopicTree depth $depth (b); topics: @topics");
1456             }
1457              
1458             # Does the topic inherit others?
1459 37 100       70 if (exists $self->{lineage}->{$topic}) {
1460             # Try each of these.
1461 5         7 foreach my $inherits (sort { $a cmp $b } keys %{$self->{lineage}->{$topic}}) {
  0         0  
  5         19  
1462 5         17 $self->debug ("Topic $topic inherits $inherits");
1463 5         14 push (@topics, $self->_getTopicTree($inherits,($depth + 1)));
1464             }
1465 5         16 $self->debug ("_getTopicTree depth $depth (b); topics: @topics");
1466             }
1467              
1468             # Return them.
1469 37         100 return (@topics);
1470             }
1471              
1472             # Gather an array of all triggers in a topic. If the topic inherits other
1473             # topics, recursively collect those triggers too. Take care about recursion.
1474             sub _topicTriggers {
1475 48     48   108 my ($self,$topic,$triglvl,$depth,$inheritence,$inherited) = @_;
1476              
1477             # Break if we're in too deep.
1478 48 50       98 if ($depth > $self->{depth}) {
1479 0         0 $self->issue ("Deep recursion while scanning topic inheritance (topic $topic was involved)");
1480 0         0 return ();
1481             }
1482              
1483             # Important info about the depth vs inheritence params to this function:
1484             # depth increments by 1 every time this function recursively calls itself.
1485             # inheritence increments by 1 only when this topic inherits another topic.
1486             #
1487             # This way, `> topic alpha includes beta inherits gamma` will have this effect:
1488             # alpha and beta's triggers are combined together into one matching pool, and then
1489             # these triggers have higher matching priority than gamma's.
1490             #
1491             # The $inherited option is 1 if this is a recursive call, from a topic that
1492             # inherits other topics. This forces the {inherits} tag to be added to the
1493             # triggers. This only applies when the top topic "includes" another topic.
1494              
1495 48         154 $self->debug ("\tCollecting trigger list for topic $topic (depth=$depth; inheritence=$inheritence; inherited=$inherited)");
1496              
1497             # topic: the name of the topic
1498             # triglvl: either $self->{topics} or $self->{thats}
1499             # depth: starts at 0 and ++'s with each recursion
1500              
1501             # Collect an array of triggers to return.
1502 48         77 my @triggers = ();
1503              
1504             # Does this topic include others?
1505 48 100       89 if (exists $self->{includes}->{$topic}) {
1506             # Check every included topic.
1507 3         7 foreach my $includes (sort { $a cmp $b } keys %{$self->{includes}->{$topic}}) {
  1         4  
  3         11  
1508 4         14 $self->debug ("\t\tTopic $topic includes $includes");
1509 4         16 push (@triggers, $self->_topicTriggers($includes,$triglvl,($depth + 1), $inheritence, 1));
1510             }
1511             }
1512              
1513             # Does this topic inherit others?
1514 48 100       95 if (exists $self->{lineage}->{$topic}) {
1515             # Check every inherited topic.
1516 2         7 foreach my $inherits (sort { $a cmp $b } keys %{$self->{lineage}->{$topic}}) {
  0         0  
  2         6  
1517 2         17 $self->debug ("\t\tTopic $topic inherits $inherits");
1518 2         19 push (@triggers, $self->_topicTriggers($inherits,$triglvl,($depth + 1), ($inheritence + 1), 0));
1519             }
1520             }
1521              
1522             # Collect the triggers for *this* topic. If this topic inherits any other
1523             # topics, it means that this topic's triggers have higher priority than those
1524             # in any inherited topics. Enforce this with an {inherits} tag.
1525 48 100 100     161 if (exists $self->{lineage}->{$topic} || $inherited) {
1526 6         11 my @inThisTopic = keys %{$triglvl->{$topic}};
  6         25  
1527 6         14 foreach my $trigger (@inThisTopic) {
1528 10         29 $self->debug ("\t\tPrefixing trigger with {inherits=$inheritence}$trigger");
1529 10         30 push (@triggers, "{inherits=$inheritence}$trigger");
1530             }
1531             }
1532             else {
1533 42         53 push (@triggers, keys %{$triglvl->{$topic}});
  42         128  
1534             }
1535              
1536             # Return them.
1537 48         143 return (@triggers);
1538             }
1539              
1540             =item data deparse ()
1541              
1542             Translate the in-memory representation of the loaded RiveScript documents into
1543             a Perl data structure. This would be useful for developing a user interface to
1544             facilitate editing of RiveScript replies without having to edit the RiveScript
1545             code manually.
1546              
1547             The data structure returned from this will follow this format:
1548              
1549             {
1550             "begin" => { # Contains begin block and config settings
1551             "global" => { # ! global (global variables)
1552             "depth" => 50,
1553             ...
1554             },
1555             "var" => { # ! var (bot variables)
1556             "name" => "Aiden",
1557             ...
1558             },
1559             "sub" => { # ! sub (substitutions)
1560             "what's" => "what is",
1561             ...
1562             },
1563             "person" => { # ! person (person substitutions)
1564             "you" => "I",
1565             ...
1566             },
1567             "array" => { # ! array (arrays)
1568             "colors" => [ "red", "green", "light green", "blue" ],
1569             ...
1570             },
1571             "triggers" => { # triggers in your > begin block
1572             "request" => { # trigger "+ request"
1573             "reply" => [ "{ok}" ],
1574             },
1575             },
1576             },
1577             "topic" => { # all topics under here
1578             "random" => { # topic names (default is random)
1579             "hello bot" => { # trigger labels
1580             "reply" => [ "Hello human!" ], # Array of -Replies
1581             "redirect" => "hello", # Only if @Redirect exists
1582             "previous" => "hello human", # Only if %Previous exists
1583             "condition" => [ # Only if *Conditions exist
1584             " != undefined => Hello !",
1585             ...
1586             ],
1587             },
1588             },
1589             },
1590             "include" => { # topic inclusion
1591             "alpha" => [ "beta", "gamma" ], # > topic alpha includes beta gamma
1592             },
1593             "inherit" => { # topic inheritence
1594             "alpha" => [ "delta" ], # > topic alpha inherits delta
1595             }
1596             }
1597              
1598             Note that inline object macros can't be deparsed this way. This is probably for
1599             the best (for security, etc). The global variables "debug" and "depth" are only
1600             provided if the values differ from the defaults (true and 50, respectively).
1601              
1602             =cut
1603              
1604             sub deparse {
1605 0     0 1 0 my ($self) = @_;
1606              
1607             # Can we clone?
1608 0         0 eval {
1609 0         0 require Clone;
1610 0         0 $self->{_can_clone} = 1;
1611             };
1612 0 0       0 if ($@) {
1613 0         0 warn "You don't have the Clone module installed. Output from "
1614             . "RiveScript->deparse will remain referenced to internal data "
1615             . "structures. Be careful!";
1616 0         0 $self->{_can_clone} = 0;
1617             }
1618              
1619             # Data to return.
1620 0         0 my $deparse = {
1621             begin => {
1622             global => {},
1623             var => {},
1624             sub => {},
1625             person => {},
1626             array => {},
1627             triggers => {},
1628             that => {},
1629             },
1630             topic => {},
1631             that => {},
1632             inherit => {},
1633             include => {},
1634             };
1635              
1636             # Populate the config fields.
1637 0 0       0 if ($self->{debug}) {
1638 0         0 $deparse->{begin}->{global}->{debug} = $self->{debug};
1639             }
1640 0 0       0 if ($self->{depth} != 50) {
1641 0         0 $deparse->{begin}->{global}->{depth} = $self->{depth};
1642             }
1643 0         0 $deparse->{begin}->{var} = $self->_clone($self->{bot});
1644 0         0 $deparse->{begin}->{sub} = $self->_clone($self->{subs});
1645 0         0 $deparse->{begin}->{person} = $self->_clone($self->{person});
1646 0         0 $deparse->{begin}->{array} = $self->_clone($self->{arrays});
1647 0         0 foreach my $global (keys %{$self->{globals}}) {
  0         0  
1648 0         0 $deparse->{begin}->{global}->{$global} = $self->{globals}->{$global};
1649             }
1650              
1651             # Triggers.
1652 0         0 foreach my $topic (keys %{$self->{topics}}) {
  0         0  
1653 0         0 my $dest; # Where to place the topic info.
1654              
1655 0 0       0 if ($topic eq "__begin__") {
1656             # Begin block.
1657 0         0 $dest = $deparse->{begin}->{triggers};
1658             }
1659             else {
1660             # Normal topic.
1661 0 0       0 if (!exists $deparse->{topic}->{$topic}) {
1662 0         0 $deparse->{topic}->{$topic} = {};
1663             }
1664 0         0 $dest = $deparse->{topic}->{$topic};
1665             }
1666              
1667 0         0 foreach my $trig (keys %{$self->{topics}->{$topic}}) {
  0         0  
1668 0         0 my $src = $self->{topics}->{$topic}->{$trig};
1669 0         0 $dest->{$trig} = {};
1670 0         0 $self->_copy_trigger($trig, $src, $dest);
1671             }
1672             }
1673              
1674             # %Previous's.
1675 0         0 foreach my $topic (keys %{$self->{thats}}) {
  0         0  
1676 0         0 my $dest; # Where to place the topic info.
1677              
1678 0 0       0 if ($topic eq "__begin__") {
1679             # Begin block.
1680 0         0 $dest = $deparse->{begin}->{that};
1681             }
1682             else {
1683             # Normal topic.
1684 0 0       0 if (!exists $deparse->{that}->{$topic}) {
1685 0         0 $deparse->{that}->{$topic} = {};
1686             }
1687 0         0 $dest = $deparse->{that}->{$topic};
1688             }
1689              
1690             # The "that" structure is backwards: bot reply, then trigger, then info.
1691 0         0 foreach my $previous (keys %{$self->{thats}->{$topic}}) {
  0         0  
1692 0         0 foreach my $trig (keys %{$self->{thats}->{$topic}->{$previous}}) {
  0         0  
1693 0         0 my $src = $self->{thats}->{$topic}->{$previous}->{$trig};
1694 0         0 $dest->{$trig}->{previous} = $previous;
1695 0         0 $self->_copy_trigger($trig, $src, $dest);
1696             }
1697             }
1698             }
1699              
1700             # Inherits/Includes.
1701 0         0 foreach my $topic (keys %{$self->{lineage}}) {
  0         0  
1702 0         0 $deparse->{inherit}->{$topic} = [];
1703 0         0 foreach my $inherit (keys %{$self->{lineage}->{$topic}}) {
  0         0  
1704 0         0 push @{$deparse->{inherit}->{$topic}}, $inherit;
  0         0  
1705             }
1706             }
1707 0         0 foreach my $topic (keys %{$self->{includes}}) {
  0         0  
1708 0         0 $deparse->{include}->{$topic} = [];
1709 0         0 foreach my $include (keys %{$self->{includes}->{$topic}}) {
  0         0  
1710 0         0 push @{$deparse->{include}->{$topic}}, $include;
  0         0  
1711             }
1712             }
1713              
1714 0         0 return $deparse;
1715             }
1716              
1717             sub _copy_trigger {
1718 0     0   0 my ($self, $trig, $src, $dest) = @_;
1719              
1720 0 0       0 if (exists $src->{redirect}) { # @Redirect
1721 0         0 $dest->{$trig}->{redirect} = $src->{redirect};
1722             }
1723 0 0       0 if (exists $src->{condition}) { # *Condition
1724 0         0 $dest->{$trig}->{condition} = [];
1725 0         0 foreach my $i (sort { $a <=> $b } keys %{$src->{condition}}) {
  0         0  
  0         0  
1726 0         0 push @{$dest->{$trig}->{condition}}, $src->{condition}->{$i};
  0         0  
1727             }
1728             }
1729 0 0       0 if (exists $src->{reply}) { # -Reply
1730 0         0 $dest->{$trig}->{reply} = [];
1731 0         0 foreach my $i (sort { $a <=> $b } keys %{$src->{reply}}) {
  0         0  
  0         0  
1732 0         0 push @{$dest->{$trig}->{reply}}, $src->{reply}->{$i};
  0         0  
1733             }
1734             }
1735             }
1736              
1737             sub _clone {
1738 0     0   0 my ($self,$data) = @_;
1739              
1740             # Can clone?
1741 0 0       0 if ($self->{_can_clone}) {
1742 0         0 return Clone::clone($data);
1743             }
1744              
1745 0         0 return $data;
1746             }
1747              
1748             =item void write (glob $fh || string $file[, data $deparsed])
1749              
1750             Write the currently parsed RiveScript data into a RiveScript file. This uses
1751             C to dump a representation of the loaded data and writes it to the
1752             destination file. Pass either a filehandle or a file name.
1753              
1754             If you provide C<$deparsed>, it should be a data structure matching the format
1755             of C. This way you can deparse your RiveScript brain, add/edit
1756             replies and then pass in the new version to this method to save the changes
1757             back to disk. Otherwise, C will be called to get the current
1758             snapshot of the brain.
1759              
1760             =back
1761              
1762             =cut
1763              
1764             sub write {
1765 0     0 1 0 my ($self, $file, $deparsed) = @_;
1766              
1767 0         0 my $fh;
1768 0 0       0 if (ref($file) eq "GLOB") {
    0          
1769 0         0 $fh = $file;
1770             }
1771             elsif (ref($file)) {
1772 0         0 die "Must pass either a filehandle or file name to write()";
1773             }
1774             else {
1775 0 0       0 open ($fh, ">", $file) or die "Can't write to $file: $!";
1776             }
1777              
1778 0 0       0 my $deparse = ref($deparsed) ? $deparsed : $self->deparse();
1779              
1780             # Start at the beginning.
1781 0         0 print {$fh} "// Written by RiveScript::deparse()\n";
  0         0  
1782 0         0 print {$fh} "! version = 2.0\n\n";
  0         0  
1783              
1784             # Variables of all sorts!
1785 0         0 foreach my $sort (qw/global var sub person array/) {
1786 0 0       0 next unless scalar keys %{$deparse->{begin}->{$sort}} > 0;
  0         0  
1787 0         0 foreach my $var (sort keys %{$deparse->{begin}->{$sort}}) {
  0         0  
1788             # Array types need to be separated by either spaces or pipes.
1789 0         0 my $data = $deparse->{begin}->{$sort}->{$var};
1790 0 0       0 if (ref($data) eq "ARRAY") {
1791 0         0 my $needs_pipes = 0;
1792 0         0 foreach my $test (@{$data}) {
  0         0  
1793 0 0       0 if ($test =~ /\s+/) {
1794 0         0 $needs_pipes = 1;
1795 0         0 last;
1796             }
1797             }
1798              
1799             # Word-wrap the result, target width is 78 chars minus the
1800             # sort, var, and spaces and equals sign.
1801 0         0 my $width = 78 - length($sort) - length($var) - 4;
1802              
1803 0 0       0 if ($needs_pipes) {
1804 0         0 $data = $self->_write_wrapped(join("|", @{$data}), "|", undef, $width);
  0         0  
1805             } else {
1806 0         0 $data = join(" ", @{$data});
  0         0  
1807             }
1808             }
1809              
1810 0         0 print {$fh} "! $sort $var = $data\n";
  0         0  
1811             }
1812 0         0 print {$fh} "\n";
  0         0  
1813             }
1814              
1815 0 0       0 if (scalar keys %{$deparse->{begin}->{triggers}}) {
  0         0  
1816 0         0 print {$fh} "> begin\n\n";
  0         0  
1817              
1818 0         0 $self->_write_triggers($fh, $deparse->{begin}->{triggers}, "indent");
1819              
1820 0         0 print {$fh} "< begin\n\n";
  0         0  
1821             }
1822              
1823             # The topics. Random first!
1824 0         0 my $doneRandom = 0;
1825 0         0 foreach my $topic ("random", sort keys %{$deparse->{topic}}) {
  0         0  
1826 0 0       0 next unless exists $deparse->{topic}->{$topic};
1827 0 0 0     0 next if $topic eq "random" && $doneRandom;
1828 0 0       0 $doneRandom = 1 if $topic eq "random";
1829              
1830 0         0 my $tagged = 0; # Used > topic tag
1831              
1832 0 0 0     0 if ($topic ne "random" || exists $deparse->{include}->{$topic} || exists $deparse->{inherit}->{$topic}) {
      0        
1833 0         0 $tagged = 1;
1834 0         0 print {$fh} "> topic $topic";
  0         0  
1835              
1836 0 0       0 if (exists $deparse->{inherit}->{$topic}) {
1837 0         0 print {$fh} " inherits " . join(" ", @{$deparse->{inherit}->{$topic}});
  0         0  
  0         0  
1838             }
1839 0 0       0 if (exists $deparse->{include}->{$topic}) {
1840 0         0 print {$fh} " includes " . join(" ", @{$deparse->{include}->{$topic}});
  0         0  
  0         0  
1841             }
1842              
1843 0         0 print {$fh} "\n\n";
  0         0  
1844             }
1845              
1846 0 0       0 $self->_write_triggers($fh, $deparse->{topic}->{$topic}, $tagged ? "indent" : 0);
1847              
1848             # Any %Previous's?
1849 0 0       0 if (exists $deparse->{that}->{$topic}) {
1850 0 0       0 $self->_write_triggers($fh, $deparse->{that}->{$topic}, $tagged ? "indent" : 0);
1851             }
1852              
1853 0 0       0 if ($tagged) {
1854 0         0 print {$fh} "< topic\n\n";
  0         0  
1855             }
1856             }
1857              
1858 0         0 return 1;
1859             }
1860              
1861             sub _write_triggers {
1862 0     0   0 my ($self, $fh, $trigs, $id) = @_;
1863              
1864 0 0       0 $id = $id ? "\t" : "";
1865              
1866 0         0 foreach my $trig (sort keys %{$trigs}) {
  0         0  
1867 0         0 print {$fh} $id . "+ " . $self->_write_wrapped($trig," ",$id) . "\n";
  0         0  
1868 0         0 my $d = $trigs->{$trig};
1869              
1870 0 0       0 if (exists $d->{previous}) {
1871 0         0 print {$fh} $id . "% " . $self->_write_wrapped($d->{previous}," ",$id) . "\n";
  0         0  
1872             }
1873              
1874 0 0       0 if (exists $d->{condition}) {
1875 0         0 foreach my $cond (@{$d->{condition}}) {
  0         0  
1876 0         0 print {$fh} $id . "* " . $self->_write_wrapped($cond," ",$id) . "\n";
  0         0  
1877             }
1878             }
1879              
1880 0 0       0 if (exists $d->{redirect}) {
1881 0         0 print {$fh} $id . "@ " . $self->_write_wrapped($d->{redirect}," ",$id) . "\n";
  0         0  
1882             }
1883              
1884 0 0       0 if (exists $d->{reply}) {
1885 0         0 foreach my $reply (@{$d->{reply}}) {
  0         0  
1886 0         0 print {$fh} $id . "- " . $self->_write_wrapped($reply," ",$id) . "\n";
  0         0  
1887             }
1888             }
1889              
1890 0         0 print {$fh} "\n";
  0         0  
1891             }
1892             }
1893              
1894             sub _write_wrapped {
1895 0     0   0 my ($self, $line, $sep, $indent, $width) = @_;
1896 0   0     0 $width ||= 78;
1897              
1898 0 0       0 my $id = $indent ? "\t" : "";
1899              
1900 0         0 my @words;
1901 0 0       0 if ($sep eq " ") {
    0          
1902 0         0 @words = split(/\s+/, $line);
1903             }
1904             elsif ($sep eq "|") {
1905 0         0 @words = split(/\|/, $line);
1906             }
1907              
1908 0         0 my @lines = ();
1909 0         0 $line = "";
1910 0         0 my @buf = ();
1911 0         0 while (scalar(@words)) {
1912 0         0 push (@buf, shift(@words));
1913 0         0 $line = join($sep, @buf);
1914 0 0       0 if (length $line > $width) {
1915             # Need to word wrap.
1916 0         0 unshift(@words, pop(@buf)); # Undo
1917 0         0 push (@lines, join($sep,@buf));
1918 0         0 @buf = ();
1919 0         0 $line = "";
1920             }
1921             }
1922              
1923             # Straggler?
1924 0 0       0 if ($line) {
1925 0         0 push @lines, $line;
1926             }
1927              
1928 0         0 my $return = shift(@lines);
1929 0 0       0 if (scalar(@lines)) {
1930 0 0       0 my $eol = ($sep eq " " ? '\s' : "");
1931 0         0 foreach my $ln (@lines) {
1932 0         0 $return .= "$eol\n$id^ $ln";
1933             }
1934             }
1935              
1936 0         0 return $return;
1937             }
1938              
1939             ################################################################################
1940             ## Configuration Methods ##
1941             ################################################################################
1942              
1943             =head2 CONFIGURATION
1944              
1945             =over 4
1946              
1947             =item bool setHandler (string $LANGUAGE => code $CODEREF, ...)
1948              
1949             Define some code to handle objects of a particular programming language. If the
1950             coderef is C, it will delete the handler.
1951              
1952             The code receives the variables C<$rs, $action, $name,> and C<$data>. These
1953             variables are described here:
1954              
1955             $rs = Reference to Perl RiveScript object.
1956             $action = "load" during the parsing phase when an >object is found.
1957             "call" when provoked via a tag for a reply
1958             $name = The name of the object.
1959             $data = The source of the object during the parsing phase, or an array
1960             reference of arguments when provoked via a tag.
1961              
1962             There is a default handler set up that handles Perl objects.
1963              
1964             If you want to block Perl objects from being loaded, you can just set it to be
1965             undef, and its handler will be deleted and Perl objects will be skipped over:
1966              
1967             $rs->setHandler (perl => undef);
1968              
1969             The rationale behind this "pluggable" object interface is that it makes
1970             RiveScript more flexible given certain environments. For instance, if you use
1971             RiveScript on the web where the user chats with your bot using CGI, you might
1972             define a handler so that JavaScript objects can be loaded and called. Perl
1973             itself can't execute JavaScript, but the user's web browser can.
1974              
1975             See the JavaScript example in the C directory in this distribution.
1976              
1977             =cut
1978              
1979             sub setHandler {
1980 27     27 1 79 my ($self,%info) = @_;
1981              
1982 27         74 foreach my $lang (keys %info) {
1983 27         46 my $code = $info{$lang};
1984 27         59 $lang = lc($lang);
1985 27         73 $lang =~ s/\s+//g;
1986              
1987             # If the coderef is undef, delete the handler.
1988 27 100       62 if (!defined $code) {
1989 1         9 delete $self->{handlers}->{$lang};
1990             }
1991             else {
1992             # Otherwise it must be a coderef.
1993 26 50       56 if (ref($code) eq "CODE") {
1994 26         79 $self->{handlers}->{$lang} = $code;
1995             }
1996             else {
1997 0         0 $self->issue("Handler for language $lang must be a code reference!");
1998             }
1999             }
2000             }
2001              
2002 27         58 return 1;
2003             }
2004              
2005             =item bool setSubroutine (string $NAME, code $CODEREF)
2006              
2007             Manually create a RiveScript object (a dynamic bit of Perl code that can be
2008             provoked in a RiveScript response). C<$NAME> should be a single-word,
2009             alphanumeric string. C<$CODEREF> should be a pointer to a subroutine or an
2010             anonymous sub.
2011              
2012             =cut
2013              
2014             sub setSubroutine {
2015 4     4 1 19 my ($self,$name,$sub) = @_;
2016              
2017 4         23 $self->{objects}->{$name} = $sub;
2018 4         9 $self->{objlangs}->{$name} = "perl";
2019 4         8 return 1;
2020             }
2021              
2022             =item bool setGlobal (hash %DATA)
2023              
2024             Set one or more global variables, in hash form, where the keys are the variable
2025             names and the values are their value. This subroutine will make sure that you
2026             don't override any reserved global variables, and warn if that happens.
2027              
2028             This is equivalent to C in RiveScript code.
2029              
2030             To delete a global, set its value to C or "CundefE>". This
2031             is true for variables, substitutions, person, and uservars.
2032              
2033             =cut
2034              
2035             sub setGlobal {
2036 0     0 1 0 my ($self,%data) = @_;
2037              
2038 0         0 foreach my $key (keys %data) {
2039 0 0       0 if (!defined $data{$key}) {
2040 0         0 $data{$key} = "";
2041             }
2042              
2043 0         0 my $reserved = 0;
2044 0         0 foreach my $res (@{$self->{reserved}}) {
  0         0  
2045 0 0       0 if ($res eq $key) {
2046 0         0 $reserved = 1;
2047 0         0 last;
2048             }
2049             }
2050              
2051 0 0       0 if ($reserved) {
2052 0 0       0 if ($data{$key} eq "") {
2053 0         0 delete $self->{globals}->{$key};
2054             }
2055             else {
2056 0         0 $self->{globals}->{$key} = $data{$key};
2057             }
2058             }
2059             else {
2060 0 0       0 if ($data{$key} eq "") {
2061 0         0 delete $self->{$key};
2062             }
2063             else {
2064 0         0 $self->{$key} = $data{$key};
2065             }
2066             }
2067             }
2068              
2069 0         0 return 1;
2070             }
2071              
2072             =item bool setVariable (hash %DATA)
2073              
2074             Set one or more bot variables (things that describe your bot's personality).
2075              
2076             This is equivalent to C in RiveScript code.
2077              
2078             =cut
2079              
2080             sub setVariable {
2081 0     0 1 0 my ($self,%data) = @_;
2082              
2083 0         0 foreach my $key (keys %data) {
2084 0 0       0 if (!defined $data{$key}) {
2085 0         0 $data{$key} = "";
2086             }
2087              
2088 0 0       0 if ($data{$key} eq "") {
2089 0         0 delete $self->{bot}->{$key};
2090             }
2091             else {
2092 0         0 $self->{bot}->{$key} = $data{$key};
2093             }
2094             }
2095              
2096 0         0 return 1;
2097             }
2098              
2099             =item bool setSubstitution (hash %DATA)
2100              
2101             Set one or more substitution patterns. The keys should be the original word, and
2102             the value should be the word to substitute with it.
2103              
2104             $rs->setSubstitution (
2105             q{what's} => 'what is',
2106             q{what're} => 'what are',
2107             );
2108              
2109             This is equivalent to C in RiveScript code.
2110              
2111             =cut
2112              
2113             sub setSubstitution {
2114 0     0 1 0 my ($self,%data) = @_;
2115              
2116 0         0 foreach my $key (keys %data) {
2117 0 0       0 if (!defined $data{$key}) {
2118 0         0 $data{$key} = "";
2119             }
2120              
2121 0 0       0 if ($data{$key} eq "") {
2122 0         0 delete $self->{subs}->{$key};
2123             }
2124             else {
2125 0         0 $self->{subs}->{$key} = $data{$key};
2126             }
2127             }
2128              
2129 0         0 return 1;
2130             }
2131              
2132             =item bool setPerson (hash %DATA)
2133              
2134             Set a person substitution. This is equivalent to C in RiveScript code.
2135              
2136             =cut
2137              
2138             sub setPerson {
2139 0     0 1 0 my ($self,%data) = @_;
2140              
2141 0         0 foreach my $key (keys %data) {
2142 0 0       0 if (!defined $data{$key}) {
2143 0         0 $data{$key} = "";
2144             }
2145              
2146 0 0       0 if ($data{$key} eq "") {
2147 0         0 delete $self->{person}->{$key};
2148             }
2149             else {
2150 0         0 $self->{person}->{$key} = $data{$key};
2151             }
2152             }
2153              
2154 0         0 return 1;
2155             }
2156              
2157             =item bool setUservar (string $USER, hash %DATA)
2158              
2159             Set a variable for a user. C<$USER> should be their User ID, and C<%DATA> is a
2160             hash containing variable/value pairs.
2161              
2162             This is like CsetE> for a specific user.
2163              
2164             =cut
2165              
2166             sub setUservar {
2167 7     7 1 3198 my ($self,$user,%data) = @_;
2168              
2169 7         23 foreach my $key (keys %data) {
2170 7 50       22 if (!defined $data{$key}) {
2171 0         0 $data{$key} = "";
2172             }
2173              
2174 7 50       16 if ($data{$key} eq "") {
2175 0         0 delete $self->{client}->{$user}->{$key};
2176             }
2177             else {
2178 7         19 $self->{client}->{$user}->{$key} = $data{$key};
2179             }
2180             }
2181              
2182 7         20 return 1;
2183             }
2184              
2185             =item string getUservar (string $USER, string $VAR)
2186              
2187             This is an alias for getUservars, and is here because it makes more grammatical
2188             sense.
2189              
2190             =cut
2191              
2192             sub getUservar {
2193             # Alias for getUservars.
2194 3     3 1 1699 my $self = shift;
2195 3         8 return $self->getUservars (@_);
2196             }
2197              
2198             =item data getUservars ([string $USER][, string $VAR])
2199              
2200             Get all the variables about a user. If a username is provided, returns a hash
2201             B containing that user's information. Else, a hash reference of all
2202             the users and their information is returned.
2203              
2204             You can optionally pass a second argument, C<$VAR>, to get a specific variable
2205             that belongs to the user. For instance, C.
2206              
2207             This is like CgetE> for a specific user or for all users.
2208              
2209             =cut
2210              
2211             sub getUservars {
2212 3     3 1 7 my ($self,$user,$var) = @_;
2213 3 50       8 $user = '' unless defined $user;
2214 3 50       5 $var = '' unless defined $var;
2215              
2216             # Did they want a specific variable?
2217 3 50 33     21 if (length $user && length $var) {
2218 3 100       9 if (exists $self->{client}->{$user}->{$var}) {
2219 2         9 return $self->{client}->{$user}->{$var};
2220             }
2221             else {
2222 1         3 return undef;
2223             }
2224             }
2225              
2226 0 0       0 if (length $user) {
2227 0         0 return $self->{client}->{$user};
2228             }
2229             else {
2230 0         0 return $self->{client};
2231             }
2232             }
2233              
2234             =item bool clearUservars ([string $USER])
2235              
2236             Clears all variables about C<$USER>. If no C<$USER> is provided, clears all
2237             variables about all users.
2238              
2239             =cut
2240              
2241             sub clearUservars {
2242 0     0 1 0 my $self = shift;
2243 0   0     0 my $user = shift || '';
2244              
2245 0 0       0 if (length $user) {
2246 0         0 foreach my $var (keys %{$self->{client}->{$user}}) {
  0         0  
2247 0         0 delete $self->{client}->{$user}->{$var};
2248             }
2249 0         0 delete $self->{client}->{$user};
2250             }
2251             else {
2252 0         0 foreach my $client (keys %{$self->{client}}) {
  0         0  
2253 0         0 foreach my $var (keys %{$self->{client}->{$client}}) {
  0         0  
2254 0         0 delete $self->{client}->{$client}->{$var};
2255             }
2256 0         0 delete $self->{client}->{$client};
2257             }
2258             }
2259              
2260 0         0 return 1;
2261             }
2262              
2263             =item bool freezeUservars (string $USER)
2264              
2265             Freeze the current state of variables for user C<$USER>. This will back up the
2266             user's current state (their variables and reply history). This won't statically
2267             prevent the user's state from changing; it merely saves its current state. Then
2268             use thawUservars() to revert back to this previous state.
2269              
2270             =cut
2271              
2272             sub freezeUservars {
2273 0     0 1 0 my ($self,$user) = @_;
2274 0 0       0 $user = '' unless defined $user;
2275              
2276 0 0 0     0 if (length $user && exists $self->{client}->{$user}) {
2277             # Freeze their variables. First unfreeze the last copy if they
2278             # exist.
2279 0 0       0 if (exists $self->{frozen}->{$user}) {
2280 0         0 $self->thawUservars ($user, discard => 1);
2281             }
2282              
2283             # Back up all our variables.
2284 0         0 foreach my $var (keys %{$self->{client}->{$user}}) {
  0         0  
2285 0 0       0 next if $var eq "__history__";
2286 0         0 my $value = $self->{client}->{$user}->{$var};
2287 0         0 $self->{frozen}->{$user}->{$var} = $value;
2288             }
2289              
2290             # Back up the history.
2291             $self->{frozen}->{$user}->{__history__}->{input} = [
2292 0         0 @{$self->{client}->{$user}->{__history__}->{input}},
  0         0  
2293             ];
2294             $self->{frozen}->{$user}->{__history__}->{reply} = [
2295 0         0 @{$self->{client}->{$user}->{__history__}->{reply}},
  0         0  
2296             ];
2297              
2298 0         0 return 1;
2299             }
2300              
2301 0         0 return undef;
2302             }
2303              
2304             =item bool thawUservars (string $USER[, hash %OPTIONS])
2305              
2306             If the variables for C<$USER> were previously frozen, this method will restore
2307             them to the state they were in when they were last frozen. It will then delete
2308             the stored cache by default. The following options are accepted as an additional
2309             hash of parameters (these options are mutually exclusive and you shouldn't use
2310             both of them at the same time. If you do, "discard" will win.):
2311              
2312             discard: Don't restore the user's state from the frozen copy, just delete the
2313             frozen copy.
2314             keep: Keep the frozen copy even after restoring the user's state. With this
2315             you can repeatedly thawUservars on the same user to revert their state
2316             without having to keep freezing them again. On the next freeze, the
2317             last frozen state will be replaced with the new current state.
2318              
2319             Examples:
2320              
2321             # Delete the frozen cache but don't modify the user's variables.
2322             $rs->thawUservars ("soandso", discard => 1);
2323              
2324             # Restore the user's state from cache, but don't delete the cache.
2325             $rs->thawUservars ("soandso", keep => 1);
2326              
2327             =cut
2328              
2329             sub thawUservars {
2330 0     0 1 0 my ($self,$user,%args) = @_;
2331 0 0       0 $user = '' unless defined $user;
2332              
2333 0 0 0     0 if (length $user && exists $self->{frozen}->{$user}) {
2334             # What are we doing?
2335 0         0 my $restore = 1;
2336 0         0 my $discard = 1;
2337 0 0       0 if (exists $args{discard}) {
    0          
2338             # Just discard the variables.
2339 0         0 $restore = 0;
2340 0         0 $discard = 1;
2341             }
2342             elsif (exists $args{keep}) {
2343             # Keep the cache afterwards.
2344 0         0 $restore = 1;
2345 0         0 $discard = 0;
2346             }
2347              
2348             # Restore the state?
2349 0 0       0 if ($restore) {
2350             # Clear the client's current information.
2351 0         0 $self->clearUservars ($user);
2352              
2353             # Restore all our variables.
2354 0         0 foreach my $var (keys %{$self->{frozen}->{$user}}) {
  0         0  
2355 0 0       0 next if $var eq "__history__";
2356 0         0 my $value = $self->{frozen}->{$user}->{$var};
2357 0         0 $self->{client}->{$user}->{$var} = $value;
2358             }
2359              
2360             # Restore the history.
2361             $self->{client}->{$user}->{__history__}->{input} = [
2362 0         0 @{$self->{frozen}->{$user}->{__history__}->{input}},
  0         0  
2363             ];
2364             $self->{client}->{$user}->{__history__}->{reply} = [
2365 0         0 @{$self->{frozen}->{$user}->{__history__}->{reply}},
  0         0  
2366             ];
2367             }
2368              
2369             # Discard the cache?
2370 0 0       0 if ($discard) {
2371 0         0 foreach my $var (keys %{$self->{frozen}->{$user}}) {
  0         0  
2372 0         0 delete $self->{frozen}->{$user}->{$var};
2373             }
2374             }
2375 0         0 return 1;
2376             }
2377              
2378 0         0 return undef;
2379             }
2380              
2381             =item string lastMatch (string $USER)
2382              
2383             After fetching a reply for user C<$USER>, the C method will return the
2384             raw text of the trigger that the user has matched with their reply. This function
2385             may return undef in the event that the user B match any trigger at all
2386             (likely the last reply was "C" as well).
2387              
2388             =cut
2389              
2390             sub lastMatch {
2391 0     0 1 0 my ($self,$user) = @_;
2392 0 0       0 $user = '' unless defined $user;
2393              
2394             # Get this user's last matched trigger.
2395 0 0 0     0 if (length $user && exists $self->{client}->{$user}->{__lastmatch__}) {
2396 0         0 return $self->{client}->{$user}->{__lastmatch__};
2397             }
2398              
2399 0         0 return undef;
2400             }
2401              
2402             =item string currentUser ()
2403              
2404             Get the user ID of the current user chatting with the bot. This is mostly useful
2405             inside of a Perl object macro in RiveScript to get the user ID of the person who
2406             invoked the object macro (e.g., to get/set variables for them using the
2407             C<$rs> instance).
2408              
2409             This will return C if used outside the context of a reply (the value is
2410             unset at the end of the C method).
2411              
2412             =back
2413              
2414             =cut
2415              
2416             sub currentUser {
2417 0     0 1 0 my $self = shift;
2418              
2419 0 0       0 if (!defined $self->{current_user}) {
2420 0         0 $self->issue("currentUser() is meant to be used from within a Perl object macro!");
2421             }
2422              
2423 0         0 return $self->{current_user};
2424             }
2425              
2426             ################################################################################
2427             ## Interaction Methods ##
2428             ################################################################################
2429              
2430             =head2 INTERACTION
2431              
2432             =over 4
2433              
2434             =item string reply (string $USER, string $MESSAGE)
2435              
2436             Fetch a response to C<$MESSAGE> from user C<$USER>. RiveScript will take care of
2437             lowercasing, running substitutions, and removing punctuation from the message.
2438              
2439             Returns a response from the RiveScript brain.
2440              
2441             =back
2442              
2443             =cut
2444              
2445             sub reply {
2446 158     158 1 68595 my ($self,$user,$msg) = @_;
2447              
2448 158         583 $self->debug ("Get reply to [$user] $msg");
2449              
2450             # Store the current user's ID.
2451 158         285 $self->{current_user} = $user;
2452              
2453             # Format their message.
2454 158         398 $msg = $self->_formatMessage ($msg);
2455              
2456 158         262 my $reply = '';
2457              
2458             # If the BEGIN statement exists, consult it first.
2459 158 100       353 if (exists $self->{topics}->{__begin__}->{request}) {
2460             # Get a response.
2461 5         12 my $begin = $self->_getreply ($user,'request',
2462             context => 'begin',
2463             step => 0, # Recursion redundancy counter
2464             );
2465              
2466             # Okay to continue?
2467 5 100       32 if ($begin =~ /\{ok\}/i) {
2468 4         10 $reply = $self->_getreply ($user,$msg,
2469             context => 'normal',
2470             step => 0,
2471             );
2472 4         16 $begin =~ s/\{ok\}/$reply/ig;
2473             }
2474              
2475 5         9 $reply = $begin;
2476              
2477             # Run more tag substitutions.
2478 5         14 $reply = $self->processTags ($user,$msg,$reply,[],[],0);
2479             }
2480             else {
2481             # Just continue then.
2482 153         359 $reply = $self->_getreply ($user,$msg,
2483             context => 'normal',
2484             step => 0,
2485             );
2486             }
2487              
2488             # Save their reply history.
2489 158         246 unshift (@{$self->{client}->{$user}->{__history__}->{input}}, $msg);
  158         427  
2490 158         245 while (scalar @{$self->{client}->{$user}->{__history__}->{input}} > 9) {
  316         704  
2491 158         194 pop (@{$self->{client}->{$user}->{__history__}->{input}});
  158         312  
2492             }
2493              
2494 158         206 unshift (@{$self->{client}->{$user}->{__history__}->{reply}}, $reply);
  158         352  
2495 158         199 while (scalar @{$self->{client}->{$user}->{__history__}->{reply}} > 9) {
  316         688  
2496 158         194 pop (@{$self->{client}->{$user}->{__history__}->{reply}});
  158         300  
2497             }
2498              
2499             # Unset the current user's ID.
2500 158         303 $self->{current_user} = undef;
2501              
2502 158         432 return $reply;
2503             }
2504              
2505             sub _getreply {
2506 216     216   736 my ($self,$user,$msg,%tags) = @_;
2507              
2508             # Need to sort replies?
2509 216 50       319 if (scalar keys %{$self->{sorted}} == 0) {
  216         635  
2510 0         0 $self->issue ("ERR: You never called sortReplies()! Start doing that from now on!");
2511 0         0 $self->sortReplies();
2512             }
2513              
2514             # Collect info on this user if we have it.
2515 216         336 my $topic = 'random';
2516 216         303 my @stars = ();
2517 216         279 my @thatstars = (); # For %previous's.
2518 216         292 my $reply = '';
2519 216 100       460 if (exists $self->{client}->{$user}) {
2520 191         373 $topic = $self->{client}->{$user}->{topic};
2521             }
2522             else {
2523 25         57 $self->{client}->{$user}->{topic} = 'random';
2524             }
2525              
2526             # Avoid letting the user fall into a missing topic.
2527 216 50       478 if (!exists $self->{topics}->{$topic}) {
2528 0         0 $self->issue ("User $user was in an empty topic named '$topic'!");
2529 0         0 $topic = 'random';
2530 0         0 $self->{client}->{$user}->{topic} = 'random';
2531             }
2532              
2533             # Avoid deep recursion.
2534 216 100       463 if ($tags{step} > $self->{depth}) {
2535 1         11 my $ref = '';
2536 1 50       10 if (exists $self->{syntax}->{$topic}->{$msg}->{ref}) {
2537 1         4 $ref = " at $self->{syntax}->{$topic}->{$msg}->{ref}";
2538             }
2539 1         6 $self->issue ("ERR: Deep Recursion Detected$ref!");
2540 1         10 return "ERR: Deep Recursion Detected$ref!";
2541             }
2542              
2543             # Are we in the BEGIN Statement?
2544 215 100       417 if ($tags{context} eq 'begin') {
2545             # Imply some defaults.
2546 5         8 $topic = '__begin__';
2547             }
2548              
2549             # Track this user's history.
2550 215 100       464 if (!exists $self->{client}->{$user}->{__history__}) {
2551             $self->{client}->{$user}->{__history__}->{input} = [
2552 26         86 'undefined', 'undefined', 'undefined', 'undefined',
2553             'undefined', 'undefined', 'undefined', 'undefined',
2554             'undefined',
2555             ];
2556             $self->{client}->{$user}->{__history__}->{reply} = [
2557 26         75 'undefined', 'undefined', 'undefined', 'undefined',
2558             'undefined', 'undefined', 'undefined', 'undefined',
2559             'undefined',
2560             ];
2561             }
2562              
2563             # Create a pointer for the matched data (be it %previous or +trigger).
2564 215         364 my $matched = {};
2565 215         332 my $matchedTrigger = undef;
2566 215         276 my $foundMatch = 0;
2567              
2568             # See if there are any %previous's in this topic, or any topic related to it. This
2569             # should only be done the first time -- not during a recursive @/{@} redirection.
2570             # This is because in a redirection, "lastreply" is still gonna be the same as it was
2571             # the first time, causing an infinite loop.
2572 215 100       432 if ($tags{step} == 0) {
2573 162         312 my @allTopics = ($topic);
2574 162 100 100     637 if (exists $self->{includes}->{$topic} || exists $self->{lineage}->{$topic}) {
2575 14         31 (@allTopics) = $self->_getTopicTree ($topic,0);
2576             }
2577 162         283 foreach my $top (@allTopics) {
2578 185         526 $self->debug ("Checking topic $top for any %previous's.");
2579 185 100       378 if (exists $self->{sortsthat}->{$top}) {
2580 13         28 $self->debug ("There's a %previous in this topic");
2581              
2582             # Do we have history yet?
2583 13 50       16 if (scalar @{$self->{client}->{$user}->{__history__}->{reply}} > 0) {
  13         35  
2584 13         23 my $lastReply = $self->{client}->{$user}->{__history__}->{reply}->[0];
2585              
2586             # Format the bot's last reply the same as the human's.
2587 13         27 $lastReply = $self->_formatMessage ($lastReply, "lastReply");
2588              
2589 13         44 $self->debug ("lastReply: $lastReply");
2590              
2591             # See if we find a match.
2592 13         17 foreach my $trig (@{$self->{sortsthat}->{$top}}) {
  13         28  
2593 42         91 my $botside = $self->_reply_regexp ($user,$trig);
2594              
2595 42         147 $self->debug ("Try to match lastReply ($lastReply) to $botside");
2596              
2597             # Look for a match.
2598 42 100       520 if ($lastReply =~ /^$botside$/i) {
2599             # Found a match! See if our message is correct too.
2600 7         81 (@thatstars) = ($lastReply =~ /^$botside$/i);
2601 7         14 foreach my $subtrig (@{$self->{sortedthat}->{$top}->{$trig}}) {
  7         22  
2602 7         15 my $humanside = $self->_reply_regexp ($user,$subtrig);
2603              
2604 7         44 $self->debug ("Now try to match $msg to $humanside");
2605              
2606 7 50       63 if ($msg =~ /^$humanside$/i) {
2607 7         22 $self->debug ("Found a match!");
2608 7         23 $matched = $self->{thats}->{$top}->{$trig}->{$subtrig};
2609 7         12 $matchedTrigger = $top;
2610 7         9 $foundMatch = 1;
2611              
2612             # Get the stars.
2613 7         48 (@stars) = ($msg =~ /^$humanside$/i);
2614 7         18 last;
2615             }
2616             }
2617             }
2618              
2619             # Break if we've found a match.
2620 42 100       109 last if $foundMatch;
2621             }
2622             }
2623             }
2624              
2625             # Break if we've found a match.
2626 185 100       421 last if $foundMatch;
2627             }
2628             }
2629              
2630             # Search their topic for a match to their trigger.
2631 215 100       422 if (not $foundMatch) {
2632 208         335 foreach my $trig (@{$self->{sorted}->{$topic}}) {
  208         425  
2633             # Process the triggers.
2634 431         957 my $regexp = $self->_reply_regexp ($user,$trig);
2635              
2636 431         1484 $self->debug ("Trying to match \"$msg\" against $trig ($regexp)");
2637              
2638 431 100       6456 if ($msg =~ /^$regexp$/i) {
2639 190         534 $self->debug ("Found a match!");
2640              
2641             # We found a match, but what if the trigger we matched belongs to
2642             # an inherited topic? Check for that.
2643 190 100       403 if (exists $self->{topics}->{$topic}->{$trig}) {
2644             # No, the trigger does belong to our own topic.
2645 181         398 $matched = $self->{topics}->{$topic}->{$trig};
2646             }
2647             else {
2648             # Our topic doesn't have this trigger. Check inheritence.
2649 9         20 $matched = $self->_findTriggerByInheritence ($topic,$trig,0);
2650             }
2651              
2652 190         275 $foundMatch = 1;
2653 190         246 $matchedTrigger = $trig;
2654              
2655             # Get the stars.
2656 190         1739 (@stars) = ($msg =~ /^$regexp$/i);
2657 190         482 last;
2658             }
2659             }
2660             }
2661              
2662             # Store what trigger they matched on (if $matched is undef, this will be
2663             # too, which is great).
2664 215         466 $self->{client}->{$user}->{__lastmatch__} = $matchedTrigger;
2665              
2666 215         442 for (defined $matched) {
2667             # See if there are any hard redirects.
2668 215 100       457 if (exists $matched->{redirect}) {
2669 52         175 $self->debug ("Redirecting us to $matched->{redirect}");
2670 52         86 my $redirect = $matched->{redirect};
2671 52         193 $redirect = $self->processTags ($user,$msg,$redirect,[@stars],[@thatstars],$tags{step});
2672 52         201 $self->debug ("Pretend user asked: $redirect");
2673             $reply = $self->_getreply ($user,$redirect,
2674             context => $tags{context},
2675 52         1949 step => ($tags{step} + 1),
2676             );
2677 52         102 last;
2678             }
2679              
2680             # Check the conditionals.
2681 163 100       297 if (exists $matched->{condition}) {
2682 15         32 $self->debug ("Checking conditionals");
2683 15         46 for (my $i = 0; exists $matched->{condition}->{$i}; $i++) {
2684 39         236 my ($cond,$potreply) = split(/\s*=>\s*/, $matched->{condition}->{$i}, 2);
2685 39         261 my ($left,$eq,$right) = ($cond =~ /^(.+?)\s+(==|eq|\!=|ne|\<\>|\<|\<=|\>|\>=)\s+(.+?)$/i);
2686              
2687 39         135 $self->debug ("\tLeft: $left; EQ: $eq; Right: $right");
2688              
2689             # Process tags on all of these.
2690 39         124 $left = $self->processTags ($user,$msg,$left,[@stars],[@thatstars],$tags{step});
2691 39         147 $right = $self->processTags ($user,$msg,$right,[@stars],[@thatstars],$tags{step});
2692              
2693             # Revert them to undefined values.
2694 39 50       89 $left = 'undefined' if $left eq '';
2695 39 50       71 $right = 'undefined' if $right eq '';
2696              
2697 39         130 $self->debug ("\t\tCheck if \"$left\" $eq \"$right\"");
2698              
2699             # Validate the expression.
2700 39         58 my $match = 0;
2701 39 100 66     216 if ($eq eq 'eq' || $eq eq '==') {
    100 66        
    100 66        
    50          
    100          
    50          
2702 19 100       36 if ($left eq $right) {
2703 4         7 $match = 1;
2704             }
2705             }
2706             elsif ($eq eq 'ne' || $eq eq '!=' || $eq eq '<>') {
2707 4 100       12 if ($left ne $right) {
2708 2         3 $match = 1;
2709             }
2710             }
2711             elsif ($eq eq '<') {
2712 1 50       5 if ($left < $right) {
2713 1         2 $match = 1;
2714             }
2715             }
2716             elsif ($eq eq '<=') {
2717 0 0       0 if ($left <= $right) {
2718 0         0 $match = 1;
2719             }
2720             }
2721             elsif ($eq eq '>') {
2722 7 100       22 if ($left > $right) {
2723 1         3 $match = 1;
2724             }
2725             }
2726             elsif ($eq eq '>=') {
2727 8 100       21 if ($left >= $right) {
2728 4         7 $match = 1;
2729             }
2730             }
2731              
2732 39 100       115 if ($match) {
2733             # Condition is true.
2734 12         16 $reply = $potreply;
2735 12         25 last;
2736             }
2737             }
2738             }
2739 163 100       332 last if length $reply > 0;
2740              
2741             # Process weights in the replies.
2742 151         218 my @bucket = ();
2743 151         312 $self->debug ("Processing responses to this trigger.");
2744 151         392 for (my $rep = 0; exists $matched->{reply}->{$rep}; $rep++) {
2745 133         225 my $text = $matched->{reply}->{$rep};
2746 133         169 my $weight = 1;
2747 133 50       271 if ($text =~ /{weight=(\d+)\}/i) {
2748 0         0 $weight = $1;
2749 0 0       0 if ($weight <= 0) {
2750 0         0 $weight = 1;
2751 0         0 $self->issue ("Can't have a weight < 0!");
2752             }
2753             }
2754 133         275 for (my $i = 0; $i < $weight; $i++) {
2755 133         462 push (@bucket,$text);
2756             }
2757             }
2758              
2759             # Get a random reply.
2760 151         537 $reply = $bucket [ int(rand(scalar(@bucket))) ];
2761 151         296 last;
2762             }
2763              
2764             # Still no reply?
2765 215 100 33     827 if ($foundMatch == 0) {
    50          
2766 18         26 $reply = RS_ERR_MATCH;
2767             }
2768             elsif (!defined $reply || length $reply == 0) {
2769 0         0 $reply = RS_ERR_REPLY;
2770             }
2771              
2772 215         675 $self->debug ("Reply: $reply");
2773              
2774             # Process tags for the BEGIN Statement.
2775 215 100       481 if ($tags{context} eq 'begin') {
2776 5 50       16 if ($reply =~ /\{topic=(.+?)\}/i) {
2777             # Set the user's topic.
2778 0         0 $self->debug ("Topic set to $1");
2779 0         0 $self->{client}->{$user}->{topic} = $1;
2780 0         0 $reply =~ s/\{topic=(.+?)\}//ig;
2781             }
2782 5         13 while ($reply =~ //i) {
2783             # Set a user variable.
2784 1         7 $self->debug ("Set uservar $1 => $2");
2785 1         3 $self->{client}->{$user}->{$1} = $2;
2786 1         5 $reply =~ s///i;
2787             }
2788             }
2789             else {
2790             # Process more tags if not in BEGIN.
2791 210         720 $reply = $self->processTags($user,$msg,$reply,[@stars],[@thatstars],$tags{step});
2792             }
2793              
2794 215         726 return $reply;
2795             }
2796              
2797             sub _findTriggerByInheritence {
2798 13     13   25 my ($self,$topic,$trig,$depth) = @_;
2799              
2800             # This sub was called because the user matched a trigger from the
2801             # sorted array, but the trigger doesn't exist under the topic of
2802             # which the user currently belongs. It probably was a trigger
2803             # inherited/included from another topic. This subroutine finds that out,
2804             # recursively, following the inheritence trail.
2805              
2806             # Take care to prevent infinite recursion.
2807 13 50       26 if ($depth > $self->{depth}) {
2808 0         0 $self->issue("Deep recursion detected while following an inheritence trail (involving topic $topic and trigger $trig)");
2809 0         0 return undef;
2810             }
2811              
2812             # Inheritence is more important than inclusion: triggers in one topic
2813             # can override those in an inherited topic.
2814 13 100       30 if (exists $self->{lineage}->{$topic}) {
2815 3         8 foreach my $inherits (sort { $a cmp $b } keys %{$self->{lineage}->{$topic}}) {
  0         0  
  3         12  
2816             # See if this inherited topic has our trigger.
2817 3 100       12 if (exists $self->{topics}->{$inherits}->{$trig}) {
2818             # Great!
2819 1         3 return $self->{topics}->{$inherits}->{$trig};
2820             }
2821             else {
2822             # Check what this topic inherits from.
2823 2         7 my $match = $self->_findTriggerByInheritence (
2824             $inherits, $trig, ($depth + 1),
2825             );
2826 2 50       6 if (defined $match) {
2827             # Finally got a match.
2828 2         7 return $match;
2829             }
2830             }
2831             }
2832             }
2833              
2834             # See if this topic has an "includes".
2835 10 100       21 if (exists $self->{includes}->{$topic}) {
2836 8         9 foreach my $includes (sort { $a cmp $b } keys %{$self->{includes}->{$topic}}) {
  4         14  
  8         28  
2837              
2838             # See if this included topic has our trigger.
2839 10 100       34 if (exists $self->{topics}->{$includes}->{$trig}) {
2840             # Great!
2841 8         30 return $self->{topics}->{$includes}->{$trig};
2842             }
2843             else {
2844             # Check what this topic includes from.
2845 2         10 my $match = $self->_findTriggerByInheritence (
2846             $includes, $trig, ($depth + 1),
2847             );
2848 2 50       7 if (defined $match) {
2849             # Finally got a match.
2850 0         0 return $match;
2851             }
2852             }
2853             }
2854             }
2855              
2856             # Don't know what else we can do.
2857 2         4 return undef;
2858             }
2859              
2860             sub _reply_regexp {
2861 480     480   823 my ($self,$user,$regexp) = @_;
2862              
2863             # If the trigger is simply /^\*$/ (+ *) then the * there needs to
2864             # become (.*?) to match the blank string too.
2865 480         793 $regexp =~ s/^\*$//i;
2866              
2867 480         807 $regexp =~ s/\*/(.+?)/ig; # Convert * into (.+?)
2868 480         660 $regexp =~ s/\#/(\\d+)/ig; # Convert # into ([0-9]+?)
2869 480         688 $regexp =~ s/\_/(\\w+)/ig; # Convert _ into ([A-Za-z]+?)
2870 480         634 $regexp =~ s/\s*\{weight=\d+\}\s*//ig; # Remove {weight} tags.
2871 480         791 $regexp =~ s//(.*?)/i;
2872 480         1128 while ($regexp =~ /\[(.+?)\]/i) { # Optionals
2873 53         176 my @parts = split(/\|/, $1);
2874 53         90 my @new = ();
2875 53         83 foreach my $p (@parts) {
2876 75         168 $p = '(?:\s|\b)+' . $p . '(?:\s|\b)+';
2877 75         123 push (@new,$p);
2878             }
2879              
2880             # If this optional had a star or anything in it, e.g. [*],
2881             # make that non-matching.
2882 53         118 my $pipes = join("|",@new);
2883 53         85 $pipes =~ s/\(\.\+\?\)/(?:.+?)/ig; # (.+?) --> (?:.+?)
2884 53         92 $pipes =~ s/\(\\d\+\)/(?:\\d+)/ig; # (\d+) --> (?:\d+)
2885 53         76 $pipes =~ s/\(\\w\+\)/(?:\\w+)/ig; # (\w+) --> (?:\w+)
2886              
2887 53         95 my $rep = "(?:$pipes|(?:\\s|\\b)+)";
2888 53         312 $regexp =~ s/\s*\[(.+?)\]\s*/$rep/i;
2889             }
2890              
2891             # _ wildcards can't match numbers!
2892 480         714 $regexp =~ s/\\w/[A-Za-z]/g;
2893              
2894             # Filter in arrays.
2895 480         961 while ($regexp =~ /\@(.+?)\b/) {
2896 16         39 my $name = $1;
2897 16         24 my $rep = '';
2898 16 50       36 if (exists $self->{arrays}->{$name}) {
2899 16         21 $rep = '(?:' . join ("|",@{$self->{arrays}->{$name}}) . ')';
  16         53  
2900             }
2901 16         82 $regexp =~ s/\@(.+?)\b/$rep/i;
2902             }
2903              
2904             # Filter in bot variables.
2905 480         885 while ($regexp =~ //i) {
2906 0         0 my $var = $1;
2907 0         0 my $rep = '';
2908 0 0       0 if (exists $self->{bot}->{$var}) {
2909 0         0 $rep = $self->{bot}->{$var};
2910 0         0 $rep =~ s/[^A-Za-z0-9 ]//ig;
2911 0         0 $rep = lc($rep);
2912             }
2913 0         0 $regexp =~ s//$rep/i;
2914             }
2915              
2916             # Filter in user variables.
2917 480         872 while ($regexp =~ //i) {
2918 0         0 my $var = $1;
2919 0         0 my $rep = '';
2920 0 0       0 if (exists $self->{client}->{$user}->{$var}) {
2921 0         0 $rep = $self->{client}->{$user}->{$var};
2922 0         0 $rep =~ s/[^A-Za-z0-9 ]//ig;
2923 0         0 $rep = lc($rep);
2924             }
2925 0         0 $regexp =~ s//$rep/i;
2926             }
2927              
2928             # Filter input tags.
2929 480 50       977 if ($regexp =~ /
2930 0   0     0 my $firstInput = $self->_formatMessage($self->{client}->{$user}->{__history__}->{input}->[0] || "undefined", "botReply");
2931 0         0 $regexp =~ s//$firstInput/ig;
2932 0         0 while ($regexp =~ //i) {
2933 0         0 my $index = $1;
2934 0         0 my (@arrInput) = @{$self->{client}->{$user}->{__history__}->{input}};
  0         0  
2935 0         0 unshift (@arrInput,'');
2936 0         0 my $line = $arrInput[$index];
2937 0         0 $line = $self->_formatMessage ($line, "botReply");
2938 0         0 $regexp =~ s//$line/ig;
2939             }
2940             }
2941 480 50       838 if ($regexp =~ /
2942 0   0     0 my $firstReply = $self->_formatMessage($self->{client}->{$user}->{__history__}->{reply}->[0] || "undefined", "botReply");
2943 0         0 $regexp =~ s//$firstReply/ig;
2944 0         0 while ($regexp =~ //i) {
2945 0         0 my $index = $1;
2946 0         0 my (@arrReply) = @{$self->{client}->{$user}->{__history__}->{reply}};
  0         0  
2947 0         0 unshift (@arrReply,'');
2948 0         0 my $line = $arrReply[$index];
2949 0         0 $line = $self->_formatMessage ($line, "botReply");
2950 0         0 $regexp =~ s//$line/ig;
2951             }
2952             }
2953              
2954 480         937 return $regexp;
2955             }
2956              
2957             sub processTags {
2958 345     345 0 742 my ($self,$user,$msg,$reply,$st,$bst,$depth) = @_;
2959 345         432 my (@stars) = (@{$st});
  345         636  
2960 345         459 my (@botstars) = (@{$bst});
  345         502  
2961 345         632 unshift (@stars,"");
2962 345         513 unshift (@botstars,"");
2963 345 100       649 if (scalar(@stars) == 1) {
2964 23         32 push (@stars,'undefined');
2965             }
2966 345 100       694 if (scalar(@botstars) == 1) {
2967 338         487 push (@botstars,'undefined');
2968             }
2969              
2970 345         452 my (@arrInput) = @{$self->{client}->{$user}->{__history__}->{input}};
  345         975  
2971 345         476 my (@arrReply) = @{$self->{client}->{$user}->{__history__}->{reply}};
  345         903  
2972              
2973 345   50     728 my $lastInput = $arrInput[0] || 'undefined';
2974 345   50     598 my $lastReply = $arrReply[0] || 'undefined';
2975 345         543 unshift(@arrInput,'');
2976 345         514 unshift(@arrReply,'');
2977              
2978             # Tag Shortcuts.
2979 345         628 $reply =~ s//{person}{\/person}/ig;
2980 345         568 $reply =~ s/<\@>/{\@}/ig;
2981 345         474 $reply =~ s//{formal}{\/formal}/ig;
2982 345         453 $reply =~ s//{sentence}{\/sentence}/ig;
2983 345         501 $reply =~ s//{uppercase}{\/uppercase}/ig;
2984 345         459 $reply =~ s//{lowercase}{\/lowercase}/ig;
2985              
2986             # Quick tags.
2987 345         448 $reply =~ s/\{weight=(\d+)\}//ig; # Remove leftover {weight}s
2988 345 50       698 if (scalar(@stars) > 0) {
2989 345 50       802 $reply =~ s//$stars[1]/ig if defined $stars[1];
2990 345 50       531 $reply =~ s//(defined $stars[$1] ? $stars[$1] : '')/ieg;
  10         55  
2991             }
2992 345 50       658 if (scalar(@botstars) > 0) {
2993 345         467 $reply =~ s//$botstars[1]/ig;
2994 345 0       451 $reply =~ s//(defined $botstars[$1] ? $botstars[$1] : '')/ieg;
  0         0  
2995             }
2996 345         516 $reply =~ s//$lastInput/ig;
2997 345         495 $reply =~ s//$lastReply/ig;
2998 345         437 $reply =~ s//$arrInput[$1]/ig;
2999 345         467 $reply =~ s//$arrReply[$1]/ig;
3000 345         507 $reply =~ s//$user/ig;
3001 345         541 $reply =~ s/\\s/ /ig;
3002 345         510 $reply =~ s/\\n/\n/ig;
3003 345         468 $reply =~ s/\\/\\/ig;
3004 345         460 $reply =~ s/\\#/#/ig;
3005              
3006 345         715 while ($reply =~ /\{random\}(.+?)\{\/random\}/i) {
3007 0         0 my $rand = $1;
3008 0         0 my $output = '';
3009 0 0       0 if ($rand =~ /\|/) {
3010 0         0 my @tmp = split(/\|/, $rand);
3011 0         0 $output = $tmp [ int(rand(scalar(@tmp))) ];
3012             }
3013             else {
3014 0         0 my @tmp = split(/\s+/, $rand);
3015 0         0 $output = $tmp [ int(rand(scalar(@tmp))) ];
3016             }
3017 0         0 $reply =~ s/\{random\}(.+?)\{\/random\}/$output/i;
3018             }
3019 345         644 while ($reply =~ /\{\!(.+?)\}/i) {
3020             # Just stream this back through.
3021 0         0 $self->stream ("! $1");
3022 0         0 $reply =~ s/\{\!(.+?)\}//i;
3023             }
3024 345         619 while ($reply =~ /\{person\}(.+?)\{\/person\}/i) {
3025 4         9 my $person = $1;
3026 4         11 $person = $self->_personSub ($person);
3027 4         20 $reply =~ s/\{person\}(.+?)\{\/person\}/$person/i;
3028             }
3029 345         685 while ($reply =~ /\{formal\}(.+?)\{\/formal\}/i) {
3030 3         7 my $formal = $1;
3031 3         9 $formal = $self->_stringUtil ('formal',$formal);
3032 3         17 $reply =~ s/\{formal\}(.+?)\{\/formal\}/$formal/i;
3033             }
3034 345         631 while ($reply =~ /\{sentence\}(.+?)\{\/sentence\}/i) {
3035 2         7 my $sentence = $1;
3036 2         5 $sentence = $self->_stringUtil ('sentence',$sentence);
3037 2         14 $reply =~ s/\{sentence\}(.+?)\{\/sentence\}/$sentence/i;
3038             }
3039 345         635 while ($reply =~ /\{uppercase\}(.+?)\{\/uppercase\}/i) {
3040 0         0 my $upper = $1;
3041 0         0 $upper = $self->_stringUtil ('upper',$upper);
3042 0         0 $reply =~ s/\{uppercase\}(.+?)\{\/uppercase\}/$upper/i;
3043             }
3044 345         624 while ($reply =~ /\{lowercase\}(.+?)\{\/lowercase\}/i) {
3045 0         0 my $lower = $1;
3046 0         0 $lower = $self->_stringUtil ('lower',$lower);
3047 0         0 $reply =~ s/\{lowercase\}(.+?)\{\/lowercase\}/$lower/i;
3048             }
3049              
3050             # Handle all variable-related tags with an iterative regexp approach,
3051             # to allow for nesting of tags in arbitrary ways (think >)
3052             # Dummy out the tags first, because we don't handle them right here.
3053 345         477 $reply =~ s//{__call__}/og;
3054 345         483 $reply =~ s/<\/call>/{\/__call__}/og;
3055 345         433 while (1) {
3056             # This regexp will match a which contains no other tag inside it,
3057             # i.e. in the case of > it will match but not the
3058             # tag, on the first pass. The second pass will get the tag,
3059             # and so on.
3060 414 100       992 if ($reply =~ /<([^<]+?)>/) {
3061 69         164 my $match = $1;
3062 69         213 my @parts = split(/\s+/, $match, 2);
3063 69         134 my $tag = lc($parts[0]);
3064 69   100     136 my $data = $parts[1] || "";
3065 69         94 my $insert = ""; # Result of the tag evaluation.
3066              
3067             # Handle the tags.
3068 69 100 100     317 if ($tag eq "bot" or $tag eq "env") {
    100          
    50          
    100          
3069             # and tags are similar.
3070 8         21 my ($what, $is) = split(/=/, $data, 2);
3071 8         15 my $target = $self->{bot};
3072 8 100       17 if ($tag eq "env") {
3073             # Reserved?
3074 3         5 my $reserved = 0;
3075 3         3 foreach my $res (@{$self->{reserved}}) {
  3         8  
3076 60 50       98 if ($res eq $what) {
3077 0         0 $reserved = 1;
3078 0         0 last;
3079             }
3080             }
3081 3 50       6 if ($reserved) {
3082 0         0 $target = $self->{globals};
3083             }
3084             else {
3085 3         6 $target = $self;
3086             }
3087             }
3088              
3089             # Updating?
3090 8 100       18 if ($data =~ /=/) {
3091 2         9 $self->debug("Set $tag variable $what => $is");
3092 2         4 $target->{$what} = $is;
3093             }
3094             else {
3095 6 100       17 $insert = exists $target->{$what} ? $target->{$what} : "undefined";
3096             }
3097             }
3098             elsif ($tag eq "set") {
3099             # user vars.
3100 12         68 my ($what, $is) = split(/=/, $data, 2);
3101 12         46 $self->debug("Set uservar $what => $is");
3102 12         31 $self->{client}->{$user}->{$what} = $is;
3103             }
3104             elsif ($tag =~ /^(?:add|sub|mult|div)$/) {
3105 0         0 my ($var, $value) = split(/=/, $data, 2);
3106              
3107             # Initialize the value?
3108 0 0       0 if (!exists $self->{client}->{$user}->{$var}) {
3109 0         0 $self->{client}->{$user}->{$var} = 0;
3110             }
3111              
3112             # Sanity checks.
3113 0 0       0 if ($self->{client}->{$user}->{$var} !~ /^[0-9\-\.]+$/) {
    0          
3114 0         0 $insert = "[ERR: Can't Modify Non-Numeric Variable $var]";
3115             }
3116             elsif ($value =~ /^[^0-9\-\.]$/) {
3117 0         0 $insert = "[ERR: Math Can't '$tag' Non-Numeric Value $value]";
3118             }
3119             else {
3120             # Modify the variable.
3121 0 0       0 if ($tag eq "add") {
    0          
    0          
    0          
3122 0         0 $self->{client}->{$user}->{$var} += $value;
3123             }
3124             elsif ($tag eq "sub") {
3125 0         0 $self->{client}->{$user}->{$var} -= $value;
3126             }
3127             elsif ($tag eq "mult") {
3128 0         0 $self->{client}->{$user}->{$var} *= $value;
3129             }
3130             elsif ($tag eq "div") {
3131             # Don't divide by zero.
3132 0 0       0 if ($value == 0) {
3133 0         0 $insert = "[ERR: Can't Divide By Zero]";
3134             }
3135             else {
3136 0         0 $self->{client}->{$user}->{$var} /= $value;
3137             }
3138             }
3139             }
3140             }
3141             elsif ($tag eq "get") {
3142 45 100       136 $insert = (exists $self->{client}->{$user}->{$data} ? $self->{client}->{$user}->{$data} : "undefined");
3143             }
3144             else {
3145             # Might be HTML tag, it's unrecognized. Preserve it.
3146 4         10 $insert = "\x00$match\x01";
3147             }
3148              
3149 69         668 $reply =~ s/<\Q$match\E>/$insert/i;
3150             }
3151             else {
3152 345         509 last; # No more tags remaining.
3153             }
3154             }
3155              
3156             # Recover mangled HTML-like tag parts.
3157 345         499 $reply =~ s/\x00/
3158 345         504 $reply =~ s/\x01/>/g;
3159              
3160 345 100       656 if ($reply =~ /\{topic=(.+?)\}/i) {
3161             # Set the user's topic.
3162 2         10 $self->debug ("Topic set to $1");
3163 2         6 $self->{client}->{$user}->{topic} = $1;
3164 2         9 $reply =~ s/\{topic=(.+?)\}//ig;
3165             }
3166 345         685 while ($reply =~ /\{\@(.+?)\}/i) {
3167 2         7 my $at = $1;
3168 2         5 $at =~ s/^\s+//ig;
3169 2         7 $at =~ s/\s+$//ig;
3170 2         17 my $subreply = $self->_getreply ($user,$at,
3171             context => 'normal',
3172             step => ($depth + 1),
3173             );
3174 2         15 $reply =~ s/\{\@(.+?)\}/$subreply/i;
3175             }
3176 345         494 $reply =~ s/\{__call__\}//g;
3177 345         424 $reply =~ s/\{\/__call__\}/<\/call>/g;
3178 345         641 while ($reply =~ /(.+?)<\/call>/i) {
3179 7         32 my ($obj,@args) = split(/\s+/, $1);
3180 7         13 my $output = '';
3181              
3182             # What language handles this object?
3183 7 100       21 my $lang = exists $self->{objlangs}->{$obj} ? $self->{objlangs}->{$obj} : '';
3184 7 100       14 if (length $lang) {
3185             # Do we handle this?
3186 5 50       11 if (exists $self->{handlers}->{$lang}) {
3187             # Ok.
3188 5         11 $output = &{ $self->{handlers}->{$lang} } ($self,"call",$obj,[@args]);
  5         27  
3189             }
3190             else {
3191 0         0 $output = '[ERR: No Object Handler]';
3192             }
3193             }
3194             else {
3195 2         5 $output = '[ERR: Object Not Found]';
3196             }
3197              
3198 7         41 $reply =~ s/(.+?)<\/call>/$output/i;
3199             }
3200              
3201 345         1232 return $reply;
3202             }
3203              
3204             sub _formatMessage {
3205 171     171   307 my ($self,$string, $botReply) = @_;
3206              
3207             # Lowercase it.
3208 171         343 $string = lc($string);
3209              
3210             # Make placeholders each time we substitute something.
3211 171         264 my @ph = ();
3212 171         264 my $i = 0;
3213              
3214             # Run substitutions on it.
3215 171         230 foreach my $pattern (@{$self->{sortlist}->{subs}}) {
  171         386  
3216 48         105 my $result = $self->{subs}->{$pattern};
3217              
3218             # Make a placeholder.
3219 48         86 push (@ph, $result);
3220 48         85 my $placeholder = "\x00$i\x00";
3221 48         65 $i++;
3222              
3223 48         70 my $qm = quotemeta($pattern);
3224 48         349 $string =~ s/^$qm$/$placeholder/ig;
3225 48         283 $string =~ s/^$qm(\W+)/$placeholder$1/ig;
3226 48         308 $string =~ s/(\W+)$qm(\W+)/$1$placeholder$2/ig;
3227 48         330 $string =~ s/(\W+)$qm$/$1$placeholder/ig;
3228             }
3229 171         526 while ($string =~ /\x00(\d+)\x00/i) {
3230 4         11 my $id = $1;
3231 4         11 my $result = $ph[$id];
3232 4         62 $string =~ s/\x00$id\x00/$result/i;
3233             }
3234              
3235             # In UTF-8 mode, only strip meta characters.
3236 171 100       374 if ($self->{utf8}) {
3237             # Backslashes and HTML tags
3238 24         57 $string =~ s/[\\<>]//g;
3239 24         119 $string =~ s/$self->{unicode_punctuation}//g;
3240              
3241             # If formatting the bot's last reply for %Previous, also remove punctuation.
3242 24 100       58 if ($botReply) {
3243 9         66 $string =~ s/[.?,!;:@#$%^&*()\-+]//g;
3244             }
3245             } else {
3246 147         544 $string =~ s/[^A-Za-z0-9 ]//g;
3247             }
3248              
3249             # In UTF-8 mode, only strip meta characters.
3250 171 100       334 if ($self->{utf8}) {
3251             # Backslashes and HTML tags
3252 24         39 $string =~ s/[\\<>]//g;
3253             } else {
3254 147         250 $string =~ s/[^A-Za-z0-9 ]//g;
3255             }
3256              
3257             # Remove excess whitespace and consolidate multiple spaces down to one.
3258 171         366 $string =~ s/^\s+//g;
3259 171         434 $string =~ s/\s+$//g;
3260 171         720 $string =~ s/\s+/ /g;
3261              
3262 171         404 return $string;
3263             }
3264              
3265             sub _stringUtil {
3266 5     5   11 my ($self,$type,$string) = @_;
3267              
3268 5 100       16 if ($type eq 'formal') {
    50          
    0          
    0          
3269 3         22 $string =~ s/\b(\w+)\b/\L\u$1\E/ig;
3270             }
3271             elsif ($type eq 'sentence') {
3272 2         24 $string =~ s/\b(\w)(.*?)(\.|\?|\!|$)/\u$1\L$2$3\E/ig;
3273             }
3274             elsif ($type eq 'upper') {
3275 0         0 $string = uc($string);
3276             }
3277             elsif ($type eq 'lower') {
3278 0         0 $string = lc($string);
3279             }
3280              
3281 5         15 return $string;
3282             }
3283              
3284             sub _personSub {
3285 4     4   9 my ($self,$string) = @_;
3286              
3287             # Make placeholders each time we substitute something.
3288 4         8 my @ph = ();
3289 4         5 my $i = 0;
3290              
3291             # Substitute each of the sorted person sub arrays in order,
3292             # using a one-way substitution algorithm (read: base13).
3293 4         4 foreach my $pattern (@{$self->{sortlist}->{person}}) {
  4         9  
3294 4         10 my $result = $self->{person}->{$pattern};
3295              
3296             # Make a placeholder.
3297 4         8 push (@ph, $result);
3298 4         8 my $placeholder = "\x00$i\x00";
3299 4         6 $i++;
3300              
3301 4         7 my $qm = quotemeta($pattern);
3302 4         35 $string =~ s/^$qm$/$placeholder/ig;
3303 4         37 $string =~ s/^$qm(\W+)/$placeholder$1/ig;
3304 4         29 $string =~ s/(\W+)$qm(\W+)/$1$placeholder$2/ig;
3305 4         35 $string =~ s/(\W+)$qm$/$1$placeholder/ig;
3306             }
3307              
3308 4         16 while ($string =~ /\x00(\d+)\x00/i) {
3309 2         5 my $id = $1;
3310 2         4 my $result = $ph[$id];
3311 2         25 $string =~ s/\x00$id\x00/$result/i;
3312             }
3313              
3314 4         10 return $string;
3315             }
3316              
3317             1;
3318             __END__