#!/usr/bin/perl
$dot_file = "/second/www/temp/monitor.dot" ;
$gif_file = "/second/www/temp/qos.png" ;

$TC="tc" ;
$DEV = "dev eth0" ;

# %child  : $child{$parent} = $child1; child2; child3
# %rate   : $rate{$} = rate
# %option : $option{$parent} = options
# %filter : $filter{$parent $child} = filter1;filter2;filter3
# %type   : $type{$parent $child} = filter
# %color  : $color{$parent $child} = color of filter

# Get classes and qdiscs
@qdisc = `$TC qdisc show $DEV` ;
@class = `$TC class show $DEV` ;

#foreach $qdisc  (@qdisc)  { print "qdisc:  $qdisc"  ; }
#foreach $class  (@class)  { print "class:  $class"  ; }

set_colors () ;
process_qdisc () ;		# Find TBF and SFQ qdiscs
process_class () ;
find_root_qdisc () ;
process () ;
system ("dot $dot_file -Tpng -o $gif_file") ;
#$PNG = system ("dot $dot_file -Tpng") ;
#print "$PNG\n" ;

#print_childs () ; 		# DEBUG : print childs and filters

# note : rate of cbq qdisc is extract from root class
#          and options are allways "(bounded,isolated) prio no-transmit"
# Root_qdiscs used so when there is one qdisc, root_qdisc is allready initialised
sub process_qdisc () {
   foreach $qdisc (@qdisc) {
      chomp ($qdisc) ;
      @split = split (" ",$qdisc) ;
      $root_qdisc = $split[2] ;
      if ( $split[1] eq "cbq" ) { next ; 
      } elsif ( $split[1] eq "sfq" ) {
         $child{$root_qdisc} = "SFQ" ;
      } elsif ( $split[1] eq "tbf" ) {
         $child{$root_qdisc} = "TBF" ;
         $rate{$root_qdisc} = $split[4] ;
         shift (@split) ; 
         shift (@split) ; 
      }
      shift (@split) ; 
      shift (@split) ; 
      shift (@split) ; 
      $option{$root_qdisc} = join (" ", @split) ;
   }
}

# Takes one argument and use this as the parent to find all the filters
sub find_filter {
   my $parent = $_[0] ;
   $/ = "filter" ;
   @filter = `$TC filter show $DEV parent $parent` ;
   $/ = "\n" ;

   foreach $filter (@filter) {
      my @split = split " ", $filter ;
      if ( $split[4] eq "fw" ) {
         if ( $#split == "5" ) { next ; }
         my $key = $parent . " " . $split[8] ;
         shift (@split) ;
         $#split -- ; $#split -- ;
         if ( $split[5] eq "0x1" ) {
            $color{$key} = "yellow" . "\;" . $color{$key} ;
         } elsif ( $split[5] eq "0x2" ) {
            $color{$key} = "green" . "\;" . $color{$key} ;
         } else {
            $color{$key} = "blue" . "\;" . $color{$key} ;
         }

         $filter{$key} = $split[5]."\;".$filter{$key};
         $type{$key} = "fw" ;
      }
      elsif ( $split[4] eq "u32" ) {
         if ( $#split < "11" ) { next ; }
         my $key = $parent . " " . $split[15] ;
         $filter{$key} = $split[6] . "\;" . $filter{$key};
         @split = split "\n", $filter ;
         shift (@split) ;
         $option{$key} = join ("\n", @split) ;
         $option{$key} =~ s/\nfilter// ;
         $color{$key} = "black" ;
         $type{$key} = "u32" ;
      }
   }
}

sub process_class {
   foreach $class (@class) {
      chomp ($class) ;
      @split = split (" ",$class) ;
      shift (@split) ;
      shift (@split) ;
      my $name = shift (@split) ;
      if ( $split[0] eq "root" ) { # root class = CBQ root qdisc
# class cbq 20: root rate 1112Kbit (bounded,isolated) prio no-transmit
#               0    1    2        3                  4    5
         shift (@split) ;
         shift (@split) ;
         $rate{$name} = shift (@split) ;
         $root_qdisc = $name ;
      } else {
         shift (@split) ;
         my $parent = shift (@split) ;
   
         if ( $split[0] eq "leaf" ) {
            $child{$name} = $split[1] . " " . $child{$name};
            shift (@split) ; shift (@split) ; 
         }
# class cbq 10:1 parent 10:2 leaf 20: rate 832Kbit (bounded) prio 3
#                            0    1   2    3       4         5    6
# class cbq 10:2 parent 10:           rate 1112Kbit (bounded,isolated) prio 3
#                                     0    1        2                  3    4
         $child{$parent} = $name . " " . $child{$parent} ;
         shift (@split) ;
         $rate{$name} = shift (@split) ;
         if ( ($split[0] =~ /bounded/) or ($split[0] =~ /isolated/) ) {
            $split[0] =~ s/^\(// ;
            $split[0] =~ s/\)$// ;
            $option{$name} = shift (@split) ; }
         $option{$name} = $option{$name} . " " . ( join " ", @split ) ;
      }
   }
}

# Find root qdisc
sub find_root_qdisc {
   foreach $parent (keys(%child)) {
      $root_qdisc = $parent if ( ! $child{$parent} ) ; # The root qdisc is never a child
   }
}

sub process {
  open (OUT, ">$dot_file") ;
  print OUT "digraph QOS {\n" ;
  #print OUT "    rankdir=LR\n" ;
  print OUT "    ratio=compress\n" ;
  print OUT "    node [style=filled]\n" ;
  if ($#qdisc eq "-1" ) { 
    print OUT "    \"NO\" \[color=red\]\n" ;
    print OUT "    \"NO\" \[label=\"NO QOS\"\]\n" ;
  } elsif ( $child{$root_qdisc} eq "TBF" ) {
    print OUT "    \"$root_qdisc\" \[color=red\]\n" ;
    print OUT "    \"$root_qdisc\" \[label=\"TBF Root Qdisc $root_qdisc\\nRate $rate{$root_qdisc}\"\]\n" ;
  } elsif ( $child{$root_qdisc} eq "SFQ" ) {
    print OUT "    \"$root_qdisc\" \[color=red\]\n" ;
    print OUT "    \"$root_qdisc\" \[label=\"SFQ Root Qdisc $root_qdisc\"\]\n" ;
  } else {
    print OUT "    \"$root_qdisc\" \[color=red\]\n" ;
    print OUT "    \"$root_qdisc\" \[label=\"CBQ Root Qdisc $root_qdisc\\nRate $rate{$root_qdisc}\"\]\n" ;
  #######3print_root_qdisc () ;
    foreach $parent (keys(%child)) {
      find_filter ($parent) ;
      my @child = split (" ",$child{$parent}) ;
      foreach my $child (@child) {
        $child =~ s/\s// ;
        if ( $child{$child} eq "TBF") { # For TBF and SFQ, we skip a child
          print OUT "       edge \[color=\"black\",label=\" \"\]\n" ;
          print OUT "    \"$parent\" -> \"$child\"\n" ;
          print OUT "       \"$child\" \[label=\"TBF Qdisc $child\\n$rate{$child}\"\]\n" ;
          print OUT "       \"$child\" \[fontcolor=red\]\n" ;
        } elsif ( $child{$child} eq "SFQ") {
          print OUT "       edge \[color=\"black\",label=\" \"\]\n" ;
          print OUT "    \"$parent\" -> \"$child\"\n" ;
          print OUT "       \"$child\" \[label=\"SFQ Qdisc $child\"\]\n" ;
          print OUT "       \"$child\" \[fontcolor=red\]\n" ;
        } else { 
          if ( ( $child eq "SFQ" ) or ( $child eq "TBF" ) ) { next ; }
# Rest must be CBQ
   
          my $color = "black" ;
          if ( $child =~ /\:$/ ) { # If CBQ Qdisc ...
            print OUT "    \"$child\" \[fontcolor=red\]\n" ;
            print OUT "    \"$child\" \[label=\"Qdisc $child\\n" ;
          } else { # If CBQ Class ...
            print OUT "    \"$child\" \[label=\"Class $child\\n" ;
            print OUT "Options : $option{$child}\\n" ;
          }
          print OUT "Rate : $rate{$child}\"\]\n" ;

          if ( $type{($parent." ".$child)} ) { # If there is a filter ...
            delete $type { ($parent." ".$child) } ;
            @filter_split = split (";",$filter{($parent." ".$child)}) ;

            my $temp = "0" ;
            foreach $filter_split (@filter_split) {
              $color = (split (";",$color{($parent." ".$child)}))[$temp];
              $temp ++ ;
              print OUT "     edge \[color=\"$color\",label=\"$filter_split\"\]\n" ;
              $child{$child} =~ s/\s// ;
              if ( $child{$child} =~ /\:$/ ) { # If child of child = qdisc, filter direct to qdisc
                print OUT "    \"$parent\" -> \"$child{$child}\"\n" ;
                $qdisc_child = "1" ;
              } else {
                print OUT "    \"$parent\" -> \"$child\"\n" ;
                undef $qdisc_child ;
              }
            }

            if ( $qdisc_child ) { # If child=qdisc, draw 1 line to qdisc
              print OUT "     edge \[color=\"black\",label=\" \"\]\n" ;
              print OUT "    \"$parent\" -> \"$child\"\n" ;
            }

          } else { # If there is no filter ...
            print OUT "       edge \[color=\"black\",label=\" \"\]\n" ;
            print OUT "    \"$parent\" -> \"$child\"\n" ;
          }
        }
      }
    }
  }
  process_filter () ; # Find filter not yet found
  print OUT "}\n" ;
  close OUT ;
}

sub process_filter {
   foreach my $type (keys(%type)) {
      (my $parent,my $child) = split (" ",$type) ;
      @filter_split = split (";",$filter{($parent." ".$child)}) ;

      foreach $filter_split (@filter_split) {
        if ( $child{$child} =~ /\:\s$/ ) {
          $filter_child = $child{$child} ;
        } else {
          $filter_child = $child ;
        } 
        $filter_child =~ s/ // ;
        $color = $color {($parent." ".$child)} ;
        print OUT "     edge \[color=\"$color\",label=\"$filter_split\"\]\n" ;
        print OUT "    \"$parent\" -> \"$filter_child\"\n" ;
      }
   }
}

###sub print_root_qdisc {
#   if ($#qdisc eq "-1" ) { 
#      print "$rood NO QOS\n" ;
#      print "$reset\n" ;
#   } elsif ( $child{$root_qdisc} eq "TBF" ) {
#      print "\n$rood TBF root qdisc : $root_qdisc" ;
#      print "$groen Rate : $rate{$root_qdisc}" ;
#      print "$groen Options : $option{$root_qdisc}" ;
#      print "$reset\n" ;
#   } elsif ( $child{$root_qdisc} eq "SFQ" ) {
#      print "\n$rood SFQ root qdisc : $root_qdisc" ;
#      print "$groen Options : $option{$root_qdisc}" ;
#      print "$reset\n" ;
#   } else {
#      $i = 0 ;
#      $j = 0 ;
#      print "$rood CBQ root qdisc : $root_qdisc" ;
#      print "$groen Rate : $rate{$root_qdisc}" ;
#      get_child ($root_qdisc) ;
#      print "$reset\n" ;
#   }
#}
#
#sub get_child {
#   $j ++ ;
#   my $parent = @_[0] ;
#   #print "\n" ;
#   #print " " x $j x 4 ;
#   #print "$rood CBQ : $parent" ;
#   #print " $groen BandWidth : $BW{$parent}" if $BW{$parent} ;
#
#   @child = sort (split (" ", $child{$parent})) ;
#
#   foreach my $child (@child) {
#      $i ++ ;
#      $backup[$i] = join (" ", @child)  ;
##print "\nBackup $i @child\n" ;
#      $child =~ s/ //;
#
#      if ( $child =~ /:$/ ) { 
#         print "\n" ;
#         print " " x ( $j -1 ) x 4 ;
#         if ( $child{$child}  eq "SFQ" ) { 
#            print "$rood SFQ Qdisc" ;
#            print "$groen Options : $option{$child}" if $option{$child} ;
#         } elsif ( $child{$child}  eq "TBF" ) {
#            print "$rood TBF Qdisc" ;
#            print "$groen Rate : $rate{$child}" if $rate{$child} ;
#            print "$groen Options : $option{$child}" if $option{$child} ;
#         } else {
#            print "$rood Qdisc : $child" ;
#            print "$groen Rate : $rate{$child}" if $rate{$child} ;
#         }
#      } else {
#         print "\n" ;
#         print " " x $j x 4 ;
#         print "$blauw Class : $child" ;
#         print "$groen Rate : $rate{$child}" if $rate{$child} ;
#         print "$groen Options : $option{$child}" if $option{$child} ;
#         get_child ($child) ;
#      }
#      @child = split (" ", $backup[$i]) ;
##print "\nrestore $i @child\n" ;
#      $i -- ;
#   }
#   $j -- ;
#}

sub print_childs {
  foreach $filter (keys(%filter)) {
    @split = split ("\;", $filter{$filter}) ;
    foreach $split (@split) {
      print "$filter Filter parent : $split, value : $filter{$split}\n" ;
    }
  }
  foreach $key (keys(%child)) {
    print "$reset Childs value : $key, child : $child{$key}, Rate : $rate{$key}\n" ;
   }
}

sub set_colors {
  $reset    = "\033[00m"  ;
  $zwart    = "\033[30m" ;
  $rood     = "\033[31m" ;
  $groen    = "\033[32m" ;
  $bruin    = "\033[33m" ;
  $blauw    = "\033[34m" ;
  $paars    = "\033[35m" ;
  $cyan     = "\033[36m" ;
  $wit      = "\033[37m" ;
  $clear    = `clear` ;
 
#print "$zwart zwart ##++**\n" ;
#print "$rood rood ##++**\n" ;
#print "$groen groen ##++**\n" ;
#print "$bruin bruin ##++**\n" ;
#print "$blauw blauw ##++**\n" ;
#print "$magneta magneta ##++**\n" ;
#print "$paars paars  ##++**\n" ;
#print "$cyan cyan  ##++**\n" ;
#print "$wit wit ##++**\n" ;
#print "$reset reset ##++**\n" ;
 
  $color[0] = $rood ;
  $color[1] = $groen ;
  $color[2] = $blauw ;
  $color[3] = $paars ;
  $color[4] = $cyan ;
  $color[5] = $geel ;
}