[people/teissler/ipfire-2.x.git] / config / qos / parse-func.pl

#!/usr/bin/perl

##########################################
##
## NAME
##
## DESCRIPTION
##
##   Which is part of the ADSL-optimizer.
##
## USAGE / FUNCTIONS
##   
##   
##   
##    
##
## REQUIRES
##
##
## AUTHOR
##   Jesper Dangaard Brouer <hawk@diku.dk>, d.15/4-2004
##
## CHANGELOG
##   2004-04-15:  Initial version.
##   2005-04-18:  Remove some warnings.
##
##########################################

#use Data::Dumper;

#our %classes_data;
#our %classes_info;
#our $tc_command="/sbin/tc";

my @input_htb = (<<"END_OF_HERE_HTB" =~ m/^\s*(.+)/gm);
class tbf 4220:1 parent 4220: 
class htb 1:1 root rate 400Kbit ceil 400Kbit burst 2111b cburst 2111b 
 Sent 12369084336 bytes 80967118 pkts (dropped 0, overlimits 0) 
 rate 45020bps 258pps 
 lended: 23353805 borrowed: 0 giants: 0
 tokens: 30210 ctokens: 30210

class htb 1:10 parent 1:1 prio 0 rate 80Kbit ceil 320Kbit burst 1701b cburst 2008b 
 Sent 80640087 bytes 247988 pkts (dropped 0, overlimits 0) 
 backlog 42p 
 lended: 230876 borrowed: 17112 giants: 0
 tokens: 127200 ctokens: 37940

class htb 1:20 parent 1:1 leaf 4220: prio 1 rate 100Kbit ceil 200Kbit burst 1727b cburst 1855b 
 Sent 2495181573 bytes 44034303 pkts (dropped 5837, overlimits 0) 
 lended: 43825585 borrowed: 208718 giants: 0
 tokens: 103424 ctokens: 55808

class htb 1:30 parent 1:1 leaf 4230: prio 3 rate 80Kbit ceil 400Kbit burst 1701b cburst 2111b 
 Sent 2060213567 bytes 5465574 pkts (dropped 121, overlimits 0) 
 rate 16851bps 35pps 
 lended: 4556992 borrowed: 908582 giants: 0
 tokens: -25364 ctokens: 32897

class htb 1:50 parent 1:1 leaf 4250: prio 5 rate 40Kbit ceil 120Kbit burst 1650b cburst 1752b 
 Sent 6071486687 bytes 24448436 pkts (dropped 8086739, overlimits 0) 
 rate 15801bps 85pps backlog 126p 
 lended: 8324530 borrowed: 16123780 giants: 0
 tokens: -202717 ctokens: -172499

class htb 1:666 parent 1:1 leaf 666: prio 7 rate 4Kbit ceil 40Kbit burst 1604b cburst 1650b 
 Sent 2148626078 bytes 6771069 pkts (dropped 2078536, overlimits 0) 
 rate 5221bps 17pps backlog 125p 
 lended: 675330 borrowed: 6095613 giants: 0
 tokens: -1149121 ctokens: -293386

END_OF_HERE_HTB


my @input_hfsc = (<<"END_OF_HERE_HFSC" =~ m/^\s*(.+)/gm);
class hfsc 1: root 
 Sent 0 bytes 0 pkts (dropped 0, overlimits 0) 
 period 0 level 2 

class hfsc 1:1 parent 1: ls m1 0bps d 0us m2 250Kbit ul m1 0bps d 0us m2 250Kbit 
 Sent 0 bytes 0 pkts (dropped 0, overlimits 0) 
 period 6 work 131770097 bytes level 1 

class hfsc 1:10 parent 1:1 rt m1 250Kbit d 30.0ms m2 50Kbit ls m1 250Kbit d 50.0ms m2 50Kbit 
 Sent 1300885 bytes 7052 pkts (dropped 0, overlimits 0) 
 period 6502 work 1300885 bytes rtwork 1245495 bytes level 0 

class hfsc 1:20 parent 1: rt m1 0bps d 64.0ms m2 75Kbit ls m1 0bps d 0us m2 250Kbit 
 Sent 19144279 bytes 325503 pkts (dropped 46, overlimits 0) 
 backlog 3p 
 period 20242 work 19143778 bytes level 0 

class hfsc 1:30 parent 1:1 leaf 4230: ls m1 0bps d 150.0ms m2 50Kbit 
 Sent 45139930 bytes 74200 pkts (dropped 1664, overlimits 0) 
 backlog 24p 
 period 140 work 44885232 bytes level 0 

class hfsc 1:50 parent 1:1 leaf 4250: ls m1 0bps d 235.7ms m2 72Kbit 
 Sent 73910198 bytes 301294 pkts (dropped 104807, overlimits 0) 
 backlog 62p 
 period 115 work 64625490 bytes level 0 

class hfsc 1:666 parent 1:1 leaf 666: ls m1 0bps d 1.0s m2 2Kbit 
 Sent 2217104 bytes 17018 pkts (dropped 74526, overlimits 0) 
 backlog 22p 
 period 1 work 1814712 bytes level 0 

END_OF_HERE_HFSC

sub parse_class($) {
    my $device = "$_[0]";
    my $return_val = 1;

    my $timestamp = time;
    my @tc_output = `$tc_command -statistics class show dev $device`;
#    my @tc_output = @input_hfsc;
#    my @tc_output = @input_htb;
    my $result = $?;
    if ( $result != 0 ) {
	print "Error executing $tc_command\n";
	return $result;
    }

    $classes_data{last_update}{$device} = $timestamp;
    $classes_info{last_update}{$device} = $timestamp;

    #for my $line (@tc_output) {
    for my $i (0 .. $#tc_output) {

	my $line=$tc_output[$i];
	# Parsing HTB:
	# ------------
	if ( $line =~ m/class htb (\d+):(\d+)( root| parent )?(\d+:\d+)?( leaf )?(\d+)?:?( prio )?(\d+)? rate (.*) ceil (.*) burst (.*) cburst (.*)/ ) {
	    my $type  = "htb";
	    my $major = $1;
	    my $minor = $2;
	    my $class = "${major}-${minor}";
	    #my $hash  = "${class}_${device}";
	    my $parent= $4;
	    my $leaf  = $6;
	    my $prio  = $8;
	    my $rate  = $9;
	    my $ceil  = $10;
	    my $burst = $11;
	    my $cburst= $12;

	    #print "class: $class\n"."parent: $parent\n"."leaf: $leaf\n"."prio: $prio\n";
	    #print "rate: $rate\n"."ceil: $ceil\n"."burst: $burst\n"."cburst: $cburst\n";
	    
	    my ($bytes, $pkts, $dropped, $overlimits);
	    if ($tc_output[$i + 1] =~ m/Sent (\d+) bytes (\d+) pkt \(dropped (\d+), overlimits (\d+) requeues (\d+)\)/ ) {
		$bytes      = $1;
		$pkts       = $2;
		$dropped    = $3;
		$overlimits = $4;
		$requeues   = $5;
		#print "bytes: $bytes\n"."pkts: $pkts\n";
		#print "dropped: $dropped\n"."overlimits: $overlimits\n"."requeues: $requeues\n";
	    } else { 
		print "$timestamp: ERROR(+1) - Unable to parse (class ${class}_$device): ";
		print "\"$tc_output[$i + 1]\"\n";
		$return_val="";
		next;
	    } 

	    # Problem:
	    #  Sometimes the "rate" line is not shown (when a rate cannot be calculated)
	    #  And sometimes only "backlog"...
	    # Use $next_index to specify the next line to parse
	    #
	    my $next_index = 3;
	    my ($backlog);
	    if ($tc_output[$i + 2] =~ m/((rate (\d+\w+) )|backlog )(\d+)?(pps )?(backlog )?(\d+)?p?/ ) {
		$backlog = $7;
		#print "backlog: $backlog\n";
	    } else { 
# Too verbose:
#		print "$timestamp: WARNING \"rate\" line missing";
#		print " very inactive class ${class}_$device).\n";
		$next_index = 2;		
	    } 

	    my ($lended, $borrowed, $giants);
	    if ($tc_output[$i + $next_index] =~ m/lended: (\d+) borrowed: (\d+) giants: (\d+)/ ) {
		$lended   = $1;
		$borrowed = $2;
		$giants   = $3;
		#print "lended: $lended\n"."borrowed: $borrowed\n"."giants: $giants\n";
	    } else { 
		print "$timestamp: ERROR(+$next_index) - Unable to parse (class ${class}_$device): ";
		print "\"$tc_output[$i + $next_index]\"\n";
		$return_val="";
		next;
	    } 

	    # Update the hash tables	 
	    my $hash="${class}_$device";

	    # Tests if previous data have been updated to file
	    if ( (exists $classes_data{$hash}{last_update}) &&
		 (exists $classes_data{$hash}{file_update})) {
		if ( $classes_data{$hash}{last_update} >
		     $classes_data{$hash}{file_update}   ){
		    print "Warning: old data from $hash has not been updated to file!\n";
		}
	    }

	    # Update the statistics data
	    # (need a function call for error checking)
	    $classes_data{$hash}{last_update} = $timestamp;
	    update_counter( $hash, $timestamp, "bytes"     , $bytes);
	    #(yes I know its bad/redundant, but it makes in easier elsewhere)
	    #print "\n";	  
	}

	# Parsing HFSC:
	# -------------
	if ( $line =~ m/class hfsc (\d+):(\d+)( root| parent )?(\d+:\d?)?( leaf )?(\d+)?:?( rt m1 (\d+\w+?) d (\d+.?\d?\w+) m2 (\d+\w+?))?( ls m1 (\d+\w+?) d (\d+.?\d?\w+) m2 (\d+\w+?))?( ul m1 (\d+\w+?) d (\d+.?\d?\w+) m2 (\d+\w+?))? / ){

	    my $type  = "hfsc";
	    my $major = $1;
	    my $minor = $2;
	    my $class = "${major}-${minor}";
	    #my $hash  = "${class}_${device}";
	    my $parent= $4;
	    my $leaf  = $6;

	    my $realtime_m1; if (defined $8 && $8 ne '0bps') {$realtime_m1 = $8;}
	    my $realtime_d;  if (defined $9 && $9 ne '0us' ) {$realtime_d  = $9;}
	    my $realtime_m2 = $10;

	    my $linkshare_m1; if (defined $12 && $12 ne '0bps') { $linkshare_m1 = $12;}
	    my $linkshare_d ; if (defined $13 && $13 ne '0us' ) { $linkshare_d  = $13;}
	    my $linkshare_m2 = $14;

	    my $upperlimit_m1; if (defined $16 && $16 ne '0bps') { $upperlimit_m1 = $16;}
	    my $upperlimit_d ; if (defined $17 && $17 ne '0us' ) { $upperlimit_d  = $17;}
	    my $upperlimit_m2 = $18;

	    #print "\nType: $type\n";
	    my $bytes;
	    if ($tc_output[$i + 1] =~ m/Sent (\d+) bytes (\d+) pkts \(dropped (\d+), overlimits (\d+)\)/ ) {
		$bytes      = $1;
		#print "bytes: $bytes\n"."pkts: $pkts\n";
	    } else {
		print "$timestamp: ERROR(+1) - Unable to parse (class ${class}_$device): ";
		print "\"$tc_output[$i + 1]\"\n";
		$return_val="";
		next;
	    } 

	    # Sometimes the "backlog" line is not shown (when there is no backlog...)
	    # Use $next_index to specify the next line to parse
	    #
	    my $next_index = 3;
	    my ($backlog);
	    if ($tc_output[$i + 2] =~ m/backlog (\d+)?p?/ ) {
		$backlog = $1;
		#print "backlog: $backlog\n";
	    } else { 
		$next_index = 2;		
	    } 

	    my ($period, $work, $rtwork, $level);
	    if ($tc_output[$i + $next_index] =~ m/period (\d+) (work (\d+) bytes )?(rtwork (\d+) bytes )?level (\d+)/ ) {
		$period = $1;
		$work   = $3;
		$rtwork = $5;
		$level  = $6
	    } else { 
		print "$timestamp: ERROR(+$next_index) - Unable to parse (class ${class}_$device): ";
		print "\"$tc_output[$i + $next_index]\"\n";
		$return_val="";
		next;
	    } 
	    

	    # Update the hash tables	 
	    my $hash="${class}_$device";

	    # Tests if previous data have been updated to file
	    if ( (exists $classes_data{$hash}{last_update}) &&
		 (exists $classes_data{$hash}{file_update})) {
		if ( $classes_data{$hash}{last_update} >
		     $classes_data{$hash}{file_update}   ){
		    print "Warning: old data from $hash has not been updated to file!\n";
		}
	    }

	    # HFSC - Update the statistics data
	    # (need a function call for error checking)
	    $classes_data{$hash}{last_update} = $timestamp;
	    update_counter( $hash, $timestamp, "bytes"     , $bytes);

	}

	# Parsing XXX:
	# ------------
	if ( $line =~ m/class XXX/ ) {
	    print "Matching class XXX\n";
	}

    }
    return $return_val;
}

# The main purpose of this function is to detect counter resets 
#  and avoid parsing them on to RRDtool which interprets them
#  as counter overflows, thus updating with a very large number.
sub update_counter  ($$$$) {
    my $class_hash = "$_[0]";
    my $timestamp  = "$_[1]";
    my $data_key   = "$_[2]";
    my $new_value;
    if ( defined $_[3]) {
	$new_value = "$_[3]";
    }
    # 
    my $max_allowed_wrap_increase = 100000000;
    my $old_value;
    if (exists $classes_data{$class_hash}{$data_key}) {
	$old_value  =  $classes_data{$class_hash}{$data_key};
        #print "old_value: $old_value\n";
    }

#    # If the new and old value is not defined, nothing is done 
#    if ((not defined $new_value) && (not defined $old_value)) {
#	return "";
#    }

    # Argh... the tc program outputs in unsigned long long (64 bit).
    #  but perls integers should be 32 bit, but some how perl
    #  manages to store numbers larger than 32 bit numbers.
    my $MAX_VALUE=0xFFFFFFFF;

    if ((defined $new_value) && (defined $old_value)) {
	my $delta = $new_value - $old_value;
	if ( $delta < 0 ) {
	    # Counter wrap around...
	    my $real_delta = $delta + $MAX_VALUE + 1;
	    if ($real_delta < 0) {
		print "($class_hash:$data_key): Perl-Magic using numbers bigger than 32bit ";
		print "new:$new_value - old:$old_value = delta:$delta, real_delta:$real_delta.\n";
	    }
	    print time . " ($class_hash:$data_key) Info: Counter wrap around (real delta:$real_delta)\n";
	    if ( ($real_delta > $max_allowed_wrap_increase) ||
		 ($real_delta < 0)) {
		# Properly a counter reset and not a wrap around 
		# A counter reset normally a result of a reload of the classes
		$classes_data{$class_hash}{$data_key}     = undef;
		$classes_info{$class_hash}{counter_reset} = $timestamp; 
		$classes_info{$class_hash}{last_update}   = $timestamp; 
		print time . "Warning: Real_delta too big, assuming Counter reset";
		print        "($class_hash:$data_key)\n";
		return "Counter reset";	      
	    }
	}
    }
   
    $classes_data{$class_hash}{$data_key} = $new_value;
    return 1;
}

sub update_info ($$$$) {
    my $class_hash = "$_[0]";
    my $timestamp  = "$_[1]";
    my $info_key   = "$_[2]";
    my $new_value;
    if ( defined $_[3]) {
	$new_value = "$_[3]";
    }
    my $old_value;
    if (exists $classes_info{$class_hash}{$info_key}) {
	$old_value  =  $classes_info{$class_hash}{$info_key};
        #print "old_value: $old_value\n";
    }

    # If the new and old value is not defined, nothing is done 
    if ((not defined $new_value) && (not defined $old_value)) {
	return "";
    }
    
    # An update is needed
    # - if the old_value is not defined and new_value is defined
    # - if the new_value is not defined and old_value is defined
    # - if the old_value differs from the new, 
    #
    if ( ((not defined $old_value) and (defined $new_value)) ||
	 ((not defined $new_value) and (defined $old_value)) ||
	 ("$old_value" ne "$new_value")) {

	# Special case: If the "type" changes the hash should be cleared
	if ( "$info_key" eq "type") {
	    #print "Type has changed clearing hash \n";
	    for my $key ( keys %{ $classes_info{$class_hash} } ) {
		delete( $classes_info{$class_hash}{$key});
		print " Deleting key: $key from: $class_hash \n";
	    }
	}

	if (defined $new_value) {
	    $classes_info{$class_hash}{$info_key} = $new_value;
	} else {
	    #print "New value undef -> Deleting key: $info_key from: $class_hash\n";
	    delete($classes_info{$class_hash}{$info_key});
	}
	    
	# Mark the class for an info-file update
	$classes_info{$class_hash}{last_update} = $timestamp;
	
	# Update list/array of "changed" keys
	push @{ $classes_info{$class_hash}{changed} }, $info_key; 

	# Print debug info
	#print "Update class:$class_hash $info_key=";
	#if (defined $new_value) {print "$new_value"};
	#print "\n";
	return 1;
    }
    return "";
}

# test
#parse_class(eth1);

#print Dumper(%classes_data);
#print Dumper(%classes_info);

return 1;
Commit	Line	Data
a7fb5630 MT	1	#!/usr/bin/perl
	2
	3	##########################################
	4	##
	5	## NAME
	6	##
	7	## DESCRIPTION
	8	##
	9	## Which is part of the ADSL-optimizer.
	10	##
	11	## USAGE / FUNCTIONS
	12	##
	13	##
	14	##
	15	##
	16	##
	17	## REQUIRES
	18	##
	19	##
	20	## AUTHOR
	21	## Jesper Dangaard Brouer <hawk@diku.dk>, d.15/4-2004
	22	##
	23	## CHANGELOG
	24	## 2004-04-15: Initial version.
	25	## 2005-04-18: Remove some warnings.
	26	##
a7fb5630 MT	27	##########################################
	28
	29	#use Data::Dumper;
	30
	31	#our %classes_data;
	32	#our %classes_info;
	33	#our $tc_command="/sbin/tc";
	34
	35	my @input_htb = (<<"END_OF_HERE_HTB" =~ m/^\s*(.+)/gm);
	36	class tbf 4220:1 parent 4220:
	37	class htb 1:1 root rate 400Kbit ceil 400Kbit burst 2111b cburst 2111b
	38	Sent 12369084336 bytes 80967118 pkts (dropped 0, overlimits 0)
	39	rate 45020bps 258pps
	40	lended: 23353805 borrowed: 0 giants: 0
	41	tokens: 30210 ctokens: 30210
	42
	43	class htb 1:10 parent 1:1 prio 0 rate 80Kbit ceil 320Kbit burst 1701b cburst 2008b
	44	Sent 80640087 bytes 247988 pkts (dropped 0, overlimits 0)
	45	backlog 42p
	46	lended: 230876 borrowed: 17112 giants: 0
	47	tokens: 127200 ctokens: 37940
	48
	49	class htb 1:20 parent 1:1 leaf 4220: prio 1 rate 100Kbit ceil 200Kbit burst 1727b cburst 1855b
	50	Sent 2495181573 bytes 44034303 pkts (dropped 5837, overlimits 0)
	51	lended: 43825585 borrowed: 208718 giants: 0
	52	tokens: 103424 ctokens: 55808
	53
	54	class htb 1:30 parent 1:1 leaf 4230: prio 3 rate 80Kbit ceil 400Kbit burst 1701b cburst 2111b
	55	Sent 2060213567 bytes 5465574 pkts (dropped 121, overlimits 0)
	56	rate 16851bps 35pps
	57	lended: 4556992 borrowed: 908582 giants: 0
	58	tokens: -25364 ctokens: 32897
	59
	60	class htb 1:50 parent 1:1 leaf 4250: prio 5 rate 40Kbit ceil 120Kbit burst 1650b cburst 1752b
	61	Sent 6071486687 bytes 24448436 pkts (dropped 8086739, overlimits 0)
	62	rate 15801bps 85pps backlog 126p
	63	lended: 8324530 borrowed: 16123780 giants: 0
	64	tokens: -202717 ctokens: -172499
	65
	66	class htb 1:666 parent 1:1 leaf 666: prio 7 rate 4Kbit ceil 40Kbit burst 1604b cburst 1650b
	67	Sent 2148626078 bytes 6771069 pkts (dropped 2078536, overlimits 0)
	68	rate 5221bps 17pps backlog 125p
	69	lended: 675330 borrowed: 6095613 giants: 0
	70	tokens: -1149121 ctokens: -293386
	71
	72	END_OF_HERE_HTB
	73
	74
	75	my @input_hfsc = (<<"END_OF_HERE_HFSC" =~ m/^\s*(.+)/gm);
	76	class hfsc 1: root
	77	Sent 0 bytes 0 pkts (dropped 0, overlimits 0)
	78	period 0 level 2
	79
	80	class hfsc 1:1 parent 1: ls m1 0bps d 0us m2 250Kbit ul m1 0bps d 0us m2 250Kbit
	81	Sent 0 bytes 0 pkts (dropped 0, overlimits 0)
	82	period 6 work 131770097 bytes level 1
	83
	84	class hfsc 1:10 parent 1:1 rt m1 250Kbit d 30.0ms m2 50Kbit ls m1 250Kbit d 50.0ms m2 50Kbit
	85	Sent 1300885 bytes 7052 pkts (dropped 0, overlimits 0)
	86	period 6502 work 1300885 bytes rtwork 1245495 bytes level 0
	87
	88	class hfsc 1:20 parent 1: rt m1 0bps d 64.0ms m2 75Kbit ls m1 0bps d 0us m2 250Kbit
	89	Sent 19144279 bytes 325503 pkts (dropped 46, overlimits 0)
	90	backlog 3p
91	period 20242 work 19143778 bytes level 0
92
93	class hfsc 1:30 parent 1:1 leaf 4230: ls m1 0bps d 150.0ms m2 50Kbit
94	Sent 45139930 bytes 74200 pkts (dropped 1664, overlimits 0)
95	backlog 24p
96	period 140 work 44885232 bytes level 0
97
98	class hfsc 1:50 parent 1:1 leaf 4250: ls m1 0bps d 235.7ms m2 72Kbit
99	Sent 73910198 bytes 301294 pkts (dropped 104807, overlimits 0)
100	backlog 62p
101	period 115 work 64625490 bytes level 0
102
103	class hfsc 1:666 parent 1:1 leaf 666: ls m1 0bps d 1.0s m2 2Kbit
104	Sent 2217104 bytes 17018 pkts (dropped 74526, overlimits 0)
105	backlog 22p
106	period 1 work 1814712 bytes level 0
107
108	END_OF_HERE_HFSC
109
110	sub parse_class($) {
111	my $device = "$_[0]";
112	my $return_val = 1;
113
114	my $timestamp = time;
115	my @tc_output = `$tc_command -statistics class show dev $device`;
116	# my @tc_output = @input_hfsc;
117	# my @tc_output = @input_htb;
118	my $result = $?;
119	if ( $result != 0 ) {
120	print "Error executing $tc_command\n";
121	return $result;
122	}
123
124	$classes_data{last_update}{$device} = $timestamp;
125	$classes_info{last_update}{$device} = $timestamp;
126
127	#for my $line (@tc_output) {
128	for my $i (0 .. $#tc_output) {
129
130	my $line=$tc_output[$i];
131	# Parsing HTB:
132	# ------------
f1df2c41	133	if ( $line =~ m/class htb (\d+):(\d+)( root\| parent )?(\d+:\d+)?( leaf )?(\d+)?:?( prio )?(\d+)? rate (.) ceil (.) burst (.) cburst (.)/ ) {
a7fb5630 MT	134	my $type = "htb";
	135	my $major = $1;
	136	my $minor = $2;
	137	my $class = "${major}-${minor}";
	138	#my $hash = "${class}_${device}";
	139	my $parent= $4;
	140	my $leaf = $6;
	141	my $prio = $8;
	142	my $rate = $9;
	143	my $ceil = $10;
	144	my $burst = $11;
	145	my $cburst= $12;
	146
6f300951 MT	147	#print "class: $class\n"."parent: $parent\n"."leaf: $leaf\n"."prio: $prio\n";
6f300951 MT	148	#print "rate: $rate\n"."ceil: $ceil\n"."burst: $burst\n"."cburst: $cburst\n";
a7fb5630 MT	149
a7fb5630 MT	150	my ($bytes, $pkts, $dropped, $overlimits);
6f300951	151	if ($tc_output[$i + 1] =~ m/Sent (\d+) bytes (\d+) pkt \(dropped (\d+), overlimits (\d+) requeues (\d+)\)/ ) {
a7fb5630 MT	152	$bytes = $1;
	153	$pkts = $2;
	154	$dropped = $3;
	155	$overlimits = $4;
6f300951 MT	156	$requeues = $5;
	157	#print "bytes: $bytes\n"."pkts: $pkts\n";
	158	#print "dropped: $dropped\n"."overlimits: $overlimits\n"."requeues: $requeues\n";
a7fb5630	159	} else {
6f300951 MT	160	print "$timestamp: ERROR(+1) - Unable to parse (class ${class}_$device): ";
6f300951 MT	161	print "\"$tc_output[$i + 1]\"\n";
a7fb5630 MT	162	$return_val="";
	163	next;
	164	}
	165
	166	# Problem:
	167	# Sometimes the "rate" line is not shown (when a rate cannot be calculated)
	168	# And sometimes only "backlog"...
	169	# Use $next_index to specify the next line to parse
	170	#
	171	my $next_index = 3;
	172	my ($backlog);
	173	if ($tc_output[$i + 2] =~ m/((rate (\d+\w+) )\|backlog )(\d+)?(pps )?(backlog )?(\d+)?p?/ ) {
	174	$backlog = $7;
	175	#print "backlog: $backlog\n";
	176	} else {
	177	# Too verbose:
	178	# print "$timestamp: WARNING \"rate\" line missing";
	179	# print " very inactive class ${class}_$device).\n";
	180	$next_index = 2;
	181	}
	182
	183	my ($lended, $borrowed, $giants);
	184	if ($tc_output[$i + $next_index] =~ m/lended: (\d+) borrowed: (\d+) giants: (\d+)/ ) {
	185	$lended = $1;
	186	$borrowed = $2;
	187	$giants = $3;
	188	#print "lended: $lended\n"."borrowed: $borrowed\n"."giants: $giants\n";
	189	} else {
	190	print "$timestamp: ERROR(+$next_index) - Unable to parse (class ${class}_$device): ";
	191	print "\"$tc_output[$i + $next_index]\"\n";
	192	$return_val="";
	193	next;
	194	}
	195
	196	# Update the hash tables
	197	my $hash="${class}_$device";
	198
	199	# Tests if previous data have been updated to file
	200	if ( (exists $classes_data{$hash}{last_update}) &&
	201	(exists $classes_data{$hash}{file_update})) {
	202	if ( $classes_data{$hash}{last_update} >
	203	$classes_data{$hash}{file_update} ){
	204	print "Warning: old data from $hash has not been updated to file!\n";
	205	}
	206	}
	207
	208	# Update the statistics data
	209	# (need a function call for error checking)
	210	$classes_data{$hash}{last_update} = $timestamp;
	211	update_counter( $hash, $timestamp, "bytes" , $bytes);
	212	#(yes I know its bad/redundant, but it makes in easier elsewhere)
a7fb5630 MT	213	#print "\n";
	214	}
	215
	216	# Parsing HFSC:
	217	# -------------
	218	if ( $line =~ m/class hfsc (\d+):(\d+)( root\| parent )?(\d+:\d?)?( leaf )?(\d+)?:?( rt m1 (\d+\w+?) d (\d+.?\d?\w+) m2 (\d+\w+?))?( ls m1 (\d+\w+?) d (\d+.?\d?\w+) m2 (\d+\w+?))?( ul m1 (\d+\w+?) d (\d+.?\d?\w+) m2 (\d+\w+?))? / ){
	219
	220	my $type = "hfsc";
	221	my $major = $1;
	222	my $minor = $2;
	223	my $class = "${major}-${minor}";
	224	#my $hash = "${class}_${device}";
	225	my $parent= $4;
	226	my $leaf = $6;
	227
	228	my $realtime_m1; if (defined $8 && $8 ne '0bps') {$realtime_m1 = $8;}
	229	my $realtime_d; if (defined $9 && $9 ne '0us' ) {$realtime_d = $9;}
	230	my $realtime_m2 = $10;
	231
	232	my $linkshare_m1; if (defined $12 && $12 ne '0bps') { $linkshare_m1 = $12;}
	233	my $linkshare_d ; if (defined $13 && $13 ne '0us' ) { $linkshare_d = $13;}
	234	my $linkshare_m2 = $14;
	235
	236	my $upperlimit_m1; if (defined $16 && $16 ne '0bps') { $upperlimit_m1 = $16;}
	237	my $upperlimit_d ; if (defined $17 && $17 ne '0us' ) { $upperlimit_d = $17;}
	238	my $upperlimit_m2 = $18;
	239
	240	#print "\nType: $type\n";
e19fc87f	241	my $bytes;
a7fb5630 MT	242	if ($tc_output[$i + 1] =~ m/Sent (\d+) bytes (\d+) pkts \(dropped (\d+), overlimits (\d+)\)/ ) {
a7fb5630 MT	243	$bytes = $1;
a7fb5630	244	#print "bytes: $bytes\n"."pkts: $pkts\n";
e19fc87f	245	} else {
a7fb5630 MT	246	print "$timestamp: ERROR(+1) - Unable to parse (class ${class}_$device): ";
	247	print "\"$tc_output[$i + 1]\"\n";
	248	$return_val="";
	249	next;
	250	}
	251
	252	# Sometimes the "backlog" line is not shown (when there is no backlog...)
	253	# Use $next_index to specify the next line to parse
	254	#
	255	my $next_index = 3;
	256	my ($backlog);
	257	if ($tc_output[$i + 2] =~ m/backlog (\d+)?p?/ ) {
	258	$backlog = $1;
	259	#print "backlog: $backlog\n";
	260	} else {
	261	$next_index = 2;
	262	}
	263
	264	my ($period, $work, $rtwork, $level);
	265	if ($tc_output[$i + $next_index] =~ m/period (\d+) (work (\d+) bytes )?(rtwork (\d+) bytes )?level (\d+)/ ) {
	266	$period = $1;
	267	$work = $3;
	268	$rtwork = $5;
	269	$level = $6
	270	} else {
	271	print "$timestamp: ERROR(+$next_index) - Unable to parse (class ${class}_$device): ";
	272	print "\"$tc_output[$i + $next_index]\"\n";
	273	$return_val="";
	274	next;
	275	}
	276
	277
	278	# Update the hash tables
	279	my $hash="${class}_$device";
	280
	281	# Tests if previous data have been updated to file
	282	if ( (exists $classes_data{$hash}{last_update}) &&
	283	(exists $classes_data{$hash}{file_update})) {
	284	if ( $classes_data{$hash}{last_update} >
	285	$classes_data{$hash}{file_update} ){
	286	print "Warning: old data from $hash has not been updated to file!\n";
	287	}
	288	}
	289
	290	# HFSC - Update the statistics data
	291	# (need a function call for error checking)
	292	$classes_data{$hash}{last_update} = $timestamp;
	293	update_counter( $hash, $timestamp, "bytes" , $bytes);
a7fb5630 MT	294
	295	}
	296
	297	# Parsing XXX:
	298	# ------------
	299	if ( $line =~ m/class XXX/ ) {
	300	print "Matching class XXX\n";
	301	}
	302
	303	}
	304	return $return_val;
	305	}
	306
	307	# The main purpose of this function is to detect counter resets
	308	# and avoid parsing them on to RRDtool which interprets them
	309	# as counter overflows, thus updating with a very large number.
	310	sub update_counter ($$$$) {
	311	my $class_hash = "$_[0]";
	312	my $timestamp = "$_[1]";
	313	my $data_key = "$_[2]";
	314	my $new_value;
	315	if ( defined $_[3]) {
	316	$new_value = "$_[3]";
	317	}
	318	#
	319	my $max_allowed_wrap_increase = 100000000;
	320	my $old_value;
	321	if (exists $classes_data{$class_hash}{$data_key}) {
	322	$old_value = $classes_data{$class_hash}{$data_key};
	323	#print "old_value: $old_value\n";
	324	}
	325
	326	# # If the new and old value is not defined, nothing is done
	327	# if ((not defined $new_value) && (not defined $old_value)) {
	328	# return "";
	329	# }
	330
	331	# Argh... the tc program outputs in unsigned long long (64 bit).
	332	# but perls integers should be 32 bit, but some how perl
	333	# manages to store numbers larger than 32 bit numbers.
	334	my $MAX_VALUE=0xFFFFFFFF;
	335
	336	if ((defined $new_value) && (defined $old_value)) {
	337	my $delta = $new_value - $old_value;
	338	if ( $delta < 0 ) {
	339	# Counter wrap around...
	340	my $real_delta = $delta + $MAX_VALUE + 1;
	341	if ($real_delta < 0) {
	342	print "($class_hash:$data_key): Perl-Magic using numbers bigger than 32bit ";
	343	print "new:$new_value - old:$old_value = delta:$delta, real_delta:$real_delta.\n";
	344	}
	345	print time . " ($class_hash:$data_key) Info: Counter wrap around (real delta:$real_delta)\n";
	346	if ( ($real_delta > $max_allowed_wrap_increase) \|\|
	347	($real_delta < 0)) {
	348	# Properly a counter reset and not a wrap around
	349	# A counter reset normally a result of a reload of the classes
	350	$classes_data{$class_hash}{$data_key} = undef;
	351	$classes_info{$class_hash}{counter_reset} = $timestamp;
	352	$classes_info{$class_hash}{last_update} = $timestamp;
	353	print time . "Warning: Real_delta too big, assuming Counter reset";
	354	print "($class_hash:$data_key)\n";
	355	return "Counter reset";
	356	}
	357	}
358	}
359
360	$classes_data{$class_hash}{$data_key} = $new_value;
361	return 1;
362	}
363
364	sub update_info ($$$$) {
365	my $class_hash = "$_[0]";
366	my $timestamp = "$_[1]";
367	my $info_key = "$_[2]";
368	my $new_value;
369	if ( defined $_[3]) {
370	$new_value = "$_[3]";
371	}
372	my $old_value;
373	if (exists $classes_info{$class_hash}{$info_key}) {
374	$old_value = $classes_info{$class_hash}{$info_key};
375	#print "old_value: $old_value\n";
376	}
377
378	# If the new and old value is not defined, nothing is done
379	if ((not defined $new_value) && (not defined $old_value)) {
380	return "";
381	}
382
383	# An update is needed
384	# - if the old_value is not defined and new_value is defined
385	# - if the new_value is not defined and old_value is defined
386	# - if the old_value differs from the new,
387	#
388	if ( ((not defined $old_value) and (defined $new_value)) \|\|
389	((not defined $new_value) and (defined $old_value)) \|\|
390	("$old_value" ne "$new_value")) {
391
392	# Special case: If the "type" changes the hash should be cleared
393	if ( "$info_key" eq "type") {
394	#print "Type has changed clearing hash \n";
395	for my $key ( keys %{ $classes_info{$class_hash} } ) {
396	delete( $classes_info{$class_hash}{$key});
397	print " Deleting key: $key from: $class_hash \n";
398	}
399	}
400
401	if (defined $new_value) {
402	$classes_info{$class_hash}{$info_key} = $new_value;
403	} else {
404	#print "New value undef -> Deleting key: $info_key from: $class_hash\n";
405	delete($classes_info{$class_hash}{$info_key});
406	}
407
408	# Mark the class for an info-file update
409	$classes_info{$class_hash}{last_update} = $timestamp;
410
411	# Update list/array of "changed" keys
412	push @{ $classes_info{$class_hash}{changed} }, $info_key;
413
414	# Print debug info
415	#print "Update class:$class_hash $info_key=";
416	#if (defined $new_value) {print "$new_value"};
417	#print "\n";
418	return 1;
419	}
420	return "";
421	}
422
423	# test
424	#parse_class(eth1);
425
426	#print Dumper(%classes_data);
427	#print Dumper(%classes_info);
428
429	return 1;