3 ##########################################
9 ## Which is part of the ADSL-optimizer.
21 ## Jesper Dangaard Brouer <hawk@diku.dk>, d.15/4-2004
24 ## 2004-04-15: Initial version.
25 ## 2005-04-18: Remove some warnings.
27 ## $Id: parse-func.pl,v 1.15 2005/04/18 12:37:17 hawk Exp $
28 ##########################################
34 #our $tc_command="/sbin/tc";
36 my @input_htb = (<<"END_OF_HERE_HTB" =~ m/^\s*(.+)/gm);
37 class tbf 4220:1 parent 4220:
38 class htb 1:1 root rate 400Kbit ceil 400Kbit burst 2111b cburst 2111b
39 Sent 12369084336 bytes 80967118 pkts (dropped 0, overlimits 0)
41 lended: 23353805 borrowed: 0 giants: 0
42 tokens: 30210 ctokens: 30210
44 class htb 1:10 parent 1:1 prio 0 rate 80Kbit ceil 320Kbit burst 1701b cburst 2008b
45 Sent 80640087 bytes 247988 pkts (dropped 0, overlimits 0)
47 lended: 230876 borrowed: 17112 giants: 0
48 tokens: 127200 ctokens: 37940
50 class htb 1:20 parent 1:1 leaf 4220: prio 1 rate 100Kbit ceil 200Kbit burst 1727b cburst 1855b
51 Sent 2495181573 bytes 44034303 pkts (dropped 5837, overlimits 0)
52 lended: 43825585 borrowed: 208718 giants: 0
53 tokens: 103424 ctokens: 55808
55 class htb 1:30 parent 1:1 leaf 4230: prio 3 rate 80Kbit ceil 400Kbit burst 1701b cburst 2111b
56 Sent 2060213567 bytes 5465574 pkts (dropped 121, overlimits 0)
58 lended: 4556992 borrowed: 908582 giants: 0
59 tokens: -25364 ctokens: 32897
61 class htb 1:50 parent 1:1 leaf 4250: prio 5 rate 40Kbit ceil 120Kbit burst 1650b cburst 1752b
62 Sent 6071486687 bytes 24448436 pkts (dropped 8086739, overlimits 0)
63 rate 15801bps 85pps backlog 126p
64 lended: 8324530 borrowed: 16123780 giants: 0
65 tokens: -202717 ctokens: -172499
67 class htb 1:666 parent 1:1 leaf 666: prio 7 rate 4Kbit ceil 40Kbit burst 1604b cburst 1650b
68 Sent 2148626078 bytes 6771069 pkts (dropped 2078536, overlimits 0)
69 rate 5221bps 17pps backlog 125p
70 lended: 675330 borrowed: 6095613 giants: 0
71 tokens: -1149121 ctokens: -293386
76 my @input_hfsc = (<<"END_OF_HERE_HFSC
" =~ m/^\s*(.+)/gm);
78 Sent 0 bytes 0 pkts (dropped 0, overlimits 0)
81 class hfsc 1:1 parent 1: ls m1 0bps d 0us m2 250Kbit ul m1 0bps d 0us m2 250Kbit
82 Sent 0 bytes 0 pkts (dropped 0, overlimits 0)
83 period 6 work 131770097 bytes level 1
85 class hfsc 1:10 parent 1:1 rt m1 250Kbit d 30.0ms m2 50Kbit ls m1 250Kbit d 50.0ms m2 50Kbit
86 Sent 1300885 bytes 7052 pkts (dropped 0, overlimits 0)
87 period 6502 work 1300885 bytes rtwork 1245495 bytes level 0
89 class hfsc 1:20 parent 1: rt m1 0bps d 64.0ms m2 75Kbit ls m1 0bps d 0us m2 250Kbit
90 Sent 19144279 bytes 325503 pkts (dropped 46, overlimits 0)
92 period 20242 work 19143778 bytes level 0
94 class hfsc 1:30 parent 1:1 leaf 4230: ls m1 0bps d 150.0ms m2 50Kbit
95 Sent 45139930 bytes 74200 pkts (dropped 1664, overlimits 0)
97 period 140 work 44885232 bytes level 0
99 class hfsc 1:50 parent 1:1 leaf 4250: ls m1 0bps d 235.7ms m2 72Kbit
100 Sent 73910198 bytes 301294 pkts (dropped 104807, overlimits 0)
102 period 115 work 64625490 bytes level 0
104 class hfsc 1:666 parent 1:1 leaf 666: ls m1 0bps d 1.0s m2 2Kbit
105 Sent 2217104 bytes 17018 pkts (dropped 74526, overlimits 0)
107 period 1 work 1814712 bytes level 0
112 my $device = "$_[0]";
115 my $timestamp = time;
116 my @tc_output = `$tc_command -statistics class show dev $device`;
117 # my @tc_output = @input_hfsc;
118 # my @tc_output = @input_htb;
120 if ( $result != 0 ) {
121 print "Error executing
$tc_command\n";
125 $classes_data{last_update}{$device} = $timestamp;
126 $classes_info{last_update}{$device} = $timestamp;
128 #for my $line (@tc_output) {
129 for my $i (0 .. $#tc_output) {
131 my $line=$tc_output[$i];
134 if ( $line =~ m/class htb (\d+):(\d+)( root| parent )?(\d+:\d+)?( leaf )?(\d+)?:?( prio )?(\d+)? rate (.*) ceil (.*) burst (.*) cburst (.*)/ ) {
138 my $class = "${major
}-${minor
}";
139 #my $hash = "${class}_
${device
}";
148 #print "class: $class\n"."parent
: $parent\n"."leaf
: $leaf\n"."prio
: $prio\n";
149 #print "rate
: $rate\n"."ceil
: $ceil\n"."burst
: $burst\n"."cburst
: $cburst\n";
151 my ($bytes, $pkts, $dropped, $overlimits);
152 if ($tc_output[$i + 1] =~ m/Sent (\d+) bytes (\d+) pkt \(dropped (\d+), overlimits (\d+) requeues (\d+)\)/ ) {
158 #print "bytes
: $bytes\n"."pkts
: $pkts\n";
159 #print "dropped
: $dropped\n"."overlimits
: $overlimits\n"."requeues
: $requeues\n";
161 print "$timestamp: ERROR
(+1) - Unable to parse
(class ${class}_
$device): ";
162 print "\"$tc_output[$i + 1]\"\n";
168 # Sometimes the "rate
" line is not shown (when a rate cannot be calculated)
169 # And sometimes only "backlog
"...
170 # Use $next_index to specify the next line to parse
174 if ($tc_output[$i + 2] =~ m/((rate (\d+\w+) )|backlog )(\d+)?(pps )?(backlog )?(\d+)?p?/ ) {
176 #print "backlog
: $backlog\n";
179 # print "$timestamp: WARNING
\"rate
\" line missing
";
180 # print " very inactive
class ${class}_
$device).\n";
184 my ($lended, $borrowed, $giants);
185 if ($tc_output[$i + $next_index] =~ m/lended: (\d+) borrowed: (\d+) giants: (\d+)/ ) {
189 #print "lended
: $lended\n"."borrowed
: $borrowed\n"."giants
: $giants\n";
191 print "$timestamp: ERROR
(+$next_index) - Unable to parse
(class ${class}_
$device): ";
192 print "\"$tc_output[$i + $next_index]\"\n";
197 # Update the hash tables
198 my $hash="${class}_
$device";
200 # Tests if previous data have been updated to file
201 if ( (exists $classes_data{$hash}{last_update}) &&
202 (exists $classes_data{$hash}{file_update})) {
203 if ( $classes_data{$hash}{last_update} >
204 $classes_data{$hash}{file_update} ){
205 print "Warning
: old data from
$hash has
not been updated to file
!\n";
209 # Update the statistics data
210 # (need a function call for error checking)
211 $classes_data{$hash}{last_update} = $timestamp;
212 update_counter( $hash, $timestamp, "bytes
" , $bytes);
213 #(yes I know its bad/redundant, but it makes in easier elsewhere)
214 update_counter( $hash, $timestamp, "bits
" , $bytes*8);
215 update_counter( $hash, $timestamp, "pkts
" , $pkts);
216 update_counter( $hash, $timestamp, "dropped
" , $dropped);
217 update_counter( $hash, $timestamp, "overlimits
", $overlimits);
218 update_counter( $hash, $timestamp, "lended
" , $lended);
219 update_counter( $hash, $timestamp, "borrowed
" , $borrowed);
220 update_counter( $hash, $timestamp, "giants
" , $giants);
221 # Not a counter value...
222 $classes_data{$hash}{backlog} = $backlog;
224 # Update the info data
225 # (remember to update the "type
" first)
226 update_info( $hash, $timestamp, "type
" , $type);
227 update_info( $hash, $timestamp, "parent
", $parent);
228 update_info( $hash, $timestamp, "leaf
" , $leaf);
229 update_info( $hash, $timestamp, "prio
" , $prio);
230 update_info( $hash, $timestamp, "rate
" , $rate);
231 update_info( $hash, $timestamp, "ceil
" , $ceil);
232 update_info( $hash, $timestamp, "burst
" , $burst);
233 update_info( $hash, $timestamp, "cburst
", $cburst);
240 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+?))? / ){
245 my $class = "${major
}-${minor
}";
246 #my $hash = "${class}_
${device
}";
250 my $realtime_m1; if (defined $8 && $8 ne '0bps') {$realtime_m1 = $8;}
251 my $realtime_d; if (defined $9 && $9 ne '0us' ) {$realtime_d = $9;}
252 my $realtime_m2 = $10;
254 my $linkshare_m1; if (defined $12 && $12 ne '0bps') { $linkshare_m1 = $12;}
255 my $linkshare_d ; if (defined $13 && $13 ne '0us' ) { $linkshare_d = $13;}
256 my $linkshare_m2 = $14;
258 my $upperlimit_m1; if (defined $16 && $16 ne '0bps') { $upperlimit_m1 = $16;}
259 my $upperlimit_d ; if (defined $17 && $17 ne '0us' ) { $upperlimit_d = $17;}
260 my $upperlimit_m2 = $18;
262 #print "\nType
: $type\n";
263 my ($bytes, $pkts, $dropped, $overlimits);
264 if ($tc_output[$i + 1] =~ m/Sent (\d+) bytes (\d+) pkts \(dropped (\d+), overlimits (\d+)\)/ ) {
269 #print "bytes
: $bytes\n"."pkts
: $pkts\n";
270 #print "dropped
: $dropped\n"."overlimits
: $overlimits\n";
272 print "$timestamp: ERROR
(+1) - Unable to parse
(class ${class}_
$device): ";
273 print "\"$tc_output[$i + 1]\"\n";
278 # Sometimes the "backlog
" line is not shown (when there is no backlog...)
279 # Use $next_index to specify the next line to parse
283 if ($tc_output[$i + 2] =~ m/backlog (\d+)?p?/ ) {
285 #print "backlog
: $backlog\n";
290 my ($period, $work, $rtwork, $level);
291 if ($tc_output[$i + $next_index] =~ m/period (\d+) (work (\d+) bytes )?(rtwork (\d+) bytes )?level (\d+)/ ) {
297 print "$timestamp: ERROR
(+$next_index) - Unable to parse
(class ${class}_
$device): ";
298 print "\"$tc_output[$i + $next_index]\"\n";
304 # Update the hash tables
305 my $hash="${class}_
$device";
307 # Tests if previous data have been updated to file
308 if ( (exists $classes_data{$hash}{last_update}) &&
309 (exists $classes_data{$hash}{file_update})) {
310 if ( $classes_data{$hash}{last_update} >
311 $classes_data{$hash}{file_update} ){
312 print "Warning
: old data from
$hash has
not been updated to file
!\n";
316 # HFSC - Update the statistics data
317 # (need a function call for error checking)
318 $classes_data{$hash}{last_update} = $timestamp;
319 update_counter( $hash, $timestamp, "bytes
" , $bytes);
320 #(yes I know its bad/redundant, but it makes in easier elsewhere)
321 update_counter( $hash, $timestamp, "bits
" , $bytes*8);
322 update_counter( $hash, $timestamp, "pkts
" , $pkts);
323 update_counter( $hash, $timestamp, "dropped
" , $dropped);
324 update_counter( $hash, $timestamp, "overlimits
", $overlimits);
325 # Not a counter value...
326 $classes_data{$hash}{backlog} = $backlog;
328 # Extra HFSC counters
329 $classes_data{$hash}{hfsc_period} = $period;
330 update_counter( $hash, $timestamp, "hfsc_work
" , $work);
331 update_counter( $hash, $timestamp, "hfsc_rtwork
" , $rtwork);
334 # HFSC - Update the info data
335 # (remember to update the "type
" first)
336 update_info( $hash, $timestamp, "type
" , $type);
337 update_info( $hash, $timestamp, "parent
", $parent);
338 update_info( $hash, $timestamp, "leaf
" , $leaf);
340 # Extra HFSC information
341 update_info( $hash, $timestamp, "level
" , $level);
342 update_info( $hash, $timestamp, "realtime_m1
", $realtime_m1);
343 update_info( $hash, $timestamp, "realtime_d
" , $realtime_d);
344 update_info( $hash, $timestamp, "realtime_m2
", $realtime_m2);
346 update_info( $hash, $timestamp, "linkshare_m1
", $linkshare_m1);
347 update_info( $hash, $timestamp, "linkshare_d
" , $linkshare_d);
348 update_info( $hash, $timestamp, "linkshare_m2
", $linkshare_m2);
350 update_info( $hash, $timestamp, "upperlimit_m1
", $upperlimit_m1);
351 update_info( $hash, $timestamp, "upperlimit_d
" , $upperlimit_d);
352 update_info( $hash, $timestamp, "upperlimit_m2
", $upperlimit_m2);
359 if ( $line =~ m/class XXX/ ) {
360 print "Matching
class XXX
\n";
367 # The main purpose of this function is to detect counter resets
368 # and avoid parsing them on to RRDtool which interprets them
369 # as counter overflows, thus updating with a very large number.
370 sub update_counter ($$$$) {
371 my $class_hash = "$_[0]";
372 my $timestamp = "$_[1]";
373 my $data_key = "$_[2]";
375 if ( defined $_[3]) {
376 $new_value = "$_[3]";
379 my $max_allowed_wrap_increase = 100000000;
381 if (exists $classes_data{$class_hash}{$data_key}) {
382 $old_value = $classes_data{$class_hash}{$data_key};
383 #print "old_value
: $old_value\n";
386 # # If the new and old value is not defined, nothing is done
387 # if ((not defined $new_value) && (not defined $old_value)) {
391 # Argh... the tc program outputs in unsigned long long (64 bit).
392 # but perls integers should be 32 bit, but some how perl
393 # manages to store numbers larger than 32 bit numbers.
394 my $MAX_VALUE=0xFFFFFFFF;
396 if ((defined $new_value) && (defined $old_value)) {
397 my $delta = $new_value - $old_value;
399 # Counter wrap around...
400 my $real_delta = $delta + $MAX_VALUE + 1;
401 if ($real_delta < 0) {
402 print "($class_hash:$data_key): Perl
-Magic using numbers bigger than
32bit
";
403 print "new
:$new_value - old
:$old_value = delta
:$delta, real_delta
:$real_delta.\n";
405 print time . " ($class_hash:$data_key) Info
: Counter wrap around
(real delta
:$real_delta)\n";
406 if ( ($real_delta > $max_allowed_wrap_increase) ||
408 # Properly a counter reset and not a wrap around
409 # A counter reset normally a result of a reload of the classes
410 $classes_data{$class_hash}{$data_key} = undef;
411 $classes_info{$class_hash}{counter_reset} = $timestamp;
412 $classes_info{$class_hash}{last_update} = $timestamp;
413 print time . "Warning
: Real_delta too big
, assuming Counter
reset";
414 print "($class_hash:$data_key)\n";
415 return "Counter
reset";
420 $classes_data{$class_hash}{$data_key} = $new_value;
424 sub update_info ($$$$) {
425 my $class_hash = "$_[0]";
426 my $timestamp = "$_[1]";
427 my $info_key = "$_[2]";
429 if ( defined $_[3]) {
430 $new_value = "$_[3]";
433 if (exists $classes_info{$class_hash}{$info_key}) {
434 $old_value = $classes_info{$class_hash}{$info_key};
435 #print "old_value
: $old_value\n";
438 # If the new and old value is not defined, nothing is done
439 if ((not defined $new_value) && (not defined $old_value)) {
443 # An update is needed
444 # - if the old_value is not defined and new_value is defined
445 # - if the new_value is not defined and old_value is defined
446 # - if the old_value differs from the new,
448 if ( ((not defined $old_value) and (defined $new_value)) ||
449 ((not defined $new_value) and (defined $old_value)) ||
450 ("$old_value" ne "$new_value")) {
452 # Special case: If the "type
" changes the hash should be cleared
453 if ( "$info_key" eq "type
") {
454 #print "Type has changed clearing hash
\n";
455 for my $key ( keys %{ $classes_info{$class_hash} } ) {
456 delete( $classes_info{$class_hash}{$key});
457 print " Deleting key
: $key from
: $class_hash \n";
461 if (defined $new_value) {
462 $classes_info{$class_hash}{$info_key} = $new_value;
464 #print "New value
undef -> Deleting key
: $info_key from
: $class_hash\n";
465 delete($classes_info{$class_hash}{$info_key});
468 # Mark the class for an info-file update
469 $classes_info{$class_hash}{last_update} = $timestamp;
471 # Update list/array of "changed
" keys
472 push @{ $classes_info{$class_hash}{changed} }, $info_key;
475 #print "Update
class:$class_hash $info_key=";
476 #if (defined $new_value) {print "$new_value"};
486 #print Dumper(%classes_data);
487 #print Dumper(%classes_info);