2019-fosdem/nbdview/nbdcanvas.tcl

   1 #!/usr/bin/env wish
   2 # Visualize nbdkit activity - read the README file first!
   3 # Copyright (C) 2018 Red Hat Inc.
   4 # All rights reserved.
   5 #
   6 # Redistribution and use in source and binary forms, with or without
   7 # modification, are permitted provided that the following conditions are
   8 # met:
   9 #
  10 # * Redistributions of source code must retain the above copyright
  11 # notice, this list of conditions and the following disclaimer.
  12 #
  13 # * Redistributions in binary form must reproduce the above copyright
  14 # notice, this list of conditions and the following disclaimer in the
  15 # documentation and/or other materials provided with the distribution.
  16 #
  17 # * Neither the name of Red Hat nor the names of its contributors may be
  18 # used to endorse or promote products derived from this software without
  19 # specific prior written permission.
  20 #
  21 # THIS SOFTWARE IS PROVIDED BY RED HAT AND CONTRIBUTORS ''AS IS'' AND
  22 # ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
  23 # THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
  24 # PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL RED HAT OR
  25 # CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
  26 # SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
  27 # LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
  28 # USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
  29 # ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
  30 # OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT
  31 # OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
  32 # SUCH DAMAGE.
  33
  34 package require Tk
  35
  36 # Create an nbdcanvas object.
  37 #
  38 # canvas: canvas object name which is created (eg. ".c")
  39 # logfile: log file to monitor
  40 # size: size in bytes of the underlying disk
  41 # blocksize: size in bytes of the block corresponding to each pixel
  42 # width: width of the canvas (height is determined from size & blocksize)
  43 # scale: each pixel is scaled by this amount
  44 #
  45 # Returns an opaque handle which should be passed to nbdpoll.
  46 proc nbdcanvas { canvas logfile size blocksize width scale } {
  47     canvas $canvas -bg white
  48     set height [expr {$size / $blocksize / $width}]
  49
  50     # Because Tk's canvas cannot scale images, we use a very
  51     # inefficient double buffering here where we have $img which
  52     # contains the raw data but is not displayed, and $dispimg which
  53     # is the displayed image which is copied/zoomed from $img whenever
  54     # $img changes.
  55     set img [image create photo -width $width -height $height]
  56     $img put "white" -to 0 0 $width $height
  57     set dispimg [image create photo -width [expr {$width*$scale}] \
  58                      -height [expr {$height*$scale}]]
  59     $canvas create image 0 0 -anchor nw -image $dispimg
  60
  61     # Open the log file.
  62     set fp [open $logfile "r"]
  63
  64     set h [dict create \
  65                logfile $logfile \
  66                size $size \
  67                blocksize $blocksize \
  68                width $width \
  69                height $height \
  70                scale $scale \
  71                img $img \
  72                dispimg $dispimg \
  73                fp $fp]
  74     return $h
  75 }
  76
  77 # Return the computed height of the image in pixels.
  78 proc nbdheight { h } {
  79     return [dict get $h height]
  80 }
  81
  82 # Blit $img to $dispimg, with scaling.
  83 proc update_dispimg { h } {
  84     set img [dict get $h img]
  85     set dispimg [dict get $h dispimg]
  86     set width [dict get $h width]
  87     set height [dict get $h height]
  88     set scale [dict get $h scale]
  89     $dispimg copy $img -zoom $scale $scale
  90 }
  91
  92 # Handle a read.
  93 # This flashes the pixels, but restores their previous value.
  94 proc handle_read { h offset count } {
  95     set blocksize [dict get $h blocksize]
  96     set width [dict get $h width]
  97     set img [dict get $h img]
  98
  99     while { $count > 0 } {
 100         set lba [expr {$offset/$blocksize}]
 101         set x [expr {$lba % $width}]
 102         set y [expr {$lba / $width}]
 103
 104         set oldcol [$img get $x $y]
 105         set oldcol [format "#%02x%02x%02x" \
 106                         [lindex $oldcol 0] \
 107                         [lindex $oldcol 1] \
 108                         [lindex $oldcol 2]]
 109         # Flash the pixel to black.
 110         $img put "black" -to $x $y [expr {$x+1}] [expr {$y+1}]
 111         update_dispimg $h
 112         update
 113         # Restore old colour.
 114         $img put $oldcol -to $x $y [expr {$x+1}] [expr {$y+1}]
 115         update_dispimg $h
 116
 117         incr offset $blocksize
 118         incr count [expr {-$blocksize}]
 119     }
 120 }
 121
 122 # Operation colours.
 123 array set colours {
 124     # write => red
 125     w "#ff0000"
 126     # trim => grey
 127     t "#e0e0e0"
 128     # zero => white
 129     z "#ffffff"
 130 }
 131
 132 # Handle an operation.
 133 #
 134 # h: handle
 135 # op: operation, "w"-rite, "t"-rim, "z"-ero
 136 # offset, count: in bytes
 137 proc handle_op { h op offset count } {
 138     global colours
 139
 140     set blocksize [dict get $h blocksize]
 141     set width [dict get $h width]
 142     set img [dict get $h img]
 143
 144     # Choose a colour based on the operation.
 145     set col $colours($op)
 146
 147     while { $count > 0 } {
 148         set lba [expr {$offset/$blocksize}]
 149         set x [expr {$lba % $width}]
 150         set y [expr {$lba / $width}]
 151
 152         # Set the pixel at (x, y) to col.
 153         $img put $col -to $x $y [expr {$x+1}] [expr {$y+1}]
 154
 155         incr offset $blocksize
 156         incr count [expr {-$blocksize}]
 157     }
 158     update_dispimg $h
 159 }
 160
 161 # Handle a single line from the log file.
 162 proc handle { h line } {
 163     if { [ regexp {\mRead.*offset=(0x[[:xdigit:]]+).*count=(0x[[:xdigit:]]+)} $line -> offset count ] } {
 164         handle_read $h $offset $count
 165     } elseif { [ regexp {\mWrite.*offset=(0x[[:xdigit:]]+).*count=(0x[[:xdigit:]]+)} $line -> offset count ] } {
 166         handle_op $h w $offset $count
 167     } elseif { [ regexp {\mTrim.*offset=(0x[[:xdigit:]]+).*count=(0x[[:xdigit:]]+)} $line -> offset count ] } {
 168         handle_op $h t $offset $count
 169     } elseif { [ regexp {\mZero.*offset=(0x[[:xdigit:]]+).*count=(0x[[:xdigit:]]+)} $line -> offset count ] } {
 170         handle_op $h z $offset $count
 171     }
 172     # else just ignore any lines we don't understand
 173 }
 174
 175 # Poll the logfile and update the canvas.
 176 # This has to be called every so often.
 177 proc nbdpoll { h } {
 178     set fp [dict get $h fp]
 179
 180     # Read as much as we can from the log file.
 181     set data [read -nonewline $fp]
 182     if { $data ne "" } {
 183         set lines [split $data \n]
 184         foreach line $lines {
 185             handle $h $line
 186         }
 187     }
 188 }