+#!/usr/bin/env wish
+# Visualize nbdkit activity - read the README file first!
+# Copyright (C) 2018 Red Hat Inc.
+# All rights reserved.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions are
+# met:
+#
+# * Redistributions of source code must retain the above copyright
+# notice, this list of conditions and the following disclaimer.
+#
+# * Redistributions in binary form must reproduce the above copyright
+# notice, this list of conditions and the following disclaimer in the
+# documentation and/or other materials provided with the distribution.
+#
+# * Neither the name of Red Hat nor the names of its contributors may be
+# used to endorse or promote products derived from this software without
+# specific prior written permission.
+#
+# THIS SOFTWARE IS PROVIDED BY RED HAT AND CONTRIBUTORS ''AS IS'' AND
+# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
+# THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
+# PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL RED HAT OR
+# CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+# SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+# LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
+# USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
+# ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
+# OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT
+# OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+# SUCH DAMAGE.
+
+package require Tk
+
+# Create an nbdcanvas object.
+#
+# canvas: canvas object name which is created (eg. ".c")
+# logfile: log file to monitor
+# size: size in bytes of the underlying disk
+# blocksize: size in bytes of the block corresponding to each pixel
+# width: width of the canvas (height is determined from size & blocksize)
+# scale: each pixel is scaled by this amount
+#
+# Returns an opaque handle which should be passed to nbdpoll.
+proc nbdcanvas { canvas logfile size blocksize width scale } {
+ canvas $canvas -bg white
+ set height [expr {$size / $blocksize / $width}]
+
+ # Because Tk's canvas cannot scale images, we use a very
+ # inefficient double buffering here where we have $img which
+ # contains the raw data but is not displayed, and $dispimg which
+ # is the displayed image which is copied/zoomed from $img whenever
+ # $img changes.
+ set img [image create photo -width $width -height $height]
+ $img put "white" -to 0 0 $width $height
+ set dispimg [image create photo -width [expr {$width*$scale}] \
+ -height [expr {$height*$scale}]]
+ $canvas create image 0 0 -anchor nw -image $dispimg
+
+ # Open the log file.
+ set fp [open $logfile "r"]
+
+ set h [dict create \
+ logfile $logfile \
+ size $size \
+ blocksize $blocksize \
+ width $width \
+ height $height \
+ scale $scale \
+ img $img \
+ dispimg $dispimg \
+ fp $fp]
+ return $h
+}
+
+# Return the computed height of the image in pixels.
+proc nbdheight { h } {
+ return [dict get $h height]
+}
+
+# Blit $img to $dispimg, with scaling.
+proc update_dispimg { h } {
+ set img [dict get $h img]
+ set dispimg [dict get $h dispimg]
+ set width [dict get $h width]
+ set height [dict get $h height]
+ set scale [dict get $h scale]
+ $dispimg copy $img -zoom $scale $scale
+}
+
+# Handle a read.
+# This flashes the pixels, but restores their previous value.
+proc handle_read { h offset count } {
+ set blocksize [dict get $h blocksize]
+ set width [dict get $h width]
+ set img [dict get $h img]
+
+ while { $count > 0 } {
+ set lba [expr {$offset/$blocksize}]
+ set x [expr {$lba % $width}]
+ set y [expr {$lba / $width}]
+
+ set oldcol [$img get $x $y]
+ set oldcol [format "#%02x%02x%02x" \
+ [lindex $oldcol 0] \
+ [lindex $oldcol 1] \
+ [lindex $oldcol 2]]
+ # Flash the pixel to black.
+ $img put "black" -to $x $y [expr {$x+1}] [expr {$y+1}]
+ update_dispimg $h
+ update
+ # Restore old colour.
+ $img put $oldcol -to $x $y [expr {$x+1}] [expr {$y+1}]
+ update_dispimg $h
+
+ incr offset $blocksize
+ incr count [expr {-$blocksize}]
+ }
+}
+
+# Operation colours.
+array set colours {
+ # write => red
+ w "#ff0000"
+ # trim => grey
+ t "#e0e0e0"
+ # zero => white
+ z "#ffffff"
+}
+
+# Handle an operation.
+#
+# h: handle
+# op: operation, "w"-rite, "t"-rim, "z"-ero
+# offset, count: in bytes
+proc handle_op { h op offset count } {
+ global colours
+
+ set blocksize [dict get $h blocksize]
+ set width [dict get $h width]
+ set img [dict get $h img]
+
+ # Choose a colour based on the operation.
+ set col $colours($op)
+
+ while { $count > 0 } {
+ set lba [expr {$offset/$blocksize}]
+ set x [expr {$lba % $width}]
+ set y [expr {$lba / $width}]
+
+ # Set the pixel at (x, y) to col.
+ $img put $col -to $x $y [expr {$x+1}] [expr {$y+1}]
+
+ incr offset $blocksize
+ incr count [expr {-$blocksize}]
+ }
+ update_dispimg $h
+}
+
+# Handle a single line from the log file.
+proc handle { h line } {
+ if { [ regexp {\mRead.*offset=(0x[[:xdigit:]]+).*count=(0x[[:xdigit:]]+)} $line -> offset count ] } {
+ handle_read $h $offset $count
+ } elseif { [ regexp {\mWrite.*offset=(0x[[:xdigit:]]+).*count=(0x[[:xdigit:]]+)} $line -> offset count ] } {
+ handle_op $h w $offset $count
+ } elseif { [ regexp {\mTrim.*offset=(0x[[:xdigit:]]+).*count=(0x[[:xdigit:]]+)} $line -> offset count ] } {
+ handle_op $h t $offset $count
+ } elseif { [ regexp {\mZero.*offset=(0x[[:xdigit:]]+).*count=(0x[[:xdigit:]]+)} $line -> offset count ] } {
+ handle_op $h z $offset $count
+ }
+ # else just ignore any lines we don't understand
+}
+
+# Poll the logfile and update the canvas.
+# This has to be called every so often.
+proc nbdpoll { h } {
+ set fp [dict get $h fp]
+
+ # Read as much as we can from the log file.
+ set data [read -nonewline $fp]
+ if { $data ne "" } {
+ set lines [split $data \n]
+ foreach line $lines {
+ handle $h $line
+ }
+ }
+}
git.annexia.org / libguestfs-talks.git / commitdiff