[people/pmueller/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

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;
  	#print "bytes: $bytes\n";
	    } else { 
		print "$timestamp: ERROR(+1) - Unable to parse (class ${class}_$device): ";
		print "\"$tc_output[$i + 1]\"\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 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
a7fb5630 MT	74	sub parse_class($) {
	75	my $device = "$_[0]";
	76	my $return_val = 1;
	77
	78	my $timestamp = time;
	79	my @tc_output = `$tc_command -statistics class show dev $device`;
	80	# my @tc_output = @input_hfsc;
	81	# my @tc_output = @input_htb;
	82	my $result = $?;
	83	if ( $result != 0 ) {
	84	print "Error executing $tc_command\n";
	85	return $result;
	86	}
	87
	88	$classes_data{last_update}{$device} = $timestamp;
	89	$classes_info{last_update}{$device} = $timestamp;
	90
	91	#for my $line (@tc_output) {
	92	for my $i (0 .. $#tc_output) {
	93
	94	my $line=$tc_output[$i];
	95	# Parsing HTB:
	96	# ------------
f1df2c41	97	if ( $line =~ m/class htb (\d+):(\d+)( root\| parent )?(\d+:\d+)?( leaf )?(\d+)?:?( prio )?(\d+)? rate (.) ceil (.) burst (.) cburst (.)/ ) {
a7fb5630 MT	98	my $type = "htb";
	99	my $major = $1;
	100	my $minor = $2;
	101	my $class = "${major}-${minor}";
	102	#my $hash = "${class}_${device}";
	103	my $parent= $4;
	104	my $leaf = $6;
	105	my $prio = $8;
	106	my $rate = $9;
	107	my $ceil = $10;
	108	my $burst = $11;
	109	my $cburst= $12;
	110
6f300951 MT	111	#print "class: $class\n"."parent: $parent\n"."leaf: $leaf\n"."prio: $prio\n";
6f300951 MT	112	#print "rate: $rate\n"."ceil: $ceil\n"."burst: $burst\n"."cburst: $cburst\n";
a7fb5630 MT	113
a7fb5630 MT	114	my ($bytes, $pkts, $dropped, $overlimits);
6f300951	115	if ($tc_output[$i + 1] =~ m/Sent (\d+) bytes (\d+) pkt \(dropped (\d+), overlimits (\d+) requeues (\d+)\)/ ) {
a7fb5630	116	$bytes = $1;
8b6a7fde	117	#print "bytes: $bytes\n";
a7fb5630	118	} else {
6f300951 MT	119	print "$timestamp: ERROR(+1) - Unable to parse (class ${class}_$device): ";
6f300951 MT	120	print "\"$tc_output[$i + 1]\"\n";
a7fb5630 MT	121	$return_val="";
a7fb5630 MT	122	next;
8b6a7fde	123	}
a7fb5630 MT	124
	125	# Update the hash tables
	126	my $hash="${class}_$device";
	127
	128	# Tests if previous data have been updated to file
	129	if ( (exists $classes_data{$hash}{last_update}) &&
	130	(exists $classes_data{$hash}{file_update})) {
	131	if ( $classes_data{$hash}{last_update} >
	132	$classes_data{$hash}{file_update} ){
	133	print "Warning: old data from $hash has not been updated to file!\n";
	134	}
	135	}
	136
	137	# Update the statistics data
	138	# (need a function call for error checking)
	139	$classes_data{$hash}{last_update} = $timestamp;
	140	update_counter( $hash, $timestamp, "bytes" , $bytes);
	141	#(yes I know its bad/redundant, but it makes in easier elsewhere)
a7fb5630 MT	142	#print "\n";
	143	}
	144
a7fb5630 MT	145	# Parsing XXX:
	146	# ------------
	147	if ( $line =~ m/class XXX/ ) {
	148	print "Matching class XXX\n";
	149	}
	150
	151	}
	152	return $return_val;
	153	}
	154
	155	# The main purpose of this function is to detect counter resets
	156	# and avoid parsing them on to RRDtool which interprets them
	157	# as counter overflows, thus updating with a very large number.
	158	sub update_counter ($$$$) {
	159	my $class_hash = "$_[0]";
	160	my $timestamp = "$_[1]";
	161	my $data_key = "$_[2]";
	162	my $new_value;
	163	if ( defined $_[3]) {
	164	$new_value = "$_[3]";
	165	}
	166	#
	167	my $max_allowed_wrap_increase = 100000000;
	168	my $old_value;
	169	if (exists $classes_data{$class_hash}{$data_key}) {
	170	$old_value = $classes_data{$class_hash}{$data_key};
	171	#print "old_value: $old_value\n";
	172	}
	173
	174	# # If the new and old value is not defined, nothing is done
	175	# if ((not defined $new_value) && (not defined $old_value)) {
	176	# return "";
	177	# }
	178
	179	# Argh... the tc program outputs in unsigned long long (64 bit).
	180	# but perls integers should be 32 bit, but some how perl
	181	# manages to store numbers larger than 32 bit numbers.
	182	my $MAX_VALUE=0xFFFFFFFF;
	183
	184	if ((defined $new_value) && (defined $old_value)) {
	185	my $delta = $new_value - $old_value;
	186	if ( $delta < 0 ) {
	187	# Counter wrap around...
	188	my $real_delta = $delta + $MAX_VALUE + 1;
	189	if ($real_delta < 0) {
	190	print "($class_hash:$data_key): Perl-Magic using numbers bigger than 32bit ";
	191	print "new:$new_value - old:$old_value = delta:$delta, real_delta:$real_delta.\n";
	192	}
	193	print time . " ($class_hash:$data_key) Info: Counter wrap around (real delta:$real_delta)\n";
	194	if ( ($real_delta > $max_allowed_wrap_increase) \|\|
	195	($real_delta < 0)) {
	196	# Properly a counter reset and not a wrap around
	197	# A counter reset normally a result of a reload of the classes
	198	$classes_data{$class_hash}{$data_key} = undef;
	199	$classes_info{$class_hash}{counter_reset} = $timestamp;
	200	$classes_info{$class_hash}{last_update} = $timestamp;
	201	print time . "Warning: Real_delta too big, assuming Counter reset";
	202	print "($class_hash:$data_key)\n";
	203	return "Counter reset";
	204	}
	205	}
	206	}
	207
	208	$classes_data{$class_hash}{$data_key} = $new_value;
209	return 1;
210	}
211
212	sub update_info ($$$$) {
213	my $class_hash = "$_[0]";
214	my $timestamp = "$_[1]";
215	my $info_key = "$_[2]";
216	my $new_value;
217	if ( defined $_[3]) {
218	$new_value = "$_[3]";
219	}
220	my $old_value;
221	if (exists $classes_info{$class_hash}{$info_key}) {
222	$old_value = $classes_info{$class_hash}{$info_key};
223	#print "old_value: $old_value\n";
224	}
225
226	# If the new and old value is not defined, nothing is done
227	if ((not defined $new_value) && (not defined $old_value)) {
228	return "";
229	}
230
231	# An update is needed
232	# - if the old_value is not defined and new_value is defined
233	# - if the new_value is not defined and old_value is defined
234	# - if the old_value differs from the new,
235	#
236	if ( ((not defined $old_value) and (defined $new_value)) \|\|
237	((not defined $new_value) and (defined $old_value)) \|\|
238	("$old_value" ne "$new_value")) {
239
240	# Special case: If the "type" changes the hash should be cleared
241	if ( "$info_key" eq "type") {
242	#print "Type has changed clearing hash \n";
243	for my $key ( keys %{ $classes_info{$class_hash} } ) {
244	delete( $classes_info{$class_hash}{$key});
245	print " Deleting key: $key from: $class_hash \n";
246	}
247	}
248
249	if (defined $new_value) {
250	$classes_info{$class_hash}{$info_key} = $new_value;
251	} else {
252	#print "New value undef -> Deleting key: $info_key from: $class_hash\n";
253	delete($classes_info{$class_hash}{$info_key});
254	}
255
256	# Mark the class for an info-file update
257	$classes_info{$class_hash}{last_update} = $timestamp;
258
259	# Update list/array of "changed" keys
260	push @{ $classes_info{$class_hash}{changed} }, $info_key;
261
262	# Print debug info
263	#print "Update class:$class_hash $info_key=";
264	#if (defined $new_value) {print "$new_value"};
265	#print "\n";
266	return 1;
267	}
268	return "";
269	}
270
271	# test
272	#parse_class(eth1);
273
274	#print Dumper(%classes_data);
275	#print Dumper(%classes_info);
276
277	return 1;