]>
git.ipfire.org Git - people/pmueller/ipfire-2.x.git/blob - config/qos/parse-func.pl
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 ##########################################
33 #our $tc_command="/sbin/tc";
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)
40 lended: 23353805 borrowed: 0 giants: 0
41 tokens: 30210 ctokens: 30210
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)
46 lended: 230876 borrowed: 17112 giants: 0
47 tokens: 127200 ctokens: 37940
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
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)
57 lended: 4556992 borrowed: 908582 giants: 0
58 tokens: -25364 ctokens: 32897
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
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
79 my @tc_output = `$tc_command -statistics class show dev $device`;
80 # my @tc_output = @input_hfsc;
81 # my @tc_output = @input_htb;
84 print "Error executing $tc_command\n";
88 $classes_data{last_update}{$device} = $timestamp;
89 $classes_info{last_update}{$device} = $timestamp;
91 #for my $line (@tc_output) {
92 for my $i (0 .. $#tc_output) {
94 my $line=$tc_output[$i];
97 if ( $line =~ m/class htb (\d+):(\d+)( root| parent )?(\d+:\d+)?( leaf )?(\d+)?:?( prio )?(\d+)? rate (.*) ceil (.*) burst (.*) cburst (.*)/ ) {
101 my $class = "${major}-${minor}";
102 #my $hash = "${class}_${device}";
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";
114 my ($bytes, $pkts, $dropped, $overlimits);
115 if ($tc_output[$i + 1] =~ m/Sent (\d+) bytes (\d+) pkt \(dropped (\d+), overlimits (\d+) requeues (\d+)\)/ ) {
117 #print "bytes: $bytes\n";
119 print "$timestamp: ERROR(+1) - Unable to parse (class ${class}_$device): ";
120 print "\"$tc_output[$i + 1]\"\n";
125 # Update the hash tables
126 my $hash="${class}_$device";
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";
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)
147 if ( $line =~ m/class XXX/ ) {
148 print "Matching class XXX\n";
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]";
163 if ( defined $_[3]) {
164 $new_value = "$_[3]";
167 my $max_allowed_wrap_increase = 100000000;
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";
174 # # If the new and old value is not defined, nothing is done
175 # if ((not defined $new_value) && (not defined $old_value)) {
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;
184 if ((defined $new_value) && (defined $old_value)) {
185 my $delta = $new_value - $old_value;
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";
193 print time . " ($class_hash:$data_key) Info: Counter wrap around (real delta:$real_delta)\n";
194 if ( ($real_delta > $max_allowed_wrap_increase) ||
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";
208 $classes_data{$class_hash}{$data_key} = $new_value;
212 sub update_info ($$$$) {
213 my $class_hash = "$_[0]";
214 my $timestamp = "$_[1]";
215 my $info_key = "$_[2]";
217 if ( defined $_[3]) {
218 $new_value = "$_[3]";
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";
226 # If the new and old value is not defined, nothing is done
227 if ((not defined $new_value) && (not defined $old_value)) {
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,
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")) {
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";
249 if (defined $new_value) {
250 $classes_info{$class_hash}{$info_key} = $new_value;
252 #print "New value undef -> Deleting key: $info_key from: $class_hash\n";
253 delete($classes_info{$class_hash}{$info_key});
256 # Mark the class for an info-file update
257 $classes_info{$class_hash}{last_update} = $timestamp;
259 # Update list/array of "changed" keys
260 push @{ $classes_info{$class_hash}{changed} }, $info_key;
263 #print "Update class:$class_hash $info_key=";
264 #if (defined $new_value) {print "$new_value"};
274 #print Dumper(%classes_data);
275 #print Dumper(%classes_info);