Import RTFL 0.1.1v0.1.1

6 files changed, 490 insertions, 0 deletions

diff --git a/scripts/Makefile.am b/scripts/Makefile.am
new file mode 100644
index 0000000..6929095
--- /dev/null
+++ b/scripts/Makefile.am
@@ -0,0 +1,6 @@
+dist_bin_SCRIPTS = \
+	rtfl-check-objects \
+	rtfl-filter-out-classes \
+	rtfl-objfilter \
+	rtfl-objtail \
+	rtfl-stacktraces
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);
+   }
+}
diff --git a/scripts/rtfl-filter-out-classes b/scripts/rtfl-filter-out-classes
new file mode 100644
index 0000000..5c0d2f9
--- /dev/null
+++ b/scripts/rtfl-filter-out-classes
@@ -0,0 +1,63 @@
+#!/usr/bin/perl
+
+# RTFL
+#
+# Copyright 2014, 2015 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-filter-out-classes [<classes> ...]
+#
+# Filter out all RTFL messages referring to objects belonging to a
+# specified set of classes. Each command line argument is a concrete
+# class or a (filename) pattern. The latter is useful to exclude whole
+# namespaces ("path::to::namespace::*").
+#
+# N. b. that parsing is slightly incorrect; escaping is (except partly
+# for classes) not considered.
+
+use File::FnMatch qw(:fnmatch);
+
+%removed_objects = { };
+
+open PIPE, "rtfl-objbase |";
+
+while(<PIPE>) {
+   if (/^\[rtfl-obj-1.[0-9]+][^:]*:[^:]*:[^:]*:(obj-)?create:([^:]*):(.*)$/) {
+      $removed = 0;
+      $o = $2;
+      $c1 = $3;
+      $c1 =~ s/\\:/:/g;
+      foreach $c2 (@ARGV) {
+         if (fnmatch ($c2, $c1)) {
+            $removed_objects{$o} = 1;
+            $removed = 1;
+         }
+      }
+      if (!$removed) { print; }
+   } elsif (/^\[rtfl-obj-1.[0-9]+][^:]*:[^:]*:[^:]*:(obj-)?(msg|set|enter|leave):([^:]*):/ &&
+            $removed_objects{$3}) {
+      # Suppress.
+   } elsif (/^\[rtfl-obj-1.[0-9]+][^:]*:[^:]*:[^:]*:(obj-)?(msg-(start|end)|delete|leave):(.*)$/ &&
+            $removed_objects{$4}) {
+      # Suppress.
+   } elsif (/^\[rtfl-obj-1.[0-9]+][^:]*:[^:]*:[^:]*:(obj-)?assoc:([^:]*):(.*)$/ &&
+            ($removed_objects{$2} || $removed_objects{$3})) {
+      # Suppress.
+   } else {
+      print;
+   }
+}
+
+close PIPE;
diff --git a/scripts/rtfl-objfilter b/scripts/rtfl-objfilter
new file mode 100755
index 0000000..2947e21
--- /dev/null
+++ b/scripts/rtfl-objfilter
@@ -0,0 +1,110 @@
+#!/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-objfilter [options]
+#
+# Filters a stream of RTFL messages by types, aspects and priorities.
+# The options -a, -A, -t, -T, and -p are supported and work in the
+# same way as for rtfl-objview. By default, nothing is filtered.
+#
+# N. b. that parsing is incorrect, see <doc/rtfl.html#scripts>.
+
+$LARGE_INT = 1000000000;
+
+sub helpAndExit { 
+   die "Syntax: $0 uses same arguments -a, -A, -t, -T, and -p as rtfl-objview.";
+}
+
+sub filter1 {
+   return $shownTypes{$_[0]};
+}
+
+sub filter2 {
+   return $shownTypes{$_[0]} &&
+      (($defaultShow && !$hiddenAspects{$_[1]}) ||
+       (!$defaultShow && !$shownAspects{$_[1]})) &&
+       $_[2] >= $prio;
+}
+
+
+%shownAspects = {};
+%hiddenAspects = {};
+$defaultShow = 1;
+%shownTypes =
+   ( "i" => 1, "m" => 1, "a" => 1, "f" => 1, "s" => 1, "t" => 1, "d" => 1 );
+$prio = $LARGE_INT;
+
+for ($i = 0; $i < scalar @ARGV; $i++) {
+   $opt = $ARGV[$i];
+   helpAndExit if ($i == scalar @ARGV -1);
+   $arg = $ARGV[++$i];
+
+   if ($opt eq "-a") {
+      if (arg eq "*") { $defaultShow = 1; }
+      else { $shownAspects{$arg} = 1; }
+   } elsif ($opt eq "-A") {
+      if (arg eq "*") { $defaultShow = 0; }
+      else { $hiddenAspects{$arg} = 1; }
+   } elsif ($opt eq "-t" || $opt eq "-T") {
+      $show = $opt eq "-t";
+      for ($i = 0; $i < length ($arg); $i++) {
+         $shownTypes{substr ($arg, $i, 1)} = $show;
+      }
+   } elsif ($opt eq "-p") {
+      if ($arg eq "*") { $prio = $LARGE_INT; }
+      else { $prio = $arg; }
+   } else {
+      helpAndExit if ($method eq "");
+   }
+}
+
+@shownFuns = ();
+
+while(<STDIN>) {
+   if (/^\[rtfl[^\]]*\]/) {
+      if (/^\[rtfl[^\]]*\][^:]*:[^:]*:[^:]*:(obj-)?mark:[^:]*:([^:]*):([^:]*):/) {
+         print if (filter2 ("a", $2, $3));
+      } elsif (/^\[rtfl[^\]]*\][^:]*:[^:]*:[^:]*:(obj-)?msg:[^:]*:([^:]*):([^:]*):/) {
+         print if (filter2 ("m", $2, $3));
+      } elsif (/^\[rtfl[^\]]*\][^:]*:[^:]*:[^:]*:(obj-)?msg-start:/ ||
+               /^\[rtfl[^\]]*\][^:]*:[^:]*:[^:]*:(obj-)?msg-end:/) {
+         print if (filter1 ("i"));
+      } elsif (/^\[rtfl[^\]]*\][^:]*:[^:]*:[^:]*:(obj-)?set:/) {
+         print if (filter1 ("t"));
+      } elsif (/^\[rtfl[^\]]*\][^:]*:[^:]*:[^:]*:(obj-)?delete:/) {
+         print if (filter1 ("d"));
+      } elsif (/^\[rtfl[^\]]*\][^:]*:[^:]*:[^:]*:(obj-)?enter:[^:]*:([^:]*):([^:]*):/) {
+         $shown = filter2 ("f", $2, $3);
+         print if ($shown);
+         push @shownFuns, $shown;
+      } elsif (/^\[rtfl[^\]]*\][^:]*:[^:]*:[^:]*:(obj-)?leave:/) {
+         $show = pop @shownFuns;
+         print if ($shown);
+      } elsif (/^\[rtfl[^\]]*\][^:]*:[^:]*:[^:]*:(obj-)?create:/ ||
+               /^\[rtfl[^\]]*\][^:]*:[^:]*:[^:]*:(obj-)?assoc:/ ||
+               /^\[rtfl[^\]]*\][^:]*:[^:]*:[^:]*:(obj-)?color:/ ||
+               /^\[rtfl[^\]]*\][^:]*:[^:]*:[^:]*:(obj-)?class-color:/ ||
+               /^\[rtfl[^\]]*\][^:]*:[^:]*:[^:]*:(obj-)?object-color:/ ||
+               /^\[rtfl[^\]]*\][^:]*:[^:]*:[^:]*:(obj-)?ident:/) {
+         print;
+      } else {
+        print STDERR "Invalid line: $_";
+      }
+   }
+}
diff --git a/scripts/rtfl-objtail b/scripts/rtfl-objtail
new file mode 100644
index 0000000..d0ec9c0
--- /dev/null
+++ b/scripts/rtfl-objtail
@@ -0,0 +1,134 @@
+#!/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-objtail [-a <attributes> ...] [-A <attributes> ...] <len>
+#
+# Print only the last lines of a stream of RTFL messages, but include
+# those RTFL messages which are necessary to understand the last ones,
+# like "obj-create", "obj-assoc" etc., when they refer to objects in
+# the last lines.
+#
+# Any number of options "-a" and "-A" may be added with fnmatch(3)
+# like patterns; for those attributes specified by "-a", but not
+# excluded by "-A", the last attribute definitions before the actual
+# tail is shown for relevant objects.
+#
+# Example: "-a 'foo.*' -A '*.bar'" will show attribute values for
+# 'foo.qix', but not for, say, 'foo.bar', since "-A '*.bar'" overrides
+# "-a 'foo.*'".
+#
+# The opposite, "rtfl-objhead", is not needed; simply use "head" to
+# get the first lines.
+#
+# N. b. that parsing is slightly incorrect; escaping is not considered.
+
+use File::FnMatch qw(:fnmatch);
+
+sub helpAndExit { 
+   die "Syntax: $0 [-a <attributes> ...] [-A <attributes> ...] <number of lines>";
+}
+
+$tlen = "";
+@attrs = ();
+@neg_attrs = ();
+
+for ($i = 0; $i < scalar @ARGV; $i++) {
+   if ($ARGV[$i] eq "-a") {
+      helpAndExit if ($i == scalar @ARGV -1);
+      push @attrs, $ARGV[++$i];
+   } elsif ($ARGV[$i] eq "-A") {
+      helpAndExit if ($i == scalar @ARGV -1);
+      push @neg_attrs, $ARGV[++$i];
+   } else {
+      $tlen = $ARGV[$i];
+   }
+}
+
+helpAndExit if ($tlen eq "");
+
+@all_lines = ();
+%rel_objects = { };
+%last_attrs = { };
+
+open PIPE, "rtfl-objbase |";
+
+while(<PIPE>) {
+   if (/^\[rtfl-obj-1.[0-9]+]/) { push @all_lines, $_; }
+}
+
+close PIPE;
+
+$len = scalar (@all_lines);
+if ($tlen > $len) {
+   $tlen = $len;
+}
+
+# Determine relevant objects from the last lines.
+for ($i = $len - $tlen; $i < $len; $i++) {
+   $_ = $all_lines[$i];
+   if (/^\[rtfl-obj-1.[0-9]+][^:]*:[^:]*:[^:]*:(obj-)?(create|msg|set|enter|leave):([^:]*):/ ||
+       /^\[rtfl-obj-1.[0-9]+][^:]*:[^:]*:[^:]*:(obj-)?(msg-start|msg-end|delete|leave):(.*)$/) {
+      $rel_objects{$3} = 1;
+   } elsif (/^\[rtfl-obj-1.[0-9]+][^:]*:[^:]*:[^:]*:(obj-)?assoc:([^:]*):(.*)$/) {
+      $rel_objects{$2} = 1;
+      $rel_objects{$3} = 1;
+   }
+}
+
+# Determine the last attribute values before the last lines.
+for ($i = 0; $i < $len - $tlen; $i++) {
+   $_ = $all_lines[$i];
+   if (/^\[rtfl-obj-1.[0-9]+][^:]*:[^:]*:[^:]*:(obj-)?set:([^:]*):([^:]*):(.*)/ &&
+       $rel_objects{$2}) {
+      $found = 0;
+      for ($j = 0; $j < scalar (@attrs) && !$found; $j++) {
+         if (fnmatch ($attrs[i], $3)) { $found = 1; }
+      }
+      for ($j = 0; $j < scalar (@neg_attrs) && $found; $j++) {
+         if (fnmatch ($neg_attrs[i], $3)) { $found = 0; }
+      }
+      
+      if ($found) {
+         $last_attrs{"$2:$3"} = $_;
+      }
+   }
+}
+
+foreach (keys %last_attrs) {
+   print $last_attrs{$_};
+}
+
+# Print all relevant lines (both before the last lines and the last lines).
+for ($i = 0; $i < $len; $i++) {
+   $_ = $all_lines[$i];
+   if (/^\[rtfl-obj-1.[0-9]+][^:]*:[^:]*:[^:]*:(obj-)?color:/ ||
+       /^\[rtfl-obj-1.[0-9]+][^:]*:[^:]*:[^:]*:(obj-)?class-color:/ ||
+       /^\[rtfl-obj-1.[0-9]+][^:]*:[^:]*:[^:]*:(obj-)?object-color:/) {
+      print;
+   } elsif ($i >= $len - $tlen) {
+      print;
+   } elsif ((/^\[rtfl-obj-1.[0-9]+][^:]*:[^:]*:[^:]*:(obj-)?create:([^:]*):/ ||
+             /^\[rtfl-obj-1.[0-9]+][^:]*:[^:]*:[^:]*:(obj-)?delete:(.*)$/) &&
+            $rel_objects{$2}) {
+      print;
+   } elsif (/^\[rtfl-obj-1.[0-9]+][^:]*:[^:]*:[^:]*:(obj-)?assoc:([^:]*):(.*)$/
+            && $rel_objects{$2} && $rel_objects{$3}) {
+         print;
+   }
+}
diff --git a/scripts/rtfl-stacktraces b/scripts/rtfl-stacktraces
new file mode 100755
index 0000000..a9e953b
--- /dev/null
+++ b/scripts/rtfl-stacktraces
@@ -0,0 +1,117 @@
+#!/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-stracktraces <method name>
+#
+# Prints stacktraces which lead to a specific method given as command line
+# argument (based on "obj-enter" and "obj-leave").
+#
+# Further Arguments:
+#
+# -s        Short format.
+# -n <n>    Regard only stacktraces with at least <n> occurences of the method.
+# -e <n>    Do not print stack traces, but all messages; if a stacktrace would
+#           have been printed, exit after <n> further messages. Can be used
+#           together with -m.
+# -m <mark> Do not print stack traces, but all messages; if a stacktrace would
+#           have been printed, edit a obj-mark with all parameters (file name,
+#           line number, process id, object, aspect, priority) taken from the
+#           last "obj-enter" command. Can be used together with -e.
+#
+# N. b. that parsing is incorrect, see <doc/rtfl.html#scripts>.
+
+sub helpAndExit { 
+   die "Syntax: $0 [-s] [-n <n>] [-e <n>] [-m <mark>] <method name>";
+}
+
+$method = "";
+$short = 0;
+$minNumCalls = 1;
+$willEnd = 0;
+$willEndCount = 0;
+$mark = "";
+
+for ($i = 0; $i < scalar @ARGV; $i++) {
+   if ($ARGV[$i] eq "-s") {
+      $short = 1;
+   } elsif ($ARGV[$i] eq "-n") {
+      helpAndExit if ($i == scalar @ARGV -1);
+      $minNumCalls = $ARGV[++$i];
+   } elsif ($ARGV[$i] eq "-e") {
+      helpAndExit if ($i == scalar @ARGV -1);
+      $willEnd = 1;
+      $willEndCount = $ARGV[++$i];
+   } elsif ($ARGV[$i] eq "-m") {
+      helpAndExit if ($i == scalar @ARGV -1);
+      $mark = $ARGV[++$i];
+   } else {
+      $method = $ARGV[$i];
+   }
+}
+
+helpAndExit if ($method eq "");
+
+@stack = ();
+$first = 1;
+$numCalls = 0;
+
+while(<STDIN>) {
+   if (($mark ne "" || $willEnd) && (!$endSoon || $endCount > 0)) {
+      print;
+      if ($endSoon && /^\[rtfl[^\]]*\]/) { $endCount--; };
+   }
+
+   if (/^(\[rtfl[^\]]*\][^:]*:[^:]*:[^:]*):(obj-)?enter:([^:]*:[^:]*:[^:]*):([^:]*):.*$/) {
+      push @stack, ($short ? $4 : $_);
+      
+      if ($4 eq $method) {
+         $numCalls++;
+
+         if ($numCalls >= $minNumCalls) {
+            if ($willEnd) {
+               if (!$endSoon) {
+                  $endSoon = 1;
+                  $endCount = $willEndCount;
+               }
+            } elsif ($mark ne "") {
+               print "$2:(obj-)?mark:$3:$mark\n";
+            } else {
+               if ($short) {
+                  $firstInLine = 1;
+                  foreach $frame (@stack) {
+                     print " > " unless $firstInLine;
+                     print $frame;
+                     $firstInLine = 0;
+                  }
+                  print "\n";
+               } else {
+                  print "-" x 79, "\n" unless $first;
+                  foreach $frame (@stack) { print $frame; }
+               }
+               $first = 0;
+            }
+         }
+      }
+   } elsif (/^\[rtfl[^\]]*\][^:]*:[^:]*:[^:]*:(obj-)?leave:.*$/) {
+      $l = pop @stack;
+      if ($l =~
+          /^\[rtfl[^\]]*\][^:]*:[^:]*:[^:]*:(obj-)?enter:[^:]*:[^:]*:[^:]*:$method:.*$/)
+      { $numCalls--; }
+   }
+}