source: vmdshow/trunk/vmdserver.tcl @ 4635

Last change on this file since 4635 was 4453, checked in by ldelgass, 10 years ago

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