Modified version of tccs (http://tccs.sourceforge.net/) to add support for hfsc classes

tccs.pl

#!/usr/bin/perl -w

# copyright 2005-2008 Tomasz Pala <gotar@pld-linux.org>
# Contributions by Jan-willem De Bleser, 2013
# license: GPL

# usage:
# watch -d -n1 'tc -s c ls dev imq1 | tccs -f 10 2>/dev/null'

# tccs.rc file format:
# %translate = ( '1:2' => 'LAN', '1:4076' => 'pc76', '1:b238' => 'VoIP-3_29 );


#use strict;
use Getopt::Long;

#tc -s class show dev eth1 | perl -e 'undef $/; while(<>) { while (/class htb (.*?) .*?\n\s*Sent (\d+) .*?\n\s*rate (\d+)/sg) { print "Klasa: $1 Wyslano: $2 ($3bps)\n" }; };'

my $class = "";
my $classid;
my $parent;
my $rate;
my $ceil;
my $crate;
my $sent;
my $range;
my %tree;
my $recurse=10;
my $speedlevel=0;
my %translate;

eval `cat tccs.rc 2>/dev/null`;

GetOptions('recurse=s'=>\$recurse,
		'fastest=s'=>\$speedlevel);

while(<STDIN>) {
	if(/^ lended: / and $crate) {
		if($rate ne $ceil) {
			$range="$rate-$ceil";
		} else {
			$range=$rate;
		}
#		print "$parent: $class $classid $range $crate kb/s\n";
		$crate=sprintf "%8.1lf",$crate;
		@{$tree{$classid}}[0].="	$range	$crate kb/s";
		$crate=0;
		next;
	}
	#if($class eq "htb" and /^ Sent (\d+) bytes /) {
	if(/^ Sent (\d+) bytes .*dropped (\d+)/) {
		$sent=sprintf "%10.0lf",$1/1024;
		@{$tree{$classid}}[0].="	($sent KB, dropped $2 pk)";
		next;
	}
	if(/^ rate (\S+)(bit|bps) /) {
		# print "BPS rate!\n" if $2 eq "bps";
		if ($2 eq "bps") {
			($crate=$1)=~s/K/*1024/;
			$crate=~s/M/*1024*1024/;
			$crate=eval $crate;
			$crate*=8/1000;
		} else {
			($crate=$1)=~s/K/*1000/;
			$crate=~s/M/*1000*1000/;
			$crate=eval $crate;
			$crate/=1000;
		}
		next;
	}
	if(/^class (\S+) (\S+:\S*) (root|parent (\S+:\S*))/) {
		$class=$1;
		$classid=$2;
		($parent=$3)=~s/parent //;

		@{$tree{$parent}}[0]='' unless @{$tree{$parent}}[0];
		push @{$tree{$parent}}, $classid;
		@{$tree{$classid}}[0]="($class)";

		if($class eq "htb" and /rate (\S+) ceil (\S+)/) {
			$rate=$1;
			$ceil=$2;
		} elsif($class eq "hfsc") {
			if(/rt m1 (\S+) d (\S+) m2 (\S+)/) {
				@{$tree{$classid}}[0].="	Real $3".($2 eq "0us" ? "" : " ($2 @ $1)");
			}
			if(/ls m1 (\S+) d (\S+) m2 (\S+)/) {
				@{$tree{$classid}}[0].="	Link $3".($2 eq "0us" ? "" : " ($2 @ $1)");
			}
			if(/sc m1 (\S+) d (\S+) m2 (\S+)/) {
				@{$tree{$classid}}[0].="	Service $3".($2 eq "0us" ? "" : " ($2 @ $1)");
			}
			if(/ul m1 (\S+) d (\S+) m2 (\S+)/) {
				@{$tree{$classid}}[0].="	Upper $3".($2 eq "0us" ? "" : " ($2 @ $1)");
			}
		}
		next;
	}
}

my $level='';

sub my_sort {
	return 0 unless $_[0];
	return $_[0] cmp $_[1] unless $speedlevel;
	return -1 if($a=~/^\(/);
	$tree{$_[0]}[0]=~m|\(\S+\)\ \S+	\s*([\d\.]+) kb/s	\(|;
	my $a=$1;
	$tree{$_[1]}[0]=~m|\(\S+\)\ \S+	\s*([\d\.]+) kb/s	\(|;
	my $b=$1;
	return $b <=> $a;
}

sub list {
	return if length($level)/2==$recurse;
	if($_[0]) {
		if(exists $translate{$_[0]}) {
			printf "$level%-4s",$translate{$_[0]};
		} else {
			printf "$level%-4s",$_[0];
		}
	} else { return; }
	$level.='  ';
	my $rank=0;
	foreach my $id (sort {my_sort($a,$b)} (@{$tree{$_[0]}})) {
		if($id=~/^\(/) {
			print "	$id\n";
			next;
		} else {
			$rank++;
			next if $rank>$speedlevel and $speedlevel;
			list($id);
		}
	}
	$level=substr($level,2);
}

#@{$tree{'root'}}[0]="\n";
#list('root');
if(defined $tree{'root'}) {
	foreach (sort {my_sort($a,$b)} (@{$tree{'root'}})) {
		list($_);
	}
}

Hi,
can you add CBQ support ? how much effort is it ?

Best regards,
Pawel

Hi Pawel,

Sorry for the late response, but I had no idea you commented here.

I can look into CBQ support if you haven't already done so, but I don't currently have a system I can test it on. I'll keep it in mind, however, for the next time I do.

Cheers,
Jw