Add placeholder for discussion about NBD.
[libguestfs-talks.git] / 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     set height [expr {$size / $blocksize / $width}]
48
49     # Width and height of the canvas.
50     set w_scaled [expr {$width*$scale}]
51     set h_scaled [expr {$height*$scale}]
52     canvas $canvas -bg white -width $w_scaled -height $h_scaled
53
54     # Because Tk's canvas cannot scale images, we use a very
55     # inefficient double buffering here where we have $img which
56     # contains the raw data but is not displayed, and $dispimg which
57     # is the displayed image which is copied/zoomed from $img whenever
58     # $img changes.
59     set img [image create photo -width $width -height $height]
60     $img put "white" -to 0 0 $width $height
61     set dispimg [image create photo -width $w_scaled -height $h_scaled]
62     # -borderwidth somehow counts towards the canvas area?!  So we have
63     # to offset the image by 4, 4 here to make it fully visible.
64     $canvas create image 4 4 -anchor nw -image $dispimg
65
66     # Open the log file.
67     set fp [open $logfile "r"]
68
69     set h [dict create \
70                logfile $logfile \
71                size $size \
72                blocksize $blocksize \
73                width $width \
74                height $height \
75                scale $scale \
76                img $img \
77                dispimg $dispimg \
78                fp $fp]
79     return $h
80 }
81
82 # Return the computed height of the image in pixels.
83 proc nbdheight { h } {
84     return [dict get $h height]
85 }
86
87 # Blit $img to $dispimg, with scaling.  If the optional img parameter
88 # is given, blit that image to $dispimg instead, else use the normal
89 # img stored in the handle.
90 proc update_dispimg { h { img - } } {
91     if { "$img" eq "-" } {
92         set img [dict get $h img]
93     }
94     set dispimg [dict get $h dispimg]
95     set scale [dict get $h scale]
96     $dispimg copy $img -zoom $scale $scale
97 }
98
99 # Handle a read.
100 # This flashes the pixels, but restores their previous value.
101 proc handle_read { h offset count } {
102     set blocksize [dict get $h blocksize]
103     set width [dict get $h width]
104     set height [dict get $h height]
105     set img [dict get $h img]
106
107     # We only write into a temporary image here.
108     set tmpimg [image create photo -width $width -height $height]
109     $tmpimg copy $img
110
111     while { $count > 0 } {
112         set lba [expr {$offset/$blocksize}]
113         set x [expr {$lba % $width}]
114         set y [expr {$lba / $width}]
115
116         # Set the read pixel to black.
117         $tmpimg put "black" -to $x $y [expr {$x+1}] [expr {$y+1}]
118
119         incr offset $blocksize
120         incr count [expr {-$blocksize}]
121     }
122
123     # Update the display buffer with the temporary image.
124     update_dispimg $h $tmpimg
125     update
126
127     # Discard the temporary copy.
128     image delete $tmpimg
129
130     # We don't actually update the display image again.  It will be
131     # restored next time something happens.
132 }
133
134 # Operation colours.
135 array set colours {
136     w "#ff0000"
137     t "#e0e0f0"
138     z "#ffffff"
139 }
140
141 # Handle an operation.
142 #
143 # h: handle
144 # op: operation, "w"-rite, "t"-rim, "z"-ero
145 # offset, count: in bytes
146 proc handle_op { h op offset count } {
147     global colours
148
149     set blocksize [dict get $h blocksize]
150     set width [dict get $h width]
151     set img [dict get $h img]
152
153     # Choose a colour based on the operation.
154     set col $colours($op)
155
156     while { $count > 0 } {
157         set lba [expr {$offset/$blocksize}]
158         set x [expr {$lba % $width}]
159         set y [expr {$lba / $width}]
160
161         # Set the pixel at (x, y) to col.
162         $img put $col -to $x $y [expr {$x+1}] [expr {$y+1}]
163
164         incr offset $blocksize
165         incr count [expr {-$blocksize}]
166     }
167     update_dispimg $h
168 }
169
170 # Handle a single line from the log file.
171 proc handle { h line } {
172     if { [ regexp {\mRead.*offset=(0x[[:xdigit:]]+).*count=(0x[[:xdigit:]]+)} $line -> offset count ] } {
173         handle_read $h $offset $count
174     } elseif { [ regexp {\mWrite.*offset=(0x[[:xdigit:]]+).*count=(0x[[:xdigit:]]+)} $line -> offset count ] } {
175         handle_op $h w $offset $count
176     } elseif { [ regexp {\mTrim.*offset=(0x[[:xdigit:]]+).*count=(0x[[:xdigit:]]+)} $line -> offset count ] } {
177         handle_op $h t $offset $count
178     } elseif { [ regexp {\mZero.*offset=(0x[[:xdigit:]]+).*count=(0x[[:xdigit:]]+)} $line -> offset count ] } {
179         handle_op $h z $offset $count
180     }
181     # else just ignore any lines we don't understand
182 }
183
184 # If nothing happens in nbdpoll for a few iterations then we update
185 # the displayed image.  This is so that black read bars don't appear
186 # permanently if nothing else is happening.
187 set pollcount 50
188
189 # Poll the logfile and update the canvas.
190 # This has to be called every so often from the main program.
191 proc nbdpoll { h } {
192     global pollcount
193
194     set fp [dict get $h fp]
195
196     # Read as much as we can from the log file.
197     set data [read -nonewline $fp]
198     if { $data ne "" } {
199         set lines [split $data \n]
200         foreach line $lines {
201             handle $h $line
202         }
203     } else {
204         # Nothing happening, did pollcount go to zero yet?
205         incr pollcount -1
206         if { $pollcount == 0 } {
207             update_dispimg $h
208             set pollcount 50
209         }
210     }
211 }