#!/usr/bin/perl

#
# winex was here
# modified snmp.pl from http://www.docum.org/docum.org/gui/
#

use strict;
use warnings;


my $TC = "/sbin/tc";
my $DEBUG = 1;



if (!@ARGV) { die("Usage: $0 INTERFACE\n"); }


#
# usage:
#   my @lines = `$TC -s class show dev eth1`;
#   parse_tc(@lines);
#
sub parse_tc(@)
{
	my %stats;
	my $num = "";
	my $s   = "";

	foreach $s (@_)
	{
		$s =~ /^\s*$/
			and next;

		#class htb 1:1 root prio 0 rate 16000Kbit ceil 16000Kbit burst 2Kb cburst 22077b
		# If we have a root class, the parent = "major_number:"
		$s =~ /^[^\s]+ ([^\s]+) ([A-Za-z0-9]+:[A-Za-z0-9]+) root/
			and $stats{'qdisc'} = $1
			and $num = $2
			and $stats{'parent'}{"$num"} = (split(":", $num))[0].":";

		#class htb 1:100 parent 1:10 leaf 8002: prio 0 rate 8000Kbit ceil 8000Kbit burst 2Kb cburst 11838b
		$s =~ /^[^\s]+ ([^\s]+) ([A-Za-z0-9]+:[A-Za-z0-9]+) parent ([A-Za-z0-9]+:[A-Za-z0-9]+) leaf ([A-Za-z0-9]+:) prio/
			and $stats{'qdisc'} = $1
			and $num = $2
			and $stats{'parent'}{"$num"} = $3
			and $stats{'parent'}{"$3"} = $num
			and next;

		#class htb 1:10 parent 1:1 prio 0 rate 8000Kbit ceil 8000Kbit burst 2Kb cburst 11838b
		$s =~ /^[^\s]+ ([^\s]+) ([A-Za-z0-9]+:[A-Za-z0-9]+) parent ([A-Za-z0-9]+:[A-Za-z0-9]+) prio/
			and $stats{'qdisc'} = $1
			and $num = $2
			and $stats{'parent'}{"$num"} = $3
			and next;

		# Sent 0 bytes 0 pkt (dropped 0, overlimits 0 requeues 0)
		$s =~ /^ Sent (\d+) bytes (\d+) pkt \(dropped (\d+), overlimits (\d+) requeues (\d+)\)/
			and $stats{'bytes'}{"$num"} = "$1 $2 $3 $4 $5"
			and next;

		# rate 0bit 0pps backlog 0b 0p requeues 0
		$s =~ /^ rate/
			and next;

		# lended: 0 borrowed: 0 giants: 0
		$s =~ /^ lended: (\d+) borrowed: (\d+) giants: (\d+)/
			and $stats{'lended'}{"$num"} = "$1 $2 $3"
			and next;

		#  tokens: 1637 ctokens: 9471
		$s =~ /^ tokens: (\d+) ctokens: (\d+)/
			and $stats{'tokens'}{"$num"} = "$1 $2"
			and next;
	}

	return \%stats;
}

sub my_cmp
{
	my @aa = split(/:/, $a);
	my @bb = split(/:/, $b);
	return
	     ($aa[0] cmp $bb[0])
	  || ($aa[1] <=> $bb[1]);
}


my $type = "class";
my $if = "";

($ARGV[0] =~ /^-([^\s]+)/) and $type = $1 and shift;

# get specified info for all interfaces
warn("$type:\n") unless $DEBUG;
foreach $if (@ARGV)
{
	my @lines = `$TC -s $type show dev $if`;
	my $num   = "";
	my $s     = "";

	my $stats = parse_tc(@lines);
	my @keys  = sort my_cmp keys(%{$stats->{'bytes'}});

	# fill all unknown values with U
	foreach my $key (@keys)
	{
		if (!$stats->{'parent'}{"$key"}) { $stats->{'parent'}{"$key"} = "U"; }
		if (!$stats->{'lended'}{"$key"}) { $stats->{'lended'}{"$key"} = "U U U"; }
		if (!$stats->{'tokens'}{"$key"}) { $stats->{'tokens'}{"$key"} = "U U"; }
	}

	# process all info and fill unknown values with UNKNOWN
	my @heads = ('if', 'name', 'bytes', 'packets', 'dropped', 'overlimits', 'requeues', 'lended', 'borrowed', 'giants');
	my @cols  = ('bytes', 'lended', 'tokens');
	my $return = join(' ', @heads)."\n";
	foreach my $key (@keys)
	{
		$return .= "$if $key";
		foreach my $c (@cols)
		{
			$return .= " ".$stats->{"$c"}{"$key"};
		}
		$return .= "\n";
	}

	## Some stuff so the snmp server is happy
	##   Don't ask me why, but I have to do this so I have no errors in my log-file
	#if ( $ARGV[1] eq ".1.3.6.1.4.1.2021.255.1" )
	#{
	#        exit;
	#}

	#if ((@ARGV > 1) and ($ARGV[1] eq ".1.3.6.1.4.1.2021.255"))
	#{
	#	print ".1.3.6.1.4.1.2021.255\n";
	#	print "string\n$return\n";
	#}
	#else
	{
		print "$return\n";
	}
}