[LARTC] tctree + tcng

[raptor <raptor@tvskat.net>]

OK, now it should support the output of the tcng too....
And one new option if u have a comments before the class declaration u can print them like this :

[root@qos tcng]# cat xxx.tc | ./tctree.pl -f comment
+- total
  +- internet channel    
  | +- guaranteed 70%
  | | +- g19.2
  | | +- g19.2
  | +- unguaranteed
  +- BG channel
    +- u77kbps
    +- u19.2kbps

[root@qos tcng]# cat xxx.tc | ./tctree.pl -f idparent
+-parent 2:0 classid 2:1
  +-parent 2:1 classid 2:2
  | +-parent 2:2 classid 2:3
  | | +-parent 2:3 classid 2:4
  | | +-parent 2:3 classid 2:4
  | +-parent 2:2 classid 2:3
  +-parent 2:1 classid 2:2
    +-parent 2:2 classid 2:3
    +-parent 2:2 classid 2:3

=============xxx.tc=========
which is generated using prevoisly sent on the list com.pl script from Warner .... i.e. "com.pl xxx.tcng > xxx.tc"
# ================ Device eth1 ================

tc qdisc add dev eth1 handle 1:0 root dsmark indices 4 default_index 0
# root
tc qdisc add dev eth1 handle 2:0 parent 1:0 htb default 5
# total
tc class add dev eth1 parent 2:0 classid 2:1 htb rate 125000bps
# internet channel    
tc class add dev eth1 parent 2:1 classid 2:2 htb rate 12500bps
# guaranteed 70%
tc class add dev eth1 parent 2:2 classid 2:3 htb rate 8750bps ceil 12500bps
# g19.2
tc class add dev eth1 parent 2:3 classid 2:4 htb rate 125bps ceil 9625bps
tc class add dev eth1 parent 2:3 classid 2:5 htb rate 2400bps ceil 2400bps
# unguaranteed
tc class add dev eth1 parent 2:2 classid 2:6 htb rate 3750bps ceil 12500bps
# BG channel
tc class add dev eth1 parent 2:1 classid 2:7 htb rate 6250bps
# u77kbps
tc class add dev eth1 parent 2:7 classid 2:8 htb rate 125bps ceil 9625bps
# u19.2kbps
tc class add dev eth1 parent 2:7 classid 2:9 htb rate 2400bps ceil 2400bps
tc filter add dev eth1 parent 2:0 protocol all prio 1 tcindex mask 0x3 shift 0
tc filter add dev eth1 parent 2:0 protocol all prio 1 handle 2 tcindex classid 2:5
tc filter add dev eth1 parent 2:0 protocol all prio 1 handle 1 tcindex classid 2:4
tc filter add dev eth1 parent 1:0 protocol all prio 1 handle 1:0:0 u32 divisor 1
tc filter add dev eth1 parent 1:0 protocol all prio 1 u32 match u32 0xc0a80001 0xffffffff at 12 classid 1:1
tc filter add dev eth1 parent 1:0 protocol all prio 1 u32 match u32 0xc0a80002 0xffffffff at 12 classid 1:2
tc filter add dev eth1 parent 1:0 protocol all prio 1 u32 match u32 0 0 at 0 classid 1:0 police index 1 rate 1bps burst 1 action drop/drop


===========THE SCRIPT=========
#!/usr/bin/perl
use strict;
use vars qw(%o @in);
use Getopt::Std;
use Data::Dumper;
getopts('f:',\%o);
my %pos;#for storing class positions

#used to cut unnececary vertical bars
#too much effort for being beautiful :")
my %child;

#formats - pure, bitps, rate, idparent ...etc
sub cformat {
    my ($line, $formats, $cls) = @_;
    my $res;
    for my $f (split /-/, $formats) { 
        $line =~ s/class (\w+? \d+:\d+).+$/$1/ if $f eq 'pure';
	$line =~ s/^.+(rate \d+\w+).+$/$1/ if $f eq 'rate';    
        $line =~ s!(\d+)bps!($1*8).'bs'!eg if $f eq 'bitps';
	if ($f eq 'idparent') {
	    if ($line =~ /classid/) { $line =~ s/^.+(parent.+classid \d+:\d+).+$/$1/}
	    else { $line =~ s/class (.+parent \d+:\d+).+$/$1/ }
	};
	$line = $pos{$cls}{comment}."\n" if $f eq 'comment';	
    };
    return $line
}

#which is the nearest parent in this column in rows before me
sub nearestInCol {
    my ($row, $col) = shift;
    #if u think u can make it harder do it :")
    my ($v) =  sort { $pos{$_}{$b} <=> $pos{$_}{$b} }
	grep { $pos{$_}{row} < $row && $pos{$_}{col} = $col } keys %pos;
    return $v
}

#ascii-art
sub art {
    my ($cls,$row) = @_;
    my $tab;
    for my $c (0 .. $pos{$cls}{col}) {
	my $nearest = &nearestInCol($row,$c);
	SWITCH: {
	    if ($c > ($pos{$cls}{col})-1) { $tab .= '+-'; last SWITCH};
	    #dont even ask me what this is doing ... !!!
	    if (#ok if nearest parent on this column doesnt have more childs below us cut it
		$c = $pos{$nearest}{col} || $row > $child{$nearest} ) { $tab .= '  '; last SWITCH};
	    $tab .= '| '
	}
    }
    return $tab
}


#============MAIN==========#leave only classes and comments and place comments in %pos
open FILE, '-' or die 'hmmm... : $!';

my $comment;
while (<FILE>) {
    if ($_ =~ /^\s*#/) {#this is comment just before class declaration
	($comment) = $_ =~ /^\s*#(.+)$/;
    };
    next unless $_ =~ /^(tc )?class/;
    $_ =~ s/^.*?(class.+)$/$1/;
    push @in, $_;
    if ($comment) {
        my ($classID) = $_ =~ /class(?:id)?\D+(\d+:\d+)/;	
	$pos{$classID}{comment} = $comment
    }
}    
close FILE;

#build class position table
my ($prevParent, $prevClassID, $myComment);
my $c = 0;#column
for my $r ( 1 .. $#in ) {

    my ($classID) = $in[$r] =~ /class(?:id)?\D+(\d+:\d+)/;
    my ($parent) = $in[$r] =~ /parent\D+(\d+:\d+)/;
#    print "$classID -- $parent\n";    
    unless ($parent eq $prevParent) {
	unless ($parent ne $prevClassID) { $c++ }
	else {$c = $pos{$parent}{col}+1}
    };
    $pos{$classID}{col} = $c;
    $pos{$classID}{row} = $r;
    $prevParent = $parent;
    $prevClassID = $classID;
    $child{$parent} = $r;
};

#print the tree
my $row = 0;
for my $cls (sort {$pos{$a}{row} <=> $pos{$b}{row}} keys %pos) {
    my $tab = art($cls,$row);
    print $tab.(cformat($in[$pos{$cls}{col}],$o{f},$cls));
    $row++
};

_______________________________________________
LARTC mailing list / LARTC@mailman.ds9a.nl
http://mailman.ds9a.nl/mailman/listinfo/lartc HOWTO: http://lartc.org/