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 ##########################################
  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 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         # ------------
  97         if ( $line =~ m/class htb (\d+):(\d+)( root| parent )?(\d+:\d+)?( leaf )?(\d+)?:?( prio )?(\d+)? rate (.*) ceil (.*) burst (.*) cburst (.*)/ ) {
  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
 111             #print "class: $class\n"."parent: $parent\n"."leaf: $leaf\n"."prio: $prio\n";
 112             #print "rate: $rate\n"."ceil: $ceil\n"."burst: $burst\n"."cburst: $cburst\n";
 113
 114             my ($bytes, $pkts, $dropped, $overlimits);
 115             if ($tc_output[$i + 1] =~ m/Sent (\d+) bytes (\d+) pkt \(dropped (\d+), overlimits (\d+) requeues (\d+)\)/ ) {
 116                 $bytes      = $1;
 117         #print "bytes: $bytes\n";
 118             } else {
 119                 print "$timestamp: ERROR(+1) - Unable to parse (class ${class}_$device): ";
 120                 print "\"$tc_output[$i + 1]\"\n";
 121                 $return_val="";
 122                 next;
 123             }
 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)
 142             #print "\n";
 143         }
 144
 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;