source: vmdshow/trunk/vmdserver.tcl @ 4988

Last change on this file since 4988 was 4978, checked in by ldelgass, 7 years ago

update from r51 of mdshowcase

  • Property svn:eol-style set to native
File size: 29.4 KB
Line 
1# ----------------------------------------------------------------------
2#  HUBZERO: server for VMD
3#
4#  This program runs VMD and acts as a server for client applications.
5# ----------------------------------------------------------------------
6#  Michael McLennan (mmclennan@purdue.edu)
7# ======================================================================
8#  Copyright (c) 2013 - HUBzero Foundation, LLC
9# ======================================================================
10
11# The VMD TCL interpreter is by default interactive.  Turn this off
12# so that unknown commands like "scene" don't get exec-ed.
13set ::tcl_interactive 0
14
15proc bgerror {mesg} {
16    puts stderr "SERVER ERROR: $mesg"
17}
18
19# parse command line args
20set Paradigm "socket"
21while {[llength $argv] > 0} {
22    set opt [lindex $argv 0]
23    set argv [lrange $argv 1 end]
24
25    switch -- $opt {
26        -socket { set Paradigm "socket" }
27        -stdio  { set Paradigm "stdio" }
28        default {
29            puts stderr "bad option \"$opt\": should be -socket or -stdio"
30        }
31    }
32}
33
34# use this to take snapshots to send to clients
35image create photo SnapShot
36
37# set the screen to a good size
38set DisplaySize(w) 300
39set DisplaySize(h) 300
40display resize $DisplaySize(w) $DisplaySize(h)
41set DisplaySize(changed) 0
42
43# capture initial display settings for later reset
44display antialias on
45
46set DisplayProps(options) ""
47foreach key {
48    ambientocclusion antialias aoambient aodirect
49    backgroundgradient
50    culling cuestart cueend cuedensity cuemode
51    depthcue distance
52    eyesep
53    farclip focallength
54    height
55    nearclip
56    projection
57    shadows stereo
58} {
59    if {$key eq "nearclip" || $key eq "farclip"} {
60        append DisplayProps(options) [list display $key set [display get $key]] "\n"
61    } else {
62        append DisplayProps(options) [list display $key [display get $key]] "\n"
63    }
64}
65
66# initialize work queue and epoch counter (see server_send_image)
67set Epoch 0
68set Work(queue) ""
69set Sendqueue ""
70set Scenes(@CURRENT) ""
71
72set parser [interp create -safe]
73
74foreach cmd {
75  axes
76  color
77  gettimestep
78  graphics
79  imd
80  label
81  vmd_label
82  light
83  material
84  measure
85  mobile
86  mol
87  molinfo
88  molecule
89  mouse
90  parallel
91  plugin
92  rawtimestep
93  render
94  rotate
95  rotmat
96  scale
97  vmd_scale
98  spaceball
99  stage
100  tkrender
101  tool
102  translate
103  user
104  vmdcollab
105  vmdcon
106  vmdinfo
107  vmdbench
108  volmap
109} {
110    $parser alias $cmd $cmd
111}
112
113# ----------------------------------------------------------------------
114# USAGE: display option ?arg arg...?
115#
116# Executes the "command arg arg..." string in the server and substitutes
117# the result into the template string in place of each "%v" field.
118# Sends the result back to the client.
119# ----------------------------------------------------------------------
120proc cmd_display {args} {
121    set option [lindex $args 0]
122    if {[lsearch {resize reposition rendermode update fps} $option] >= 0} {
123        # ignore these commands -- they cause trouble
124        return ""
125    }
126    eval display $args
127}
128$parser alias display cmd_display
129
130# ----------------------------------------------------------------------
131# USAGE: tellme "command template with %v" command arg arg...
132#
133# Executes the "command arg arg..." string in the server and substitutes
134# the result into the template string in place of each "%v" field.
135# Sends the result back to the client.
136# ----------------------------------------------------------------------
137proc cmd_tellme {fmt args} {
138    global parser client
139
140    # evaluate args as a command and subst the result in the fmt string
141    if {[catch {$parser eval $args} result] == 0} {
142        server_send_result $client "nv>[string map [list %v $result] $fmt]"
143    } else {
144        server_oops $client $result
145    }
146}
147$parser alias tellme cmd_tellme
148
149# ----------------------------------------------------------------------
150# USAGE: resize <w> <h>
151#
152# Resizes the visualization window to the given width <w> and height
153# <h>.  The next image sent should be this size.
154# ----------------------------------------------------------------------
155proc cmd_resize {w h} {
156    global DisplayProps
157
158    # store the desired size in case we downscale
159    set DisplayProps(framew) $w
160    set DisplayProps(frameh) $h
161
162    server_safe_resize $w $h
163}
164$parser alias resize cmd_resize
165
166# ----------------------------------------------------------------------
167# USAGE: setview ?-rotate <mtx>? ?-scale <mtx>? ?-center <mtx>? ?-global <mtx>?
168#
169# Sets the view matrix for one or more components of the view.  This
170# is a convenient way of getting a view for a particular frame just
171# right in one shot.
172# ----------------------------------------------------------------------
173proc cmd_setview {args} {
174    if {[llength $args] == 8} {
175        # setting all matrices? then start clean
176        display resetview
177    }
178    foreach {key val} $args {
179        switch -- $key {
180            -rotate {
181                molinfo top set rotate_matrix [list $val]
182            }
183            -scale {
184                molinfo top set scale_matrix [list $val]
185            }
186            -center {
187                molinfo top set center_matrix [list $val]
188            }
189            -global {
190                molinfo top set global_matrix [list $val]
191            }
192            default {
193                error "bad option \"$key\": should be -rotate, -scale, -center, or -global"
194            }
195        }
196    }
197}
198$parser alias setview cmd_setview
199
200# ----------------------------------------------------------------------
201# USAGE: drag start|end
202#
203# Resizes the visualization window to the given width <w> and height
204# <h>.  The next image sent should be this size.
205# ----------------------------------------------------------------------
206proc cmd_drag {action} {
207    global DisplayProps
208
209    switch -- $action {
210        start {
211            # simplify rendering so it goes faster during drag operations
212            set neww [expr {round($DisplayProps(framew)/2.0)}]
213            set newh [expr {round($DisplayProps(frameh)/2.0)}]
214            server_safe_resize $neww $newh
215            display rendermode Normal
216            display shadows off
217
218            foreach nmol [molinfo list] {
219                set max [molinfo $nmol get numreps]
220                for {set nrep 0} {$nrep < $max} {incr nrep} {
221                    mol modstyle $nrep $nmol "Lines"
222                }
223            }
224        }
225        end {
226            # put original rendering options back
227            server_safe_resize $DisplayProps(framew) $DisplayProps(frameh)
228            display rendermode $DisplayProps(rendermode)
229            display shadows $DisplayProps(shadows)
230
231            # restore rendering methods for all representations
232            foreach nmol [molinfo list] {
233                set max [molinfo $nmol get numreps]
234                for {set nrep 0} {$nrep < $max} {incr nrep} {
235                    mol modstyle $nrep $nmol $DisplayProps(rep-$nmol-$nrep)
236                }
237            }
238        }
239        default {
240            error "bad option \"$action\": should be start or end"
241        }
242    }
243}
244$parser alias drag cmd_drag
245
246# ----------------------------------------------------------------------
247# USAGE: setquality normal|high
248#
249# Sets the rendering quality for the scene--either "high" (GLSL) or
250# normal.
251# ----------------------------------------------------------------------
252proc cmd_setquality {newval} {
253    global DisplayProps
254
255    switch -- $newval {
256        high {
257            display rendermode GLSL
258            set DisplayProps(rendermode) "GLSL"
259        }
260        normal {
261            display rendermode Normal
262            set DisplayProps(rendermode) "Normal"
263        }
264        default {
265            error "bad quality value \"$newval\": should be normal or high"
266        }
267    }
268}
269$parser alias setquality cmd_setquality
270
271# ----------------------------------------------------------------------
272# USAGE: smoothreps <value>
273#
274# Changes the smoothing factor for all representations of the current
275# molecule.
276# ----------------------------------------------------------------------
277proc cmd_smoothreps {val} {
278    if {$val < 0} {
279        error "bad smoothing value \"$val\": should be >= 0"
280    }
281    foreach nmol [molinfo list] {
282        set max [molinfo $nmol get numreps]
283        for {set nrep 0} {$nrep < $max} {incr nrep} {
284            mol smoothrep $nmol $nrep $val
285        }
286    }
287}
288$parser alias smoothreps cmd_smoothreps
289
290# ----------------------------------------------------------------------
291# USAGE: animate <option> <args>...
292# USAGE: rock off
293# USAGE: rock x|y|z by <step> ?<n>?
294#
295# The usual VMD "animate" and "rock" commands are problematic for this
296# server.  If we're going to rock or play the animation, the client
297# will do it.  Intercept any "animate" and "rock" commands in the scene
298# scripts and do nothing.
299# ----------------------------------------------------------------------
300proc cmd_animate {args} {
301    # do nothing
302}
303$parser alias animate cmd_animate
304
305proc cmd_rock {args} {
306    # do nothing
307}
308$parser alias rock cmd_rock
309
310# ----------------------------------------------------------------------
311# These commands just confuse things, so ignore them silently.
312# ----------------------------------------------------------------------
313proc cmd_noop {args} {
314    # do nothing
315}
316
317$parser alias sleep cmd_noop
318$parser alias menu cmd_noop
319$parser alias vmd_menu cmd_noop
320$parser alias play cmd_noop
321$parser alias quit cmd_noop
322
323# ----------------------------------------------------------------------
324# USAGE: load <file> <file>...
325#
326# Loads the molecule data from one or more files, which may be PDB,
327# DCD, PSF, etc.
328# ----------------------------------------------------------------------
329proc cmd_load {args} {
330    global MolInfo
331
332    # clear all existing molecules
333    foreach nmol [molinfo list] {
334        mol delete $nmol
335    }
336    catch {unset MolInfo}
337
338    # load new files
339    if {![regexp {^@name:} $args]} {
340        # make sure that there is at least one name in the list
341        set args [linsert $args 0 "@name:0"]
342    }
343
344    set slot 0
345    foreach file $args {
346        if {[regexp {^@name:(.+)} $file match name]} {
347            set op "new"
348            continue
349        }
350        mol $op $file waitfor all
351
352        if {$op eq "new"} {
353            set newnum [lindex [molinfo list] end]
354            set MolInfo($name) $newnum
355            set MolInfo($slot) $newnum
356            incr slot
357            set op "addfile"
358        }
359    }
360
361    # BE CAREFUL -- force a "display update" here
362    # that triggers something in VMD that changes view matrices now,
363    # so if we change them later, the new values stick
364    display update
365}
366$parser alias load cmd_load
367
368# ----------------------------------------------------------------------
369# USAGE: scene define <name> <script>
370# USAGE: scene show <name> ?-before <viewCmd>? ?-after <viewCmd>?
371# USAGE: scene clear
372# USAGE: scene forget ?<name> <name>...?
373#
374# Used to define and manipulate scenes of the trajectory information
375# loaded previously by the "load" command.  The "define" operation
376# defines the script that loads a scene called <name>.  The "show"
377# operation executes that script to show the scene.  The "clear"
378# operation clears the current scene (usually in preparation for
379# showing another scene).  The "forget" operation erases one or more
380# scene definitions; if no names are specified, then all scenes are
381# forgotten.
382# ----------------------------------------------------------------------
383proc cmd_scene {option args} {
384    global Scenes Views MolInfo DisplayProps parser
385
386    switch -- $option {
387        define {
388            if {[llength $args] != 2} {
389                error "wrong # args: should be \"scene define name script\""
390            }
391            set name [lindex $args 0]
392            set script [lindex $args 1]
393            set Scenes($name) $script
394        }
395        show {
396            if {[llength $args] < 1 || [llength $args] > 5} {
397                error "wrong # args: should be \"scene show name ?-before cmd? ?-after cmd?\""
398            }
399            set name [lindex $args 0]
400            if {![info exists Scenes($name)]} {
401                error "bad scene name \"$name\": should be one of [join [array names Scenes] {, }]"
402            }
403
404            set triggers(before) ""
405            set triggers(after) ""
406            foreach {key val} [lrange $args 1 end] {
407                switch -- $key {
408                    -before { set triggers(before) $val }
409                    -after { set triggers(after) $val }
410                    default { error "bad option \"$key\": should be -before, -after" }
411                }
412            }
413
414            # if -before arg was given, send back the view right now
415            if {$triggers(before) ne "" && $Scenes(@CURRENT) ne ""} {
416                cmd_tellme $triggers(before) getview
417            }
418
419            # clear the old scene
420            cmd_scene clear
421            display resetview
422
423            # use a safe interp to keep things safe
424            foreach val [$parser eval {info vars}] {
425                # clear all variables created by previous scripts
426                $parser eval [list catch [list unset $val]]
427            }
428            $parser eval [list array set mol [array get MolInfo]]
429
430            if {[catch {$parser eval $Scenes($name)} result]} {
431                error "$result\nwhile loading scene \"$name\""
432            }
433
434            # capture display characteristics in case we ever need to reset
435            set DisplayProps(rendermode) "Normal"
436            set DisplayProps(shadows) [display get shadows]
437
438            foreach nmol [molinfo list] {
439                set max [molinfo $nmol get numreps]
440                for {set nrep 0} {$nrep < $max} {incr nrep} {
441                    set style [lindex [molinfo $nmol get "{rep $nrep}"] 0]
442                    set DisplayProps(rep-$nmol-$nrep) $style
443                }
444            }
445
446            # store the scene name for later
447            set Scenes(@CURRENT) $name
448
449            # if -after arg was given, send back the view after the script
450            if {$triggers(after) ne ""} {
451                cmd_tellme $triggers(after) getview
452            }
453        }
454        clear {
455            foreach mol [molinfo list] {
456                set numOfRep [lindex [mol list $mol] 12]
457                for {set i 1} {$i <= $numOfRep} {incr i} {
458                    mol delrep 0 $mol
459                }
460            }
461            set Scenes(@CURRENT) ""
462            catch {unset Views}
463
464            # reset the server properties
465            axes location off
466            color Display Background black
467            eval $DisplayProps(options)
468        }
469        forget {
470            if {[llength $args] == 0} {
471                set args [array names Scenes]
472            }
473            foreach name $args {
474                if {$name eq "@CURRENT"} continue
475                catch {unset Scenes($name)}
476                if {$name eq $Scenes(@CURRENT)} {
477                    set Scenes(@CURRENT) ""
478                }
479            }
480        }
481        default {
482            error "bad option \"$option\": should be define, show, clear, forget"
483        }
484    }
485}
486$parser alias scene cmd_scene
487
488# ----------------------------------------------------------------------
489# USAGE: frames defview <frame> {matrixNames...} {matrixValues...}
490# USAGE: frames time <epochValue> <start> ?<finish>? ?<inc>? ?-defview?
491# USAGE: frames rotate <epochValue> <xa> <ya> <za> <number>
492# USAGE: frames max
493#
494# Used to request one or more frames for an animation.  A "time"
495# animation is a series of frames between two time points.  A "rotate"
496# animation is a series of frames that rotate the view 360 degrees.
497#
498# The <epochValue> is passed by the client to indicate the relevance of
499# the request.  Whenever the client enters a new epoch, it is no longer
500# concerned with any earlier epochs, so the server can ignore pending
501# images that are out of date.  The server sends back the epoch with
502# all frames so the client can understand if the frames are relevant.
503#
504# The "defview" operation sets the default view associated with each
505# frame.  Animation scripts can change the default view to a series of
506# fly-through views.  This operation provides a way of storing those
507# views.
508#
509# For a "time" animation, the <start> is a number of a requested frame.
510# The <finish> is the last frame in the series.  The <inc> is the step
511# by which the frames should be generated, which may be larger than 1.
512#
513# For a "rotate" animation, the <xa>,<ya>,<za> angles indicate the
514# direction of the rotation.  The <number> is the number of frames
515# requested for a full 360 degree rotation.
516#
517# The "frames max" query returns the maximum number of frames in the
518# trajectory.  The server uses this to figure out the limits of
519# animation.
520# ----------------------------------------------------------------------
521proc cmd_frames {what args} {
522    global client Epoch Work Views
523
524    # check incoming parameters
525    switch -- $what {
526      time {
527        set epochValue [lindex $args 0]
528        set start [lindex $args 1]
529
530        set i [lsearch $args -defview]
531        if {$i >= 0} {
532            set defview 1
533            set args [lreplace $args $i $i]
534        } else {
535            set defview 0
536        }
537
538        set finish [lindex $args 2]
539        if {$finish eq ""} { set finish $start }
540        set inc [lindex $args 3]
541        if {$inc eq ""} { set inc 1 }
542
543        if {![string is integer $finish]} {
544            server_oops $client "bad animation end \"$finish\" should be integer"
545            return
546        }
547        if {![string is integer $inc] || $inc == 0} {
548            server_oops $client "bad animation inc \"$inc\" should be non-zero integer"
549            return
550        }
551        if {($finish < $start && $inc > 0) || ($finish > $start && $inc < 0)} {
552            server_oops $client "bad animation limits: from $start to $finish by $inc"
553        }
554
555        # new epoch? then clean out work queue
556        if {$epochValue > $Epoch} {
557            catch {unset Work}
558            set Work(queue) ""
559            set Epoch $epochValue
560        }
561
562        # add these frames to the queue
563        if {$inc > 0} {
564            # generate frames in play>> direction
565            for {set n $start} {$n <= $finish} {incr n $inc} {
566                if {![info exists Work($n)]} {
567                    lappend Work(queue) [list epoch $epochValue frame $n num $n defview $defview]
568                    set Work($n) 1
569                }
570            }
571        } else {
572            # generate frames in <<play direction
573            for {set n $start} {$n >= $finish} {incr n $inc} {
574                if {![info exists Work($n)]} {
575                    lappend Work(queue) [list epoch $epochValue frame $n num $n defview $defview]
576                    set Work($n) 1
577                }
578            }
579        }
580      }
581      rotate {
582        set epochValue [lindex $args 0]
583        set mx [lindex $args 1]
584        if {![string is double -strict $mx]} {
585            server_oops $client "bad mx rotation value \"$mx\" should be double"
586            return
587        }
588        set my [lindex $args 2]
589        if {![string is double -strict $my]} {
590            server_oops $client "bad my rotation value \"$my\" should be double"
591            return
592        }
593        set mz [lindex $args 3]
594        if {![string is double -strict $mz]} {
595            server_oops $client "bad mz rotation value \"$mz\" should be double"
596            return
597        }
598        set num [lindex $args 4]
599        if {![string is integer -strict $num] || $num < 2} {
600            server_oops $client "bad number of rotation frames \"$num\" should be integer > 1"
601            return
602        }
603
604        #
605        # Compute the rotation matrix for each rotated view.
606        # Start with the current rotation matrix.  Rotate that around
607        # a vector perpendicular to the plane of rotation for the given
608        # angles (mx,my,mz).  Find vector that by rotating some vector
609        # such as (1,1,1) by the angles (mx,my,mz).  Do a couple of
610        # times and compute the differences between those vectors.
611        # Then, compute the cross product of the differences.  The
612        # result is the axis of rotation.
613        #
614        set lastrotx [trans axis x $mx deg]
615        set lastroty [trans axis y $my deg]
616        set lastrotz [trans axis z $mz deg]
617        set lastrot [transmult $lastrotx $lastroty $lastrotz]
618
619        set lastvec [list 1 1 1]
620        foreach v {1 2} {
621            foreach row $lastrot comp {x y z w} {
622                # multiply each row by last vector
623                set vec($comp) 0
624                for {set i 0} {$i < 3} {incr i} {
625                    set vec($comp) [expr {$vec($comp) + [lindex $row $i]}]
626                }
627            }
628            set vec${v}(x) [expr {$vec(x)-[lindex $lastvec 0]}]
629            set vec${v}(y) [expr {$vec(y)-[lindex $lastvec 1]}]
630            set vec${v}(z) [expr {$vec(z)-[lindex $lastvec 2]}]
631
632            set lastvec [list $vec(x) $vec(y) $vec(z)]
633            set lastrot [transmult $lastrot $lastrotx $lastroty $lastrotz]
634        }
635
636        set crx [expr {$vec1(y)*$vec2(z)-$vec1(z)*$vec2(y)}]
637        set cry [expr {$vec1(z)*$vec2(x)-$vec1(x)*$vec2(z)}]
638        set crz [expr {$vec1(x)*$vec2(y)-$vec1(y)*$vec2(x)}]
639
640        set angle [expr {360.0/$num}]
641        set rotby [transabout [list $crx $cry $crz] $angle deg]
642        set rotm [lindex [molinfo top get rotate_matrix] 0]
643
644        # compute cross product of (1,1,1,0) and rotated vector from above
645
646        for {set n 0} {$n < $num} {incr n} {
647            lappend Work(queue) [list epoch $epochValue rotate $rotm num $n defview 0]
648            set rotm [transmult $rotby $rotm]
649            set Work($n) 1
650        }
651      }
652      defview {
653          if {[llength $args] != 3} { error "wrong # args: should be \"defview matrixNameList matrixValueList\"" }
654          set n [lindex $args 0]
655          if {![string is int $n]} { error "bad frame value \"$n\"" }
656          set Views($n) [lrange $args 1 end]
657      }
658      max {
659        set nmol [lindex [molinfo list] 0]
660        if {$nmol ne ""} {
661            return [molinfo $nmol get numframes]
662        }
663        return 0
664      }
665      default {
666        error "bad option \"$what\": should be defview, time, rotate, max"
667      }
668    }
669
670    # service the queue at some point
671    server_send_image -eventually
672}
673$parser alias frames cmd_frames
674
675# ----------------------------------------------------------------------
676# USAGE: getview
677#
678# Used to query the scaling and centering of the initial view set
679# by VMD after a molecule is loaded.  Returns the following:
680#   <viewName> -rotate <mtx> -global <mtx> -scale <mtx> -center <mtx>
681# ----------------------------------------------------------------------
682proc cmd_getview {} {
683    global Scenes
684
685    if {[llength [molinfo list]] == 0} { return "" }
686    if {$Scenes(@CURRENT) eq ""} { return "" }
687
688    set rval [list $Scenes(@CURRENT)]  ;# start with the scene name
689
690    lappend rval -rotate [lindex [molinfo top get rotate_matrix] 0] \
691                 -scale [lindex [molinfo top get scale_matrix] 0] \
692                 -center [lindex [molinfo top get center_matrix] 0] \
693                 -global [lindex [molinfo top get global_matrix] 0]
694
695    return $rval
696}
697$parser alias getview cmd_getview
698
699#
700# USAGE: server_safe_resize <width> <height>
701#
702# Use this version instead of "display resize" whenever possible.
703# The VMD "display resize" goes into the event loop, so calling that
704# causes things to execute out of order.  Use this method instead to
705# store the change and actually resize later.
706#
707proc server_safe_resize {w h} {
708    global DisplaySize
709
710    if {$w != $DisplaySize(w) || $h != $DisplaySize(h)} {
711        set DisplaySize(w) $w
712        set DisplaySize(h) $h
713        set DisplaySize(changed) yes
714    }
715}
716
717# ----------------------------------------------------------------------
718# SERVER CORE
719# ----------------------------------------------------------------------
720proc server_accept {cid addr port} {
721    global env
722
723    fileevent $cid readable [list server_handle $cid $cid]
724    fconfigure $cid -buffering none -blocking 0
725
726    if {[info exists env(LOCAL)]} {
727        # identify server type to this client
728        # VMD on the hub has this built in, but stock versions can
729        # set the environment variable as a work-around
730        puts $cid "vmd 0.1"
731    }
732}
733
734proc server_handle {cin cout} {
735    global parser buffer client
736
737    if {[gets $cin line] < 0} {
738        # when client drops connection, we can exit
739        # nanoscale will spawn a new server next time we need it
740        if {[eof $cin]} {
741            server_exit $cin $cout
742        }
743    } else {
744        append buffer($cin) $line "\n"
745        if {[info complete $buffer($cin)]} {
746            set request $buffer($cin)
747            set buffer($cin) ""
748            set client $cout
749            if {[catch {$parser eval $request} result] == 0} {
750                server_send_image -eventually
751            } else {
752                server_oops $cout $result
753                if { [string match "invalid command*" $result] } {
754                    bgerror "I got a invalid command: $result"
755                    exit 1
756                }
757            }
758        }
759    }
760}
761
762proc server_send {cout} {
763    global Epoch Sendqueue
764
765    # grab the next chunk of output and send it along
766    # discard any chunks from an older epoch
767    while {[llength $Sendqueue] > 0} {
768        set chunk [lindex $Sendqueue 0]
769        set Sendqueue [lrange $Sendqueue 1 end]
770
771        catch {unset data}; array set data $chunk
772        if {$data(epoch) < 0 || $data(epoch) == $Epoch} {
773            catch {puts $cout $data(cmd)}
774
775            # if this command has a binary data block, send it specially
776            if {[string length $data(bytes)] > 0} {
777                fconfigure $cout -translation binary
778                catch {puts $cout $data(bytes)}
779                fconfigure $cout -translation auto
780            }
781            break
782        }
783    }
784
785    # nothing left? Then stop callbacks until we get more
786    if {[llength $Sendqueue] == 0} {
787        fileevent $cout writable ""
788        server_send_image -eventually
789    }
790}
791
792proc server_exit {cin cout} {
793    catch {close $cin}
794    catch {exit 0}
795}
796
797# ----------------------------------------------------------------------
798# SERVER RESPONSES
799# ----------------------------------------------------------------------
800
801# turn off constant updates -- only need them during server_send_image
802display update off
803
804proc server_send_image {{when -now}} {
805    global client Epoch Work Views Sendqueue DisplaySize
806
807    if {$when eq "-eventually"} {
808        after cancel server_send_image
809        after 1 server_send_image
810        return
811    } elseif {$when ne "-now"} {
812        error "bad option \"$when\" for server_send_image: should be -now or -eventually"
813    }
814
815    # is there a display resize pending? then resize and try again later
816    if {$DisplaySize(changed)} {
817        set DisplaySize(changed) 0
818        after idle [list display resize $DisplaySize(w) $DisplaySize(h)]
819        after 20 server_send_image
820        return
821    }
822
823    # loop through requests in the work queue and skip any from an older epoch
824    while {1} {
825        if {[llength $Work(queue)] == 0} {
826            return
827        }
828
829        set rec [lindex $Work(queue) 0]
830        set Work(queue) [lrange $Work(queue) 1 end]
831
832        catch {unset item}; array set item $rec
833        if {$item(epoch) < $Epoch} {
834            catch {unset Work($item(num))}
835            continue
836        }
837
838        # set the frame characteristics and render this frame
839        if {[info exists item(frame)]} {
840            animate goto $item(frame)
841        } elseif {[info exists item(rotate)]} {
842            molinfo top set rotate_matrix [list $item(rotate)]
843            # send rotation matrix back to the client so we can pause later
844            server_send_latest $client [list nv>rotatemtx $item(num) $item(rotate)]
845        } else {
846            puts "ERROR: bad work frame: [array get item]"
847        }
848
849        # flag to use the stored default view? then set that
850        if {[info exists item(defview)] && $item(defview)} {
851            if {[info exists Views($item(frame))]} {
852                eval molinfo top set $Views($item(frame))
853            }
854        }
855        catch {unset Work($item(num))}
856        break
857    }
858
859    # force VMD to update and grab the screen
860    display update
861    tkrender SnapShot
862
863    set data [SnapShot data -format PPM]
864    server_send_latest $client "nv>image epoch $item(epoch) frame $item(num) length [string length $data]" $data
865
866    # if there's more work in the queue, try again later
867    if {[llength $Work(queue)] > 0} {
868        after 1 server_send_image
869    }
870}
871
872proc server_send_result {cout cmd {data ""}} {
873    global Sendqueue
874
875    # add this result to the output queue
876    # use the epoch -1 to force the send even if the epoch has changed
877    lappend Sendqueue [list epoch -1 cmd $cmd bytes $data]
878    fileevent $cout writable [list server_send $cout]
879}
880
881proc server_send_latest {cout cmd {data ""}} {
882    global Epoch Sendqueue
883
884    # add this result to the output queue
885    # wait until the client is ready, then send the output
886    lappend Sendqueue [list epoch $Epoch cmd $cmd bytes $data]
887    fileevent $cout writable [list server_send $cout]
888}
889
890proc server_oops {cout mesg} {
891    # remove newlines -- all lines must start with nv>
892    set mesg [string map {\n " "} $mesg]
893    server_send_result $cout "nv>oops [list $mesg]"
894}
895
896if {$Paradigm eq "socket"} {
897    socket -server server_accept 2018
898} else {
899    set cin $vmd_client(read)
900    set cout $vmd_client(write)
901
902    fileevent $cin readable [list server_handle $cin $cout]
903    fconfigure $cout -buffering none -blocking 0
904}
905
906# vmd automatically drops into an event loop at this point...
907#
908# The VMD TCL interpreter is by default interactive.  Their version
909# of tkconsole always turns this on.  Turn this off
910# so that unknown commands like "scene" don't get exec-ed.
911set ::tcl_interactive 0
Note: See TracBrowser for help on using the repository browser.