config/qos/parse-func.pl

   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 ##
  27 ## $Id: parse-func.pl,v 1.15 2005/04/18 12:37:17 hawk Exp $
  28 ##########################################
  29
  30 #use Data::Dumper;
  31
  32 #our %classes_data;
  33 #our %classes_info;
  34 #our $tc_command="/sbin/tc";
  35
  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)
  40  rate 45020bps 258pps
  41  lended: 23353805 borrowed: 0 giants: 0
  42  tokens: 30210 ctokens: 30210
  43
  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)
  46  backlog 42p
  47  lended: 230876 borrowed: 17112 giants: 0
  48  tokens: 127200 ctokens: 37940
  49
  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
  54
  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)
  57  rate 16851bps 35pps
  58  lended: 4556992 borrowed: 908582 giants: 0
  59  tokens: -25364 ctokens: 32897
  60
  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
  66
  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
  72
  73 END_OF_HERE_HTB
  74
  75
  76 my @input_hfsc = (<<"END_OF_HERE_HFSC" =~ m/^\s*(.+)/gm);
  77 class hfsc 1: root
  78  Sent 0 bytes 0 pkts (dropped 0, overlimits 0)
  79  period 0 level 2
  80
  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
  84
  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
  88
  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)
  91  backlog 3p
  92  period 20242 work 19143778 bytes level 0
  93
  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)
  96  backlog 24p
  97  period 140 work 44885232 bytes level 0
  98
  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)
 101  backlog 62p
 102  period 115 work 64625490 bytes level 0
 103
 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)
 106  backlog 22p
 107  period 1 work 1814712 bytes level 0
 108
 109 END_OF_HERE_HFSC
 110
 111 sub parse_class($) {
 112     my $device = "$_[0]";
 113     my $return_val = 1;
 114
 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;
 119     my $result = $?;
 120     if ( $result != 0 ) {
 121         print "Error executing $tc_command\n";
 122         return $result;
 123     }
 124
 125     $classes_data{last_update}{$device} = $timestamp;
 126     $classes_info{last_update}{$device} = $timestamp;
 127
 128     #for my $line (@tc_output) {
 129     for my $i (0 .. $#tc_output) {
 130
 131         my $line=$tc_output[$i];
 132         # Parsing HTB:
 133         # ------------
 134         if ( $line =~ m/class htb (\d+):(\d+)( root| parent )?(\d+:\d+)?( leaf )?(\d+)?:?( prio )?(\d+)? rate (.*) ceil (.*) burst (.*) cburst (.*)/ ) {
 135             my $type  = "htb";
 136             my $major = $1;
 137             my $minor = $2;
 138             my $class = "${major}-${minor}";
 139             #my $hash  = "${class}_${device}";
 140             my $parent= $4;
 141             my $leaf  = $6;
 142             my $prio  = $8;
 143             my $rate  = $9;
 144             my $ceil  = $10;
 145             my $burst = $11;
 146             my $cburst= $12;
 147
 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";
 150
 151             my ($bytes, $pkts, $dropped, $overlimits);
 152             if ($tc_output[$i + 1] =~ m/Sent (\d+) bytes (\d+) pkt \(dropped (\d+), overlimits (\d+) requeues (\d+)\)/ ) {
 153                 $bytes      = $1;
 154                 $pkts       = $2;
 155                 $dropped    = $3;
 156                 $overlimits = $4;
 157                 $requeues   = $5;
 158                 #print "bytes: $bytes\n"."pkts: $pkts\n";
 159                 #print "dropped: $dropped\n"."overlimits: $overlimits\n"."requeues: $requeues\n";
 160             } else {
 161                 print "$timestamp: ERROR(+1) - Unable to parse (class ${class}_$device): ";
 162                 print "\"$tc_output[$i + 1]\"\n";
 163                 $return_val="";
 164                 next;
 165             }
 166
 167             # Problem:
 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
 171             #
 172             my $next_index = 3;
 173             my ($backlog);
 174             if ($tc_output[$i + 2] =~ m/((rate (\d+\w+) )|backlog )(\d+)?(pps )?(backlog )?(\d+)?p?/ ) {
 175                 $backlog = $7;
 176                 #print "backlog: $backlog\n";
 177             } else {
 178 # Too verbose:
 179 #               print "$timestamp: WARNING \"rate\" line missing";
 180 #               print " very inactive class ${class}_$device).\n";
 181                 $next_index = 2;
 182             }
 183
 184             my ($lended, $borrowed, $giants);
 185             if ($tc_output[$i + $next_index] =~ m/lended: (\d+) borrowed: (\d+) giants: (\d+)/ ) {
 186                 $lended   = $1;
 187                 $borrowed = $2;
 188                 $giants   = $3;
 189                 #print "lended: $lended\n"."borrowed: $borrowed\n"."giants: $giants\n";
 190             } else {
 191                 print "$timestamp: ERROR(+$next_index) - Unable to parse (class ${class}_$device): ";
 192                 print "\"$tc_output[$i + $next_index]\"\n";
 193                 $return_val="";
 194                 next;
 195             }
 196
 197             # Update the hash tables
 198             my $hash="${class}_$device";
 199
 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";
 206                 }
 207             }
 208
 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;
 223
 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);
 234
 235             #print "\n";
 236         }
 237
 238         # Parsing HFSC:
 239         # -------------
 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+?))? / ){
 241
 242             my $type  = "hfsc";
 243             my $major = $1;
 244             my $minor = $2;
 245             my $class = "${major}-${minor}";
 246             #my $hash  = "${class}_${device}";
 247             my $parent= $4;
 248             my $leaf  = $6;
 249
 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;
 253
 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;
 257
 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;
 261
 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+)\)/ ) {
 265                 $bytes      = $1;
 266                 $pkts       = $2;
 267                 $dropped    = $3;
 268                 $overlimits = $4;
 269                 #print "bytes: $bytes\n"."pkts: $pkts\n";
 270                 #print "dropped: $dropped\n"."overlimits: $overlimits\n";
 271             } else {
 272                 print "$timestamp: ERROR(+1) - Unable to parse (class ${class}_$device): ";
 273                 print "\"$tc_output[$i + 1]\"\n";
 274                 $return_val="";
 275                 next;
 276             }
 277
 278             # Sometimes the "backlog" line is not shown (when there is no backlog...)
 279             # Use $next_index to specify the next line to parse
 280             #
 281             my $next_index = 3;
 282             my ($backlog);
 283             if ($tc_output[$i + 2] =~ m/backlog (\d+)?p?/ ) {
 284                 $backlog = $1;
 285                 #print "backlog: $backlog\n";
 286             } else {
 287                 $next_index = 2;
 288             }
 289
 290             my ($period, $work, $rtwork, $level);
 291             if ($tc_output[$i + $next_index] =~ m/period (\d+) (work (\d+) bytes )?(rtwork (\d+) bytes )?level (\d+)/ ) {
 292                 $period = $1;
 293                 $work   = $3;
 294                 $rtwork = $5;
 295                 $level  = $6
 296             } else {
 297                 print "$timestamp: ERROR(+$next_index) - Unable to parse (class ${class}_$device): ";
 298                 print "\"$tc_output[$i + $next_index]\"\n";
 299                 $return_val="";
 300                 next;
 301             }
 302
 303
 304             # Update the hash tables
 305             my $hash="${class}_$device";
 306
 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";
 313                 }
 314             }
 315
 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;
 327             #
 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);
 332
 333
 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);
 339             #
 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);
 345
 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);
 349
 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);
 353
 354
 355         }
 356
 357         # Parsing XXX:
 358         # ------------
 359         if ( $line =~ m/class XXX/ ) {
 360             print "Matching class XXX\n";
 361         }
 362
 363     }
 364     return $return_val;
 365 }
 366
 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]";
 374     my $new_value;
 375     if ( defined $_[3]) {
 376         $new_value = "$_[3]";
 377     }
 378     #
 379     my $max_allowed_wrap_increase = 100000000;
 380     my $old_value;
 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";
 384     }
 385
 386 #    # If the new and old value is not defined, nothing is done
 387 #    if ((not defined $new_value) && (not defined $old_value)) {
 388 #       return "";
 389 #    }
 390
 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;
 395
 396     if ((defined $new_value) && (defined $old_value)) {
 397         my $delta = $new_value - $old_value;
 398         if ( $delta < 0 ) {
 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";
 404             }
 405             print time . " ($class_hash:$data_key) Info: Counter wrap around (real delta:$real_delta)\n";
 406             if ( ($real_delta > $max_allowed_wrap_increase) ||
 407                  ($real_delta < 0)) {
 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";
 416             }
 417         }
 418     }
 419
 420     $classes_data{$class_hash}{$data_key} = $new_value;
 421     return 1;
 422 }
 423
 424 sub update_info ($$$$) {
 425     my $class_hash = "$_[0]";
 426     my $timestamp  = "$_[1]";
 427     my $info_key   = "$_[2]";
 428     my $new_value;
 429     if ( defined $_[3]) {
 430         $new_value = "$_[3]";
 431     }
 432     my $old_value;
 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";
 436     }
 437
 438     # If the new and old value is not defined, nothing is done
 439     if ((not defined $new_value) && (not defined $old_value)) {
 440         return "";
 441     }
 442
 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,
 447     #
 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")) {
 451
 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";
 458             }
 459         }
 460
 461         if (defined $new_value) {
 462             $classes_info{$class_hash}{$info_key} = $new_value;
 463         } else {
 464             #print "New value undef -> Deleting key: $info_key from: $class_hash\n";
 465             delete($classes_info{$class_hash}{$info_key});
 466         }
 467
 468         # Mark the class for an info-file update
 469         $classes_info{$class_hash}{last_update} = $timestamp;
 470
 471         # Update list/array of "changed" keys
 472         push @{ $classes_info{$class_hash}{changed} }, $info_key;
 473
 474         # Print debug info
 475         #print "Update class:$class_hash $info_key=";
 476         #if (defined $new_value) {print "$new_value"};
 477         #print "\n";
 478         return 1;
 479     }
 480     return "";
 481 }
 482
 483 # test
 484 #parse_class(eth1);
 485
 486 #print Dumper(%classes_data);
 487 #print Dumper(%classes_info);
 488
 489 return 1;