Import RTFL 0.1.1v0.1.1

1 files changed, 60 insertions, 0 deletions

diff --git a/scripts/rtfl-check-objects b/scripts/rtfl-check-objects
new file mode 100644
index 0000000..0e29e82
--- /dev/null
+++ b/scripts/rtfl-check-objects
@@ -0,0 +1,60 @@
+#!/usr/bin/perl
+
+# RTFL
+#
+# Copyright 2014 Sebastian Geerken <sgeerken@dillo.org>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+# Usage: rtfl-check-objects
+#
+# Use RTFL messages to check for invalid object access.
+#
+# N. b. that parsing is incorrect, see <doc/rtfl.html#scripts>.
+
+%exist_objects = { };
+%all_objects = { };
+%ident_objects = { };
+
+sub check_object
+{
+   my $id1 = $_[0], $id2 = $ident_objects{$_[0]};
+   if (!($exist_objects{$id1} || ($id2 && $exist_objects{$id2}))) {
+      if ($all_objects{$id1} || ($id2 && $all_objects{$id2})) {
+         print "--- Object $id1 has been deleted: ---\n$_";
+      } else {
+         print "--- Object $id1 has never existed: ---\n$_";
+      }
+   }
+}
+
+while(<STDIN>) {
+   if (/^\[rtfl[^\]]*\][^:]*:[^:]*:[^:]*:(obj-)?create:([^:]*):/) {
+      $exist_objects{$2}++;
+      $all_objects{$2} = 1;
+   } elsif (/^\[rtfl[^\]]*\][^:]*:[^:]*:[^:]*:(obj-)?delete:(.*)$/) {
+      $exist_objects{$2}--;
+   } elsif (/^\[rtfl[^\]]*\][^:]*:[^:]*:[^:]*:(obj-)?ident:([^:]*):(.*)$/) {
+      if($2 ne $3) {
+         $ident_objects{$2} = $3;
+         $ident_objects{$3} = $2;
+      }
+   } elsif (/^\[rtfl[^\]]*\][^:]*:[^:]*:[^:]*:(obj-)?(msg|set|enter|leave):([^:]*):/ ||
+            /^\[rtfl[^\]]*\][^:]*:[^:]*:[^:]*:(obj-)?(msg-start|msg-end|leave):(.*)$/) {
+      check_object ($3);
+   } elsif (/^\[rtfl[^\]]*\][^:]*:[^:]*:[^:]*:(obj-)?assoc:([^:]*):(.*)$/) {
+      check_object ($2);
+      check_object ($3);
+   }
+}