Fix show queueing on interface

Bug 6532
Rework code to make it more robust for tc output format.
Kernel no longer provide empty rate values.
Rearrange fields on output.

1 files changed, 148 insertions, 123 deletions

diff --git a/scripts/vyatta-show-queueing.pl b/scripts/vyatta-show-queueing.pl
index 5ab66c0..9d6caa6 100755
--- a/scripts/vyatta-show-queueing.pl
+++ b/scripts/vyatta-show-queueing.pl
@@ -119,110 +119,92 @@ sub byclassid {
     my ( $a1, $a2 ) = ( $a =~ m/([0-9a-f]+):([0-9a-f]+)/ );
     my ( $b1, $b2 ) = ( $b =~ m/([0-9a-f]+):([0-9a-f]+)/ );
 
-    return hex($a2) <=> hex($b2) if ( $a1 == $b1 );
-    return hex($a1) <=> hex($b1);
+    if ($a1 eq $b1) {
+	return hex($a2) <=> hex($b2);
+    } else {
+	return hex($a1) <=> hex($b1);
+    }
 }
 
+# Recursively add classes to parent tree
 sub class2tree {
-    my ( $classes, $parentid, $parent ) = @_;
+    my ( $classes, $parent_id, $parent_tree ) = @_;
 
     foreach my $id ( sort byclassid keys %{$classes} ) {
         my $class = $classes->{$id};
-        next unless ( $class->{parent} && $class->{parent} eq $parentid );
-        my $node = Tree::Simple->new( $class->{info} );
-        $parent->addChild($node);
+        next unless ( $class->{parent} && $class->{parent} eq $parent_id );
+
+        my $node = Tree::Simple->new( $class );
+        $parent_tree->addChild($node);
+
         class2tree( $classes, $id, $node );
     }
-
-    return $parent;
 }
 
 # Build a tree of output information
 # (This is N^2 but not a big issue)
 sub get_class {
-    my ( $interface, $rootq, $qdisc ) = @_;
+    my ( $interface, $rootq ) = @_;
     my %classes;
 
     open( my $tc, '-|', "/sbin/tc -s class show dev $interface" )
       or die 'tc class command failed: $!';
 
-    my ( $id, $name, $sent, $drop, $over, $root, $leaf, $parent );
-
+    my ($id, $info, $root);
     while (<$tc>) {
         chomp;
-        /^class/ && do {
-
-       # class htb 1:1 root rate 1000Kbit ceil 1000Kbit burst 1600b cburst 1600b
-       # class htb 1:2 parent 1:1 leaf 8001:
-       # class ieee80211 :2 parent 8001:
-            my ( $l, $q, $t );
-            ( undef, $name, $id, $t, $parent, $l, $q ) = split;
-            $leaf = undef;
-            if ( $t eq 'root' ) {
-                $parent = undef;
-            }
-            elsif ( $t eq 'parent' ) {
-                if ( $l eq 'leaf' ) {
-                    $q =~ s/:$//;
-                    $leaf = hex($q);
-                }
-            }
-            else {
-                die "confused by tc class output for type 'class $name $id $t'";
+        /^class \S+ (\S+) / && do {
+	    # class htb 1:1 root rate 1000Kbit ceil 1000Kbit burst 1600b cburst 1600b
+	    # class htb 1:2 parent 1:1 leaf 8001:
+	    # class ieee80211 :2 parent 8001:
+
+	    # record last data, and clean slate
+	    $classes{$id} = $info if $id;
+
+	    $info = {};
+	    $id = $1;
+	    $info->{id} = $id;
+
+	    if (/ root / ) {
+		$root = $id;
+            } else {
+		/ parent (\S+)/ && do {
+		    $info->{parent} = $1;
+		};
+
+		/ leaf ([0-9a-f]+):/ && do {
+                    $info->{leaf} = hex($1);
+                };
             }
             next;
         };
 
-        /^ Sent/ && do {
-
-            #  Sent 13860 bytes 88 pkt (dropped 0, overlimits 0 requeues 0)
-            ( undef, $sent, undef, undef, undef, undef, $drop, undef, $over ) =
-              split;
+        /^ Sent (\d+) bytes (\d+) pkt/ && do {
+	    $info->{sent} = $1;
+	};
 
-            # fix silly punctuation bug in tc
-            $drop =~ s/,$//;
-            next;
+	/ \(dropped (\d+), overlimits (\d+) requeues (\d+)\) / && do {
+	    $info->{dropped} = $1;
+	    $info->{overlimit} = $2;
+	    $info->{requeues} = $3;
         };
 
-        /^ rate/ && do {
-
-            #  rate 0bit 0pps backlog 0b 23p requeues 0
-            my ( undef, $rate, undef, undef, undef, $backlog ) = split;
-            $backlog =~ s/p$//;
-            $rate    =~ s/bit$//;
+	/ rate (\S+)bit (\d+)pps / && do {
+	    $info->{rate} = $1;
+	    $info->{pps} = $2;
+	};
 
-            # split $id of form 1:10 into parent, child id
-            my ( $maj, $min ) = ( $id =~ m/([0-9a-f]+):([0-9a-f]+)/ );
-
-            # TODO handle nested classes??
-            next if ( hex($maj) != $rootq );
-
-            # record info for display
-            my @args = ( hex($min) );
-            if ($leaf) {
-                my $qdisc_info = $qdisc->{$leaf};
-                die "info for $leaf is unknown" unless $qdisc_info;
-                push @args, @{$qdisc_info};
-            }
-            else {
-                push @args, shaper($name), $sent, $drop, $over, $rate, $backlog;
-            }
-
-            $classes{$id} = {
-                id     => $id,
-                parent => $parent,
-                info   => \@args,
-            };
-
-            $root = $classes{$id} unless $parent;
-            next;
-          }
+	/ backlog \d+b (\d+)p / && do {
+	    $info->{backlog} = $1;
+	};
     }
     close $tc;
+    $classes{$id} = $info if $id;
     return unless $root;
 
-    return class2tree( \%classes, $root->{id},
-        Tree::Simple->new( $root->{info}, Tree::Simple->ROOT ) );
+    my $tree = Tree::Simple->new( $classes{$root}, Tree::Simple->ROOT );
+    class2tree( \%classes, $root, $tree );
+    return $tree;
 }
 
 sub qmajor {
@@ -232,91 +214,134 @@ sub qmajor {
     return hex($id);
 }
 
+sub qminor {
+    my $id = shift;
+
+    $id =~ s/^.*://;
+    return hex($id);
+}
+
 # This collects all the qdisc information into one hash
 # and root queue id and reference to map of qdisc to statistics
 sub get_qdisc {
     my $interface = shift;
-    my %qdisc;
+    my @qdisc;
     my ( $root, $dsmark );
 
     open( my $tc, '-|', "/sbin/tc -s qdisc show dev $interface" )
       or die 'tc command failed: $!';
 
-    my ( $qid, $name, $sent, $drop, $over );
+    my ($qid, $qinfo);
+
     while (<$tc>) {
         chomp;
-        /^qdisc/ && do {
-
-            # qdisc htb 1: root r2q 10 default 20 direct_packets...
-            my ( $t, $pqid );
-
-            ( undef, $name, $qid, $t, $pqid ) = split;
-            $qid = qmajor($qid);
 
-            if ( $name eq 'dsmark' ) {
-                $dsmark = $qid;
+	# qdisc htb 1: root r2q 10 default 20 direct_packets...
+	# qdisc pfifo 8008: parent 1:2 limit 1000p
+        /^qdisc (\S+) ([0-9a-f]+): / && do {
+	    # record last qdisc
+	    $qdisc[$qid] = $qinfo if ($qid);
+	    $qinfo = {};
+
+	    my $name = $1;
+	    $qid = hex($2);
+
+	    $qinfo->{name} = shaper($name);
+	    $dsmark = $qid  if ($name eq 'dsmark');
+
+	    if (/ root /) {
+		$root = $qid;
+	    } elsif ( / parent (\S+)/ ) {
+		my $pqid = $1;
+
+		# hide dsmark qdisc from display
+		if (defined($dsmark) && qmajor($pqid) == $dsmark) {
+		    $root = $qid;
+		} else {
+		    $qinfo->{parent} = $pqid;
+		}
             }
-            elsif ($t eq 'parent'
-                && defined($dsmark)
-                && qmajor($pqid) == $dsmark )
-            {
-                $root = $qid;
-            }
-            elsif ( $t eq 'root' ) {
-                $root = $qid;
-            }
-            next;
-        };
-
-        /^ Sent/ && do {
 
-            #  Sent 13860 bytes 88 pkt (dropped 0, overlimits 0 requeues 0)
-            ( undef, $sent, undef, undef, undef, undef, $drop, undef, $over ) =
-              split;
+	    if (/ default ([0-9a-f]+) / ) {
+		$qinfo->{default} = hex($1);
+	    }
 
-            # fix silly punctuation bug in tc
-            $drop =~ s/,$//;
             next;
         };
 
-        /^ rate/ && do {
+        /^ Sent (\d+) bytes (\d+) pkt/ && do {
+	    $qinfo->{sent} = $1;
+	};
 
-            # rate 0bit 0pps backlog 0b 23p requeues 0
-            my ( undef, $rate, undef, undef, undef, $backlog ) = split;
+	/ \(dropped (\d+), overlimits (\d+) requeues (\d+)\) / && do {
+	    $qinfo->{dropped} = $1;
+	    $qinfo->{overlimit} = $2;
+	    $qinfo->{requeues} = $3;
+        };
 
-            $backlog =~ s/p$//;
-            $rate    =~ s/bit$//;
+	/ rate (\S+)bit (\d+)pps / && do {
+	    $qinfo->{rate} = $1;
+	    $qinfo->{pps} = $2;
+	};
 
-            $qdisc{$qid} =
-              [ shaper($name), $sent, $drop, $over, $rate, $backlog ];
-          }
+	/ backlog \d+b (\d+)p / && do {
+	    $qinfo->{backlog} = $1;
+	}
     }
     close $tc;
+    $qdisc[$qid] = $qinfo if $qid;
+
+    return ( $root, \@qdisc );
+}
+
+my $CLASSFMT = "%-10s %-16s";
+my @fields = qw(sent rate dropped overlimit backlog);
+
+sub print_info {
+    my ($id, $name, $info, $depth) = @_;
+    my $indent = '  ' x $depth;
 
-    return ( $root, \%qdisc );
+    # Class Policy
+    printf $CLASSFMT, $indent . $id, $name;
+
+    for (@fields) {
+	my $val = $info->{$_};
+	if (defined($val)) {
+	    printf " %8d", $val;
+	} else {
+	    print '         ';
+	}
+    }
+    print "\n";
 }
 
 sub show_queues {
-    my ( $interface, $root, $qdisc ) = @_;
-    my $args = $qdisc->{$root};
-    return unless $args;
+    my ( $interface, $qdisc, $root ) = @_;
+    my $rootq = $qdisc->[$root];
+    my $default = $rootq->{default};
 
-    my $fmt = "%-10s %-16s %-10s %-9s %-9s %-9s %s\n";
     print "\n$interface Queueing:\n";
-    printf $fmt, 'Class', 'Qos-Policy', 'Sent',
-      'Dropped', 'Overlimit', 'Rate', 'Queued';
+    printf $CLASSFMT, 'Class', 'Policy';
+    for (@fields) {
+	printf " %8s", ucfirst($_);
+    }
+    print "\n";
 
-    printf $fmt, 'root', @{$args};
+    print_info('root', $rootq->{name}, $rootq, 0);
 
-    my $tree = get_class( $interface, $root, $qdisc );
+    my $tree = get_class( $interface, $root );
     return unless $tree;
 
     $tree->traverse(
         sub {
-            my $_tree = shift;
-            my @args  = @{ $_tree->getNodeValue() };
-            my $id    = shift @args;
-            printf $fmt, ( '  ' x $_tree->getDepth() . $id ), @args;
+	    my $node = shift;
+	    my $class = $node->getNodeValue();
+	    my $qid = qminor($class->{id});
+	    $qid = 'default' if (defined($default) && $qid == $default);
+
+	    my $subq = $qdisc->[$class->{leaf}];
+
+	    print_info($qid, $subq->{name}, $class, $node->getDepth());
         }
     );
 }
@@ -328,7 +353,7 @@ sub show {
     # Show output queue first
     ( $root, $qdisc ) = get_qdisc($interface) unless $root;
 
-    show_queues( $interface, $root, $qdisc ) if $root;
+    show_queues( $interface, $qdisc, $root ) if $root;
 }
 
 sub usage {