#!/usr/bin/perl -wT
# parse output of
# tc -s -s class list dev ethx
use strict;
$|=1;
$ENV{PATH}='';

use CGI qw/:standard -no_xhtml/;
#use Data::Dumper;
#$Data::Dumper::Terse=1; $Data::Dumper::Quotekeys=0; $Data::Dumper::Sortkeys=1;

my $tc='/sbin/tc';
my @int=qw/eth0 eth1 eth2 imq0 imq1/;

my @classattrs=qw/classid userid 
type level 
parent 
bytes pkts dropped overlimits period work rtwork/;
my @numeric_attrs=qw/bytes pkts dropped overlimits period work rtwork/;

my $hostname=`/bin/hostname -f`;

my $CSS=<<END;
body { background-color: ivory; font-family: verdana, arial, sans-serif; }
td.num { text-align: right; font-size: 75%; }
td.params { font-size: 50%; }
END

sub hex2dec($) { return hex $_[0] }
sub nbspaced ($) { # "123456,99" -> "123 456,99"
    my $in=shift;
    1 while $in =~ s/^([-+]?\d+)(\d{3})/$1&nbsp;$2/;
    return $in;
}

print header(-type => 'text/html; charset=UTF-8');
print start_html(-title => "Traffic classes at $hostname",
  -style => { -code => $CSS });
foreach my $device (@int) {

  my($type, $classid, $parent, $params);
  my($bytes, $pkts, $dropped, $overlimits);
  my($period, $work, $rtwork, $level);
  my $classes;
  my %cc=();
  my $queues;
  my %cq=();

  for(`$tc -s class list dev $device`) {
    chomp;
    if (/^class (\w+) ([[:xdigit:]]+:([[:xdigit:]]+)?) root/)
    {
      ($cc{type}, $cc{classid}) = ($1, $2);
    }
    elsif (/^class (\w+) ([[:xdigit:]]+:([[:xdigit:]]+)?) parent ([[:xdigit:]]+:([[:xdigit:]]+)?)(.*)$/)
    {
      ($cc{type}, $cc{classid}, $cc{parent}, $cc{params}) = ($1, $2, $4, $6);
      $cc{userid} = defined $3 ? hex2dec($3) >= 10000 ? hex2dec($3) : undef : undef;
    }
    elsif (/Sent (\d+) bytes (\d+) p.*dropped (\d+), overlimits (\d+)/)
    {
      ($cc{bytes}, $cc{pkts}, $cc{dropped}, $cc{overlimits}) = ($1, $2, $3, $4);
    }
    elsif (/period (\d+) (?:work (\d+) bytes )?(?:rtwork (\d+) bytes )?level (\d)/)
    {
      $cc{period} = $1;
      $cc{work}   = $2 ? $2 : 0;
      $cc{rtwork} = $3 ? $3 : 0;
      $cc{level} = $4;
    }
    elsif (/^$/ and defined($cc{classid}))
    {
      #warn "end class: $cc{type} $cc{classid}\n";
        for(keys %cc) {
          $classes->{$cc{classid}}->{$_}=$cc{$_};
        }
        for(keys %cc) {
          undef $cc{$_};
        }  
        %cc=();
    }
  }
  
sub qdiscanal{
  for(`$tc --s -d qdisc list dev $device`) {
    chomp;
    if (/^qdisc (\w+) ([[:xdigit:]]+:([[:xdigit:]]+)?) parent ([[:xdigit:]]+:([[:xdigit:]]+)?)(.*)$/)
    {
      ($cq{type}, $cq{classid}, $cq{parent}, $cq{params}) = ($1, $2, $4, $6);
       $cq{userid} = defined $3 ? hex2dec($3) >= 10000 ? hex2dec($3) : undef : undef;
    }
    elsif (/^qdisc (\w+) ([[:xdigit:]]+:([[:xdigit:]]+)?)(.*)$/)
    {
      ($cq{type}, $cq{classid}, $cq{params}) = ($1, $2, $3);
    }
    elsif (/Sent (\d+) bytes (\d+) p.*dropped (\d+).*overlimits (\d+).*(?:requeues (\d+))?/)
    {
      ($cq{bytes}, $cq{pkts}, $cq{dropped}, $cq{overlimits}) = ($1, $2, $3, $4, $5);
    }
    elsif (/period (\d+) (?:work (\d+) bytes )?(?:rtwork (\d+) bytes )?level (\d)/)
    {
      $cc{period} = $1;
      $cc{work}   = $2 ? $2 : 0;
      $cc{rtwork} = $3 ? $3 : 0;
      $cc{level} = $4;
    }
    elsif (/^$/ and defined($cq{classid}))
    {
      #warn "end class: $cc{type} $cc{classid}\n";
        for(keys %cc) {
          $classes->{$cc{classid}}->{$_}=$cc{$_};
        }
        for(keys %cc) {
          undef $cc{$_};
        }  
        %cc=();
    }
  }
}

#  print table(
#          {-border=>1},
#          caption(h5("Traffic classes for device $device")),
#          Tr( [ th({-width=>'100',-scope=>'col'}, [ @classattrs ] ),
#              map {
#                  my $classid = $_;
#                  td( [ map {
#                      my $cattr=$_;
#                      defined($classes->{$classid}->{$cattr}) ? 
#                        grep(/^$cattr$/,@numeric_attrs) ?
#                          nbspaced($classes->{$classid}->{$cattr}) :
#                          $classes->{$classid}->{$cattr} :
#                        '' 
#                  } @classattrs  ] );
#              } sort keys %{$classes}
#          ] ) );


  print "<table border=\"1\">";
  print "<caption><h5>Traffic classes for device $device </h5></caption>";
  print "<tr>", map("<th scope=\"col\">$_</th>", @classattrs), "</tr>";
  for my $classid (sort keys %{$classes}) {
    print "\n<tr>";
    for my $cattr ( @classattrs ) {
      if ( $cattr eq 'classid' and $classes->{$classid}->{params} ) {
        print "<td title=\"params: $classes->{$classid}->{params}\">"
             . $classes->{$classid}->{$cattr} . '</td>';
      } elsif ( grep(/^$cattr$/,@numeric_attrs) ) {
        print '<td class="num">'. nbspaced($classes->{$classid}->{$cattr}) .'</td>';
      } else {
        print "<td class=\"$cattr\">".$classes->{$classid}->{$cattr}.'</td>';
      }
    }
    print "</tr>";
  }

  print "</table>";
  
}

print end_html();
=pod

example data for class list
/sbin/tc -s class list dev eth1
-----
class hfsc 8000: root 
 Sent 0 bytes 0 pkt (dropped 0, overlimits 0 requeues 0) 
 rate 0bit 0pps backlog 0b 0p requeues 0 
 period 0 level 3 

class hfsc 8000:202 parent 8000:20 leaf 800f: ls m1 0bit d 0us m2 1200Kbit ul m1 0bit d 0us m2 1500Kbit 
 Sent 8624492045 bytes 15546414 pkt (dropped 141090, overlimits 0 requeues 0) 
 rate 0bit 0pps backlog 0b 0p requeues 0 
 period 3764624 work 8566624030 bytes level 0 

class hfsc 8000:1 parent 8000: ls m1 0bit d 0us m2 3072Kbit ul m1 0bit d 0us m2 3072Kbit 
 Sent 0 bytes 0 pkt (dropped 0, overlimits 0 requeues 0) 
 rate 0bit 0pps backlog 0b 0p requeues 0 
 period 4227580 work 10693330798 bytes level 2 

class hfsc 8000:10 parent 8000:1 leaf 800d: rt m1 51000bit d 1.0s m2 30000bit 
 Sent 24842442 bytes 291762 pkt (dropped 0, overlimits 0 requeues 0) 
 rate 0bit 0pps backlog 0b 0p requeues 0 
 period 0 work 24842442 bytes rtwork 24842442 bytes level 0 

class hfsc 8000:20 parent 8000:1 ls m1 0bit d 0us m2 3042Kbit 
 Sent 0 bytes 0 pkt (dropped 0, overlimits 0 requeues 0) 
 rate 0bit 0pps backlog 0b 0p requeues 0 
 period 4227580 work 10668488356 bytes level 1 

class hfsc 8000:201 parent 8000:20 leaf 800e: ls m1 0bit d 0us m2 1842Kbit 
 Sent 2101864326 bytes 3187248 pkt (dropped 0, overlimits 0 requeues 0) 
 rate 0bit 0pps backlog 0b 0p requeues 0 
 period 2110527 work 2101864326 bytes level 0 

-----
example data for qdisc list
/sbin/tc -s -d qdisc list dev eth1
-----
qdisc hfsc 8000: default 201 
 Sent 738465381 bytes 1731923 pkt (dropped 104380, overlimits 2653530 requeues 0) 
 rate 0bit 0pps backlog 0b 100p requeues 0 
qdisc sfq 8010: parent 8000:10 limit 128p quantum 1514b flows 128/1024 perturb 5sec 
 Sent 950096 bytes 13385 pkt (dropped 0, overlimits 0 requeues 1685) 
 rate 0bit 0pps backlog 0b 0p requeues 1685 
qdisc sfq 8011: parent 8000:201 limit 128p quantum 1514b flows 128/1024 perturb 5sec 
 Sent 49103143 bytes 376419 pkt (dropped 0, overlimits 0 requeues 0) 
 rate 0bit 0pps backlog 0b 0p requeues 0 
qdisc sfq 8012: parent 8000:202 limit 128p quantum 1514b flows 128/1024 perturb 5sec 
 Sent 688409081 bytes 1342116 pkt (dropped 104368, overlimits 0 requeues 0) 
 rate 0bit 0pps backlog 0b 100p requeues 0 
qdisc ingress ffff: ---------------- 
 Sent 810019247 bytes 1645629 pkt (dropped 104, overlimits 0 requeues 0) 
 rate 0bit 0pps backlog 0b 0p requeues 0

=cut