source: trunk/browsecif.tcl @ 638

Last change on this file since 638 was 638, checked in by toby, 11 years ago

# on 2002/08/09 16:43:07, toby did:
CIF support library
  • Property rcs:author set to toby
  • Property rcs:date set to 2002/08/09 16:43:07
  • Property rcs:rev set to 1.1
  • Property rcs:state set to Exp
  • Property svn:keywords set to Author Date Revision Id
File size: 49.9 KB
RevLine 
[638]1#!/usr/bin/wish
2# $Id: browsecif.tcl 638 2009-12-04 23:09:31Z toby $
3
4# possible future work:
5#   implement adding a new data item to a CIF? Delete one?
6#   can I bind to the tree window only? (.browser.pw.f0.frame.lf.tree)
7#   clean up use of block<n> arrays. Should the prefix be changable? Use
8#    the same syntax throughout
9
10#------------------------------------------------------------------------------
11# Misc Tcl/Tk utility routines follow
12#------------------------------------------------------------------------------
13#       Message box code that centers the message box over the parent.
14#          or along the edge, if too close,
15#          but leave a border along +x & +y for reasons I don't remember
16#       It also allows the button names to be defined using
17#            -type $list  -- where $list has a list of button names
18#       larger messages are placed in a scrolled text widget
19#       capitalization is now ignored for -default
20#       The command returns the name button in all lower case letters
21#       otherwise see  tk_messageBox for a description
22#
23#       This is a modification of tkMessageBox (msgbox.tcl v1.5)
24#
25proc MyMessageBox {args} {
26    global tkPriv tcl_platform
27
28    set w tkPrivMsgBox
29    upvar #0 $w data
30
31    #
32    # The default value of the title is space (" ") not the empty string
33    # because for some window managers, a
34    #           wm title .foo ""
35    # causes the window title to be "foo" instead of the empty string.
36    #
37    set specs {
38        {-default "" "" ""}
39        {-icon "" "" "info"}
40        {-message "" "" ""}
41        {-parent "" "" .}
42        {-title "" "" " "}
43        {-type "" "" "ok"}
44        {-helplink "" "" ""}
45    }
46
47    tclParseConfigSpec $w $specs "" $args
48
49    if {[lsearch {info warning error question} $data(-icon)] == -1} {
50        error "bad -icon value \"$data(-icon)\": must be error, info, question, or warning"
51    }
52    if {![string compare $tcl_platform(platform) "macintosh"]} {
53      switch -- $data(-icon) {
54          "error"     {set data(-icon) "stop"}
55          "warning"   {set data(-icon) "caution"}
56          "info"      {set data(-icon) "note"}
57        }
58    }
59
60    if {![winfo exists $data(-parent)]} {
61        error "bad window path name \"$data(-parent)\""
62    }
63
64    switch -- $data(-type) {
65        abortretryignore {
66            set buttons {
67                {abort  -width 6 -text Abort -under 0}
68                {retry  -width 6 -text Retry -under 0}
69                {ignore -width 6 -text Ignore -under 0}
70            }
71        }
72        ok {
73            set buttons {
74                {ok -width 6 -text OK -under 0}
75            }
76          if {![string compare $data(-default) ""]} {
77                set data(-default) "ok"
78            }
79        }
80        okcancel {
81            set buttons {
82                {ok     -width 6 -text OK     -under 0}
83                {cancel -width 6 -text Cancel -under 0}
84            }
85        }
86        retrycancel {
87            set buttons {
88                {retry  -width 6 -text Retry  -under 0}
89                {cancel -width 6 -text Cancel -under 0}
90            }
91        }
92        yesno {
93            set buttons {
94                {yes    -width 6 -text Yes -under 0}
95                {no     -width 6 -text No  -under 0}
96            }
97        }
98        yesnocancel {
99            set buttons {
100                {yes    -width 6 -text Yes -under 0}
101                {no     -width 6 -text No  -under 0}
102                {cancel -width 6 -text Cancel -under 0}
103            }
104        }
105        default {
106#           error "bad -type value \"$data(-type)\": must be abortretryignore, ok, okcancel, retrycancel, yesno, or yesnocancel"
107            foreach item $data(-type) {
108                lappend buttons [list [string tolower $item] -text $item -under 0]
109            }
110        }
111    }
112
113    if {[string compare $data(-default) ""]} {
114        set valid 0
115        foreach btn $buttons {
116            if {![string compare [lindex $btn 0] [string tolower $data(-default)]]} {
117                set valid 1
118                break
119            }
120        }
121        if {!$valid} {
122            error "invalid default button \"$data(-default)\""
123        }
124    }
125
126    # 2. Set the dialog to be a child window of $parent
127    #
128    #
129    if {[string compare $data(-parent) .]} {
130        set w $data(-parent).__tk__messagebox
131    } else {
132        set w .__tk__messagebox
133    }
134
135    # 3. Create the top-level window and divide it into top
136    # and bottom parts.
137
138    catch {destroy $w}
139    toplevel $w -class Dialog
140    wm title $w $data(-title)
141    wm iconname $w Dialog
142    wm protocol $w WM_DELETE_WINDOW { }
143    wm transient $w $data(-parent)
144    if {![string compare $tcl_platform(platform) "macintosh"]} {
145        unsupported1 style $w dBoxProc
146    }
147
148    frame $w.bot
149    pack $w.bot -side bottom -fill both
150    frame $w.top
151    pack $w.top -side top -fill both -expand 1
152    if {$data(-helplink) != ""} {
153#       frame $w.help
154#       pack $w.help -side top -fill both
155        pack [button $w.top.1 -text Help -bg yellow \
156                -command "MakeWWWHelp $data(-helplink)"] \
157                -side right -anchor ne
158        bind $w <Key-F1> "MakeWWWHelp $data(-helplink)"
159    }
160    if {[string compare $tcl_platform(platform) "macintosh"]} {
161        $w.bot configure -relief raised -bd 1
162        $w.top configure -relief raised -bd 1
163    }
164
165    # 4. Fill the top part with bitmap and message (use the option
166    # database for -wraplength and -font so that they can be
167    # overridden by the caller).
168
169    option add *Dialog.msg.wrapLength 6i widgetDefault
170
171    if {[string length $data(-message)] > 300} {
172        if {![string compare $tcl_platform(platform) "macintosh"]} {
173            option add *Dialog.msg.t.font system widgetDefault
174        } else {
175            option add *Dialog.msg.t.font {Times 18} widgetDefault
176        }
177        frame $w.msg
178        grid [text  $w.msg.t  \
179                -height 20 -width 55 -relief flat -wrap word \
180                -yscrollcommand "$w.msg.rscr set" \
181                ] -row 1 -column 0 -sticky news
182        grid [scrollbar $w.msg.rscr  -command "$w.msg.t yview" \
183                ] -row 1 -column 1 -sticky ns
184        # give extra space to the text box
185        grid columnconfigure $w.msg 0 -weight 1
186        grid rowconfigure $w.msg 1 -weight 1
187        $w.msg.t insert end $data(-message)
188    } else {
189        if {![string compare $tcl_platform(platform) "macintosh"]} {
190            option add *Dialog.msg.font system widgetDefault
191        } else {
192            option add *Dialog.msg.font {Times 18} widgetDefault
193        }
194        label $w.msg -justify left -text $data(-message)
195    }
196    pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 3m -pady 3m
197    if {[string compare $data(-icon) ""]} {
198        label $w.bitmap -bitmap $data(-icon)
199        pack $w.bitmap -in $w.top -side left -padx 3m -pady 3m
200    }
201
202    # 5. Create a row of buttons at the bottom of the dialog.
203
204    set i 0
205    foreach but $buttons {
206        set name [lindex $but 0]
207        set opts [lrange $but 1 end]
208      if {![llength $opts]} {
209            # Capitalize the first letter of $name
210          set capName [string toupper \
211                    [string index $name 0]][string range $name 1 end]
212            set opts [list -text $capName]
213        }
214
215      eval button [list $w.$name] $opts [list -command [list set tkPriv(button) $name]]
216
217        if {![string compare $name [string tolower $data(-default)]]} {
218            $w.$name configure -default active
219        }
220      pack $w.$name -in $w.bot -side left -expand 1 -padx 3m -pady 2m
221
222        # create the binding for the key accelerator, based on the underline
223        #
224        set underIdx [$w.$name cget -under]
225        if {$underIdx >= 0} {
226            set key [string index [$w.$name cget -text] $underIdx]
227          bind $w <Alt-[string tolower $key]>  [list $w.$name invoke]
228          bind $w <Alt-[string toupper $key]>  [list $w.$name invoke]
229        }
230        incr i
231    }
232
233    # 6. Create a binding for <Return> on the dialog if there is a
234    # default button.
235
236    if {[string compare $data(-default) ""]} {
237      bind $w <Return> [list tkButtonInvoke $w.[string tolower $data(-default)]]
238    }
239
240    # 7. Withdraw the window, then update all the geometry information
241    # so we know how big it wants to be, then center the window in the
242    # display and de-iconify it.
243
244    wm withdraw $w
245    update idletasks
246    set wp $data(-parent)
247    # center the new window in the middle of the parent
248    set x [expr [winfo x $wp] + [winfo width $wp]/2 - \
249            [winfo reqwidth $w]/2 - [winfo vrootx $wp]]
250    set y [expr [winfo y $wp] + [winfo height $wp]/2 - \
251            [winfo reqheight $w]/2 - [winfo vrooty $wp]]
252    # make sure that we can see the entire window
253    set xborder 10
254    set yborder 25
255    if {$x < 0} {set x 0}
256    if {$x+[winfo reqwidth $w] +$xborder > [winfo screenwidth $w]} {
257        incr x [expr \
258                [winfo screenwidth $w] - ($x+[winfo reqwidth $w] + $xborder)]
259    }
260    if {$y < 0} {set y 0}
261    if {$y+[winfo reqheight $w] +$yborder > [winfo screenheight $w]} {
262        incr y [expr \
263                [winfo screenheight $w] - ($y+[winfo reqheight $w] + $yborder)]
264    }
265    wm geom $w +$x+$y
266    wm deiconify $w
267
268    # 8. Set a grab and claim the focus too.
269
270    catch {set oldFocus [focus]}
271    catch {set oldGrab [grab current $w]}
272    catch {
273        grab $w
274        if {[string compare $data(-default) ""]} {
275            focus $w.[string tolower $data(-default)]
276        } else {
277            focus $w
278        }
279    }
280
281    # 9. Wait for the user to respond, then restore the focus and
282    # return the index of the selected button.  Restore the focus
283    # before deleting the window, since otherwise the window manager
284    # may take the focus away so we can't redirect it.  Finally,
285    # restore any grab that was in effect.
286
287    tkwait variable tkPriv(button)
288    catch {focus $oldFocus}
289    destroy $w
290    catch {grab $oldGrab}
291    return $tkPriv(button)
292}
293
294# tell'em what is happening
295proc pleasewait {{message {}}} {
296    catch {destroy .msg}
297    toplevel .msg
298    wm transient .msg [winfo toplevel .]
299    pack [frame .msg.f -bd 4 -relief groove]
300    pack [message .msg.f.m -text "Please wait $message"]
301    wm withdraw .msg
302    update idletasks
303    # place the message on top of the main window
304    set x [expr [winfo x .] + [winfo width .]/2 - \
305            [winfo reqwidth .msg]/2 - [winfo vrootx .]]
306    if {$x < 0} {set x 0}
307    set y [expr [winfo y .] + [winfo height .]/2 - \
308            [winfo reqheight .msg]/2 - [winfo vrooty .]]
309    if {$y < 0} {set y 0}
310    wm geom .msg +$x+$y
311    wm deiconify .msg
312    global makenew
313    set makenew(OldGrab) ""
314    set makenew(OldFocus) ""
315    # save focus & grab
316    catch {set makenew(OldFocus) [focus]}
317    catch {set makenew(OldGrab) [grab current .msg]}
318    catch {grab .msg}
319    update
320}
321
322# clear the wait message
323proc donewait {} {
324    global makenew
325    catch {destroy .msg}
326    # reset focus & grab
327    catch {
328        if {$makenew(OldFocus) != ""} {
329            focus $makenew(OldFocus)
330        }
331    }
332    catch {
333        if {$makenew(OldGrab) != ""} {
334            grab $makenew(OldGrab)
335        }
336    }
337}
338
339# this routine is used to fix up tk_optionMenu widgets that have too many
340# entries for a single list -- by using cascades
341proc FixBigOptionMenu {widget enum "cmd {}"} {
342    # max entries
343    set max 12
344    set menu [winfo children $widget]
345    $menu delete 0 end
346    eval destroy [winfo children $menu]
347    set var [$widget cget -textvariable]
348    # do we need a cascade?
349    if {[set n [llength $enum]] <= $max} {
350        # no
351        foreach l $enum {
352            $menu add radiobutton -value $l -label $l -variable $var \
353                    -command $cmd
354        }
355        return
356    }
357    # yes
358    set nmenus [expr int(($max + $n - 1 )/ (1.*$max))]
359    set nper [expr 1 + $n/$nmenus]
360    if {$nper > $max} {set nper $max}
361    for {set i 0} {$i < $n} {incr i $nper} {
362        set j [expr $i + $nper -1]
363        set sublist [lrange $enum $i $j]
364        $menu add cascade -label "[lindex $sublist 0]-[lindex $sublist end]" \
365                -menu $menu.$i
366        menu $menu.$i
367        foreach l $sublist {
368            $menu.$i add radiobutton -value $l -label $l -variable $var \
369                    -command $cmd
370        }
371    }
372}
373
374# this routine is used to add . and ? in a cascade for enum lists
375proc AddSpecialEnumOpts {widget "cmd {}"} {
376    set menu [winfo children $widget]
377    set var [$widget cget -textvariable]
378
379    # add the cascade and entries to it
380    $menu add cascade -label "(special values)" -menu $menu.special
381    menu $menu.special
382    $menu.special add radiobutton -value . -command $cmd \
383            -label "Inapplicable (.)" -variable $var
384    $menu.special add radiobutton -value ? -command $cmd \
385            -label "Unknown (?)" -variable $var
386}
387
388#------------------------------------------------------------------------------
389# end of Misc Tcl/Tk utility routines
390#------------------------------------------------------------------------------
391
392#------------------------------------------------------------------------------# ParseCIF reads and parses a CIF file putting the contents of
393# each block into arrays block1, block2,... in the caller's level
394#    the name of the block is saved as blockN(data_)
395# data names items are saved as blockN(_data_name) = marker_number
396#    where CIF data names are converted to lower case
397#    and marker_number.l marker_number.r define the range of the value
398# for looped data names, the data items are included in a list:
399#    blockN(_cif_name) = {marker1 marker2 ...}
400# the contents of each loop are saved as blockN(loop_M)
401#
402# The proc returns the number of blocks that have been read or a
403#    null string if the file cannot be opened
404#
405# This parser does some error checking [errors are reported in blockN(error)]
406#    but the parser could get confused if the CIF has invalid syntax
407#
408proc ParseCIF {txt filename} {
409    global CIF tcl_version
410
411    if {$tcl_version < 8.2} {
412        tk_dialog .error {Old Tcl/Tk} \
413                "Sorry, the CIF Browser requires version 8.2 or later of the Tcl/Tk package. This is $tcl_version" \
414                warning 0 Sorry
415        return
416    }
417
418    if [catch {
419        set fp [open $filename r]
420        $txt insert end [read $fp]
421        close $fp
422    }] {return ""}
423
424    set pos 1.0
425    set blocks 0
426    set EOF 1
427    set dataname {}
428    set CIF(markcount) -1
429    # this flags where we are w/r a loop_
430    #    -1 not in a loop
431    #     0 reading a loop header (data names)
432    #     1 reading the data items in a loop
433    set loopflag -1
434    set loopnum -1
435    # loop over tokens
436    while {$EOF} {
437        # skip forward to the first non-blank character
438        set pos [$txt search -regexp {[^[:space:]]} $pos end]
439        # is this the end?
440        if {$pos == ""} {
441            set EOF 0
442            break
443        }
444
445        # is this a comment, if so skip to next line
446        if {[$txt get $pos] == "#"} {
447            set pos [$txt index "$pos + 1 line linestart"]
448            continue
449        }
450
451        # find end of token
452        set epos [$txt search -regexp {[[:space:]]} $pos "$pos lineend"]
453        if {$epos == ""} {set epos [$txt index "$pos lineend"]}
454
455        set token [$txt get $pos $epos]
456
457        if {[string tolower [string range $token 0 4]] == "data_"} {
458            # this is the beginning of a data block
459            incr blocks
460            set blockname [string range $token 5 end]
461            global block$blocks
462            catch {unset block$blocks}
463            set block${blocks}(data_) $blockname
464            set loopnum -1
465            if {$dataname != ""} {
466                # this is an error -- data_ block where a data item is expected
467                append block${blocks}(errors) "No data item was found for $dataname near line [lindex [split $pos .] 0]\n"
468                set dataname {}
469            }
470            # move forward past current token
471            set pos [$txt index "$epos +1c"]
472            continue
473        }
474       
475        if {[$txt get $pos] == "_"} {
476            # this is a cif data name
477            if {$dataname != ""} {
478                # this is an error -- data name where a data item is expected
479                append block${blocks}(errors) "No data item was found for $dataname near line [lindex [split $pos .] 0]\n"
480            }
481            # convert it to lower case & save
482            set dataname [string tolower $token]
483
484            # are we in a loop header or loop body?
485            if {$loopflag == 0} {
486                # in a loop header, save the names in the loop list
487                lappend looplist $dataname
488                if {$blocks == 0} {
489                    # an error -- a loop_ before a data_ block start
490                    global block${blocks}
491                    set block${blocks}(data_) undefined
492                    append block${blocks}(errors) \
493                            "A loop_ begins before a data_ block is defined (line [lindex [split $pos .] 0])\n"
494                }
495                set block${blocks}(loop_${loopnum}) $looplist
496                # clear the array element for the data item
497                # -- should not be needed for a valid CIF but if a name is used
498                # -- twice in the same block, want to wipe out the 1st data
499                catch {
500                    if {[set block${blocks}($dataname)] != ""} {
501                        # this is an error -- repeated data name
502                        append block${blocks}(errors) \
503                                "Data name $dataname is repeated near line [lindex [split $pos .] 0]\n"
504                    }   
505                    set block${blocks}($dataname) {}
506                }
507                set dataname {}
508            } elseif {$loopflag > 0} {
509                # in a loop body, so the loop is over
510                set loopflag -1
511            }
512            # move forward past current token
513            set pos [$txt index "$epos +1c"]
514            continue
515        }
516       
517        if {[string tolower [string range $token 0 4]] == "loop_"} {
518            set loopflag 0
519            incr loopnum
520            set looplist {}
521            set block${blocks}(loop_${loopnum}) {}
522            # move forward past current token
523            set pos [$txt index "$epos +1c"]
524            continue
525        }
526
527        # keywords not matched, must be some type of data item
528        set item {}
529        incr CIF(markcount)
530       
531        if {[$txt get "$pos linestart"] == ";" && \
532                [$txt index $pos] == [$txt index "$pos linestart"]} {
533            # multiline entry with semicolon termination
534            set epos [$txt search -regexp {^;} "$pos + 1 line linestart"]
535            if {$epos == ""} {
536                set epos end
537                append block${blocks}(errors) \
538                        "Unmatched semicolon for $dataname starting at line [lindex [split $pos .] 0]\n"
539            }
540
541            $txt mark set $CIF(markcount).l "$pos linestart"
542            $txt mark set $CIF(markcount).r "$epos + 1c"
543            $txt mark gravity $CIF(markcount).l left
544            $txt mark gravity $CIF(markcount).r right
545            set item [$txt get "$pos linestart" "$epos +1c"]
546            # move forward past current token
547            set pos [$txt index "$epos + 1c"]
548        } elseif {[$txt get $pos] == "\""} {
549            # a quoted string -- find next quote
550            set epos [$txt search "\"" "$pos +1c" "$pos lineend"]
551            # skip over quotes followed by a non-blank
552            while {$epos != "" && \
553                    [regexp {[^[:space:]]} [$txt get "$epos +1c"]] == 1} {
554                set epos [$txt search "\"" "$epos +1c" "$pos lineend"]
555            }
556            # did we hit the end of line?
557            if {$epos == ""} {
558                set epos [$txt index "$pos lineend"]
559                append block${blocks}(errors) "The quoted string on line [lindex [split $pos .] 0] does not have a close quote:\n\t[$txt get $pos $epos]\n"
560            }
561            $txt mark set $CIF(markcount).l "$pos"
562            $txt mark set $CIF(markcount).r "$epos + 1c" 
563            $txt mark gravity $CIF(markcount).l left
564            $txt mark gravity $CIF(markcount).r right
565            set item [$txt get  $pos "$epos +1c"]
566            # move forward past current token
567            set pos [$txt index "$epos +2c"]
568        } elseif {[$txt get $pos] == {'}} {
569            # a quoted string -- find next quote
570            set epos [$txt search {'} "$pos +1c" "$pos lineend"]
571            # skip over quotes followed by a non-blank
572            while {$epos != "" && \
573                    [regexp {[^[:space:]]} [$txt get "$epos +1c"]] == 1} {
574                set epos [$txt search {'} "$epos +1c" "$pos lineend"]
575            }
576            # did we hit the end of line?
577            if {$epos == ""} {
578                set epos [$txt index "$pos lineend"]
579                append block${blocks}(errors) "The quoted string on line [lindex [split $pos .] 0] does not have a close quote:\n\t[$txt get $pos $epos]\n"
580            }
581            $txt mark set $CIF(markcount).l "$pos"       
582            $txt mark set $CIF(markcount).r "$epos + 1c" 
583            $txt mark gravity $CIF(markcount).l left
584            $txt mark gravity $CIF(markcount).r right
585            set item [$txt get $pos "$epos +1c"]
586            # move forward past current token
587            set pos [$txt index "$epos + 2 c"]
588        } elseif {[$txt get $pos] == {[}} {
589            # CIF v1.1 square bracket quotes
590            set count 1
591            set epos $pos
592            while {$count != 0} {
593                set epos [$txt search -regexp {[\]\[]} "$epos +1c"]
594                if {$epos == ""} {
595                    # unmatched open square bracket
596                    append block${blocks}(errors) "No closing \] was found for open \] at line [lindex [split $pos .] 0]\n"
597                    set count 0
598                    set epos [$txt index end]
599                } elseif {[$txt get $epos] == {]}} {
600                    # close bracket -- decrement
601                    incr count -1
602                } else {
603                    # open bracket -- increment
604                    incr count
605                }
606            }
607            $txt mark set $CIF(markcount).l "$pos"       
608            $txt mark set $CIF(markcount).r "$epos + 1c" 
609            $txt mark gravity $CIF(markcount).l left
610            $txt mark gravity $CIF(markcount).r right
611            set item [$txt get $pos "$epos +1c"]
612            # move forward past current token
613            set pos [$txt index "$epos + 2 c"]
614        } else {
615            # must be a single space-delimited value
616            $txt mark set $CIF(markcount).l $pos
617            $txt mark set $CIF(markcount).r $epos
618            $txt mark gravity $CIF(markcount).l left
619            $txt mark gravity $CIF(markcount).r right
620            set item $token
621            set pos [$txt index "$epos + 1 c"]
622        }
623        # a data item has been read
624
625        # store the data item
626        if {$loopflag >= 0} {
627            # if in a loop, increment the loop element counter to select the
628            # appropriate array element
629            incr loopflag
630            set i [expr ($loopflag - 1) % [llength $looplist]]
631            lappend block${blocks}([lindex $looplist $i]) $CIF(markcount)
632        } elseif {$dataname == ""} {
633            # this is an error -- a data item where we do not expect one
634            append block${blocks}(errors) "The string \"$item\" on line [lindex [split $pos .] 0] was unexpected\n"
635        } else {
636            if {$blocks == 0} {
637                # an error -- a data name before a data_ block start
638                global block${blocks}
639                set block${blocks}(data_) undefined
640                append block${blocks}(errors) \
641                            "Data name $dataname appears before a data_ block is defined (line [lindex [split $pos .] 0])\n"
642            }
643            catch {
644                if {[set block${blocks}($dataname)] != ""} {
645                    # this is an error -- repeated data name
646                    append block${blocks}(errors) \
647                            "Data name $dataname is repeated near line [lindex [split $pos .] 0]\n"
648                }
649            }
650            set block${blocks}($dataname) $CIF(markcount)
651            set dataname ""
652        }
653    }
654    return $blocks
655}
656
657#------------------------------------------------------------------------------# Create a CIF browser/editor
658#  $txt is a text widget with the entire CIF loaded
659#  blocklist contains the list of defined blocks (by #)
660#  selected is the list of blocks that will be expanded
661#  frame gives the name of the toplevel window to hold the browser
662proc BrowseCIF {txt blocklist "selected {}" "frame .cif"} {
663    catch {destroy $frame}
664    toplevel $frame 
665    wm title $frame "CIF Browser"
666    CIFBrowserWindow $frame
667    CIFBrowser $txt $blocklist $selected $frame
668    grid [button $frame.c -text Close -command "destroy $frame"] -column 0 -row 1
669}
670
671# Populate a hierarchical CIF browser
672#    $txt is a text widget with the entire CIF loaded
673#    blocklist contains the list of defined blocks (by #)
674#    selected is the list of blocks that will be expanded
675#    frame gives the name of the toplevel or frame to hold the browser
676proc CIFBrowser {txt blocklist "selected {}" "frame .cif"} {
677    global CIF CIFtreeindex
678
679    if {$selected == ""} {set selected $blocklist}
680
681    # clear out old info, if any, from browser
682    eval $CIF(tree) delete [$CIF(tree) nodes root]
683    catch {unset CIFtreeindex}
684    pack forget $CIF(EditSaveButton) $CIF(AddtoLoopButton) \
685            $CIF(LoopSpinBox) $CIF(DeleteLoopEntry)
686    # delete old contents of frame
687    set frame [$CIF(displayFrame) getframe]
688    eval destroy [grid slaves $frame]
689    # reset the scrollbars
690    $CIF(tree) see 0
691    $CIF(displayFrame) xview moveto 0
692    $CIF(displayFrame) yview moveto 0
693
694    set num 0
695    foreach n $blocklist {
696        global block$n
697        # make a list of data names in loops
698        set looplist {}
699        foreach loop [array names block$n loop_*] {
700            eval lappend looplist [set block${n}($loop)]
701        }
702        # put the block name
703        set blockname [set block${n}(data_)]
704        set open 0
705        if {[lsearch $selected $n] != -1} {set open 1}
706        $CIF(tree) insert end root block$n -text "_data_$blockname" \
707                -open $open -image [Bitmap::get copy]
708
709        # show errors, if any
710        foreach name [array names block$n errors] {
711            $CIF(tree) insert end block$n [incr num] -text $name \
712                    -image [Bitmap::get undo] -data block$n
713        }
714        # loop over the names in each block
715        foreach name [lsort [array names block$n _*]] {
716            # don't include looped names
717            if {[lsearch $looplist $name] == -1} {
718                $CIF(tree) insert end block$n [incr num] -text $name \
719                        -image [Bitmap::get folder] -data block$n
720                set CIFtreeindex(block${n}$name) $num
721            }
722        }
723        foreach loop [lsort [array names block$n loop_*]] {
724            $CIF(tree) insert end block$n block${n}$loop -text $loop \
725                    -image [Bitmap::get file] -data "block$n loop"
726            set CIFtreeindex(block${n}$loop) block${n}$loop
727            foreach name [lsort [set block${n}($loop)]] {
728                $CIF(tree) insert end block${n}$loop [incr num] -text $name \
729                        -image [Bitmap::get folder] -data "block$n $loop"
730                set CIFtreeindex(block${n}$name) $num
731            }
732        }
733    }
734    $CIF(tree) bindImage <1> showCIFbyTreeID
735    $CIF(tree) bindText <1>  showCIFbyTreeID
736}
737
738# Create the widgets for a hierarchical CIF browser in $frame
739#   (where $frame is a frame or toplevel)
740#   note that the BWidget package is required
741proc CIFBrowserWindow {frame} {
742    global CIF
743    if [catch {package require BWidget}] {
744        tk_dialog .error {No BWidget} \
745                "Sorry, the CIF Browser requires the BWidget package" \
746                warning 0 Sorry
747        return
748    }
749
750    set pw    [PanedWindow $frame.pw -side top]
751    grid $pw -sticky news -column 0 -row 0 
752    set width 900
753    if {$width > [winfo screenwidth .]} {set width [winfo screenwidth .]}
754    grid columnconfigure $frame 0 -weight 1 -minsize $width
755    grid rowconfigure $frame 0 -minsize 250 -weight 1
756
757    # create a left hand side pane for the hierarchical tree
758    set pane  [$pw add -weight 1]
759    set sw    [ScrolledWindow $pane.lf \
760            -relief sunken -borderwidth 2]
761    set CIF(tree)  [Tree $sw.tree \
762            -relief flat -borderwidth 0 -width 15 -highlightthickness 0 \
763            -redraw 1]
764    bind $frame <KeyPress-Prior> "$CIF(tree) yview scroll -1 page"
765    bind $frame <KeyPress-Next> "$CIF(tree) yview scroll 1 page"
766#    bind $frame <KeyPress-Up> "$CIF(tree) yview scroll -1 unit"
767#    bind $frame <KeyPress-Down> "$CIF(tree) yview scroll 1 unit"
768    bind $frame <KeyPress-Home> "$CIF(tree) yview moveto 0"
769    #bind $frame <KeyPress-End> "$CIF(tree) yview moveto end" -- does not work
770    bind $frame <KeyPress-End> "$CIF(tree) yview scroll 99999999 page"
771    grid $sw
772    grid $sw -sticky news -column 0 -row 0 
773    grid columnconfigure $pane 0 -minsize 275 -weight 1
774    grid rowconfigure $pane 0 -weight 1
775    $sw setwidget $CIF(tree)
776   
777    # create a right hand side pane to show the value
778    set pane [$pw add -weight 4]
779    set sw   [ScrolledWindow $pane.sw \
780            -relief sunken -borderwidth 2]
781    pack $sw -fill both -expand yes -side top
782
783    pack [frame $pane.f] -fill x
784    set CIF(EditSaveButton) [button $pane.f.b -text "Save Changes" -state disabled \
785            -command "SaveCIFedits"]
786    set CIF(AddtoLoopButton) [button $pane.f.l -text "Add to loop"]
787    set CIF(DeleteLoopEntry) [button $pane.f.d -text "Delete loop entry" \
788            -command DeleteCIFRow]
789    set CIF(LoopSpinBox) [SpinBox $pane.f.sb -range "1 1 1" \
790            -label "Loop\nelement #" -labelwidth 10 -width 10]
791    set CIF(displayFrame) $sw.lb
792    set lb [ScrollableFrame::create $CIF(displayFrame) -width 400]
793    $sw setwidget $lb
794}
795
796# Warn to save changes that are not saved in a file
797proc CheckForCIFEdits {} {
798    global CIF
799    if {$CIF(entry_changed) != ""} {
800        set ans [MyMessageBox -parent . -title "Discard Changes?" \
801                -message "You have changed this entry. Do you want to keep or discard this edit?" \
802                -icon question -type {Save Discard} -default Save]
803        if {$ans == "save"} {
804            SaveCIFedits
805            # did this save anything?
806            if {$CIF(entry_changed) != ""} {
807                # if not, don't allow the mode/loop value to change
808                set CIF(editmode) 1
809                catch {
810                    $CIF(LoopSpinBox) setvalue @$CIF(lastLoopIndex)
811                }
812                return 1
813            }
814        } else {
815            set CIF(entry_changed) {}
816            $CIF(EditSaveButton) config -state disabled
817        }
818    }
819    return 0
820}
821
822# showCIFbyTreeID is used in BrowseCIF to response to clicking on a tree widget
823#   shows the contents data name or a loop
824proc showCIFbyTreeID {name} {
825    global CIF
826    if {[CheckForCIFEdits]} return
827    set pointer [$CIF(tree) itemcget $name -data]
828    set dataname [$CIF(tree) itemcget $name -text]
829    showCIFbyDataname $pointer $dataname
830}
831
832proc showCIFbyDataname {pointer dataname "loopindex {}"} {
833    if {[CheckForCIFEdits]} return
834    global CIF
835    set CIF(lastShownItem) [list $pointer $dataname]
836    # include a save button
837    if {$CIF(editmode)} {
838        pack $CIF(EditSaveButton) -side left
839    } else {
840        pack forget $CIF(EditSaveButton)
841    }
842    pack forget $CIF(AddtoLoopButton) $CIF(LoopSpinBox) $CIF(DeleteLoopEntry)
843
844    # delete old contents of frame
845    set frame [$CIF(displayFrame) getframe]
846    eval destroy [grid slaves $frame]
847    # reset the scrollbars
848    $CIF(displayFrame) xview moveto 0
849    $CIF(displayFrame) yview moveto 0
850    # leave room for a scrollbar
851    grid columnconfig $frame 0 -minsize [expr \
852            [winfo width [winfo parent $frame]] - 20]
853    if {$pointer == ""} {
854        return
855    }
856    # create list of defined widgets
857    set CIF(widgetlist) {}
858
859    # is this a looped data item?
860    set block [lindex $pointer 0]
861    if {[llength $pointer] == 2} {
862        global $block
863        # display contents of a rows of the loop
864        if {[lindex $pointer 1] == "loop"} {
865            if {$CIF(editmode)} {
866                pack $CIF(DeleteLoopEntry) -side right
867                pack $CIF(AddtoLoopButton) -side right
868                $CIF(AddtoLoopButton) config -command "AddToCIFloop ${block} $dataname"
869            }
870            set looplist [set ${block}($dataname)]
871            # get number of elements for first name
872            set names [llength [set ${block}([lindex $looplist 0])]]
873            $CIF(LoopSpinBox) configure -range "1 $names 1" \
874                    -command    "ShowLoopVar ${block} $dataname" \
875                    -modifycmd  "ShowLoopVar ${block} $dataname"
876            if {$loopindex == ""} {
877                $CIF(LoopSpinBox) setvalue first
878            } else {
879                $CIF(LoopSpinBox) setvalue @$loopindex
880            }
881            pack $CIF(LoopSpinBox) -side right
882            set row 0
883            set i 0
884            ShowDictionaryDefinition $looplist
885            foreach var $looplist {
886                incr i
887                grid [TitleFrame $frame.$i -text $var -side left] \
888                        -column 0 -row $i -sticky ew
889                set row $i
890                set frame0 [$frame.$i getframe]
891                DisplayCIFvalue $frame0.l $var 1 "" ${block}
892                grid columnconfig $frame0 2 -weight 1
893            }
894            ShowLoopVar ${block} $dataname
895        } else {
896            # look at a single looped variable
897            ShowDictionaryDefinition $dataname
898            grid [TitleFrame $frame.0 -text $dataname -side left] \
899                    -column 0 -row 0 -sticky ew
900            set row 0
901            set i 0
902            set frame0 [$frame.0 getframe]
903            grid columnconfig $frame0 2 -weight 1
904            foreach mark [set ${block}($dataname)] {
905                incr i
906                if {$i == 1} {$CIF(txt) see $mark.l}
907                set value [StripQuotes [$CIF(txt) get $mark.l $mark.r]]     
908                grid [label $frame0.a$i -justify left -text $i]\
909                        -sticky w -column 0 -row $i
910                DisplayCIFvalue $frame0.b$i $dataname $i $value ${block} $i
911                #grid $frame0.b$i -sticky new -column 1 -row $i
912            }
913        }
914    } else {
915        # unlooped data name
916        global ${block}
917        ShowDictionaryDefinition $dataname
918        grid [TitleFrame $frame.0 -text $dataname -side left] \
919                -column 0 -row 0 -sticky ew
920        set row 0
921        if {$dataname == "errors"} {
922            set value [set ${block}($dataname)]
923        } else {
924            set mark [set ${block}($dataname)]
925            set value [StripQuotes [$CIF(txt) get $mark.l $mark.r]]         
926            $CIF(txt) see $mark.l
927        }
928        set frame0 [$frame.0 getframe]
929        grid columnconfig $frame0 2 -weight 1
930        DisplayCIFvalue $frame0.l $dataname "" $value $block
931        #grid $frame0.l -sticky w -column 1 -row 0
932    }
933}
934
935# redisplay the last entry shown in showCIFbyTreeID
936# this is used if the edit mode ($CIF(editmode)) changes or if edits are saved
937proc RepeatLastshowCIFvalue {} {
938    global CIF
939    catch {
940        eval showCIFbyDataname $CIF(lastShownItem)
941    }
942}
943
944# used in BrowseCIF in response to the spinbox
945# show entries in a specific row of a loop
946proc ShowLoopVar {array loop} {
947    global $array CIF
948    # check for unsaved changes here
949    if {[CheckForCIFEdits]} return
950
951    set looplist [set ${array}($loop)]
952    set index [$CIF(LoopSpinBox) getvalue]
953    if {$index < 0} {
954        $CIF(LoopSpinBox) setvalue first
955        set index [$CIF(LoopSpinBox) getvalue]
956    } elseif {$index > [llength [set ${array}([lindex $looplist 0])]]} {
957        $CIF(LoopSpinBox) setvalue last
958        set index [$CIF(LoopSpinBox) getvalue]
959    }
960    set CIF(lastLoopIndex) $index
961    set frame [$CIF(displayFrame) getframe]
962    set i 0
963    foreach var $looplist {
964        incr i
965        set mark [lindex [set ${array}($var)] $index]
966        # ignore invalid entries -- should not happen
967        if {$mark == ""} {
968            $CIF(LoopSpinBox) setvalue first
969            return
970        }
971        set value [StripQuotes [$CIF(txt) get $mark.l $mark.r]]     
972        if {$i == 1} {$CIF(txt) see $mark.l}
973        if {$CIF(editmode)} {
974            global CIFeditArr CIFinfoArr
975            set widget [$frame.$i getframe].l
976            set CIFeditArr($widget) $value
977            switch [winfo class $widget] {
978                Text {
979                    $widget delete 0.0 end
980                    $widget insert end $value
981                }
982                Entry {
983                    $widget config -fg black
984                }
985            }
986            set CIFinfoArr($widget) [lreplace $CIFinfoArr($widget) 2 2 $index]
987            $CIF(EditSaveButton) config -state disabled
988        } else {
989            [$frame.$i getframe].l config -text $value
990        }
991    }
992}
993
994# Parse a number in CIF, that may include a SU (ESD) value
995# note that this routine will ignore spaces, quotes & semicolons
996proc ParseSU {value} {
997    # if there is no SU just return the value
998    if {[string first "(" $value] == -1} {
999        return $value
1000    }
1001    # is there a decimal point?
1002    if [regexp {([-+]?[0-9]*\.)([0-9]*)\(([0-9]+)\)} $value junk a b err] {
1003        set ex [string length $b]
1004        return [list ${a}${b} [expr {pow(10.,-$ex)*$err}]]
1005    }
1006    if [regexp {([-+]?[0-9]*)\(([0-9]+)\)} $value junk a err] {
1007        return [list ${a} $err]
1008    }
1009    tk_dialog .err {ParseSU Error} \
1010            "ParseSU: Error processing value $value" \
1011            warning 0 Continue
1012}
1013
1014# a stand-alone routine for testing. Select, read and browse a CIF
1015proc Read_BrowseCIF {} {
1016    global tcl_platform
1017    if {$tcl_platform(platform) == "windows"} {
1018        set filetypelist {
1019            {"CIF files" .CIF} {"All files" *}
1020        }
1021    } else {
1022        set filetypelist {
1023            {"CIF files" .CIF} {"CIF files" .cif} {"All files" *}
1024        }
1025    }   
1026    set file [tk_getOpenFile -parent . -filetypes $filetypelist]
1027    if {$file == ""} return
1028    if {![file exists $file]} return
1029    pleasewait "Reading CIF file"
1030    set blocks [ParseCIF $file]
1031    if {$blocks == ""} {
1032        donewait
1033        MessageBox -parent . -type ok -icon warning \
1034                -message "Note: no valid CIF blocks were read from file $filename"
1035        return
1036    }
1037    catch {donewait}
1038    set allblocks {}
1039    for {set i 1} {$i <= $blocks} {incr i} {
1040        lappend allblocks $i
1041    }
1042    if {$allblocks != ""} {
1043        BrowseCIF $allblocks "" .cif
1044        # wait for the window to close
1045        tkwait window .cif
1046    } else {
1047        puts "no blocks read"
1048    }
1049    # clean up -- get rid of the CIF arrays
1050    for {set i 1} {$i <= $blocks} {incr i} {
1051        global block$i
1052        catch {unset block$i}
1053    }
1054}
1055
1056# this takes a block of text, strips off the quotes ("", '', [] or ;;)
1057proc StripQuotes {value} {
1058    set value [string trim $value]
1059    if {[string range $value end-1 end] == "\n;" && \
1060            [string range $value 0 0] == ";"} {
1061        return [string range $value 1 end-2]
1062    } elseif {[string range $value end end] == "\"" && \
1063            [string range $value 0 0] == "\""} {
1064        set value [string range $value 1 end-1]
1065    } elseif {[string range $value end end] == "'" && \
1066            [string range $value 0 0] == "'"} {
1067        set value [string range $value 1 end-1]
1068    } elseif {[string range $value end end] == {]} && \
1069            [string range $value 0 0] == {[}} {
1070        set value [string range $value 1 end-1]
1071    }
1072    return $value
1073}
1074
1075# replace a CIF value in with a new value.
1076# add newlines as needed to make sure the new value does not
1077# exceed 80 characters/line
1078proc ReplaceMarkedText {txt mark value} {
1079    # is this a multi-line string?
1080    set num [string first \n $value]
1081    set l [string length $value]
1082    # are there spaces in the string?
1083    set spaces [string first " " $value]
1084    # if no, are there any square brackets? -- treat them as requiring quotes
1085    if {$spaces == -1} {set spaces [string first {[} $value]}
1086    # are there quotes inside the string?
1087    set doublequote [string first "\"" $value]
1088    set singlequote [string first {'} $value]
1089    # if we have both types of quotes, use semicolon quoting
1090    if {$singlequote != -1 && $doublequote != -1} {set num $l}
1091
1092    # lines longer than 78 characters with spaces need to be treated
1093    # as multiline
1094    if {$num == -1 && $l > 77 && $spaces != -1} {
1095        set num $l
1096    }
1097    if {$num != -1} {
1098        set tmp {}
1099        if {[lindex [split [$txt index $mark.l] .] 1] != 0} {
1100            append tmp \n
1101        }
1102        append tmp ";"
1103        if {$num > 78} {
1104            append tmp \n
1105        } else {
1106            append tmp " "
1107        }
1108        append tmp $value "\n;"
1109        # is there something else on the line?
1110        set restofline [$txt get $mark.r [lindex [split [$txt index $mark.r] .] 0].end]
1111        if {[string trim $restofline] != ""} {
1112            append tmp \n
1113        }
1114        $txt delete ${mark}.l ${mark}.r
1115        $txt insert ${mark}.l $tmp
1116        return
1117    } elseif {($spaces != -1 || [string trim $value] == "") \
1118            && $doublequote == -1} {
1119        # use doublequotes, unless doublequotes are present inside the string
1120        set tmp "\""
1121        append tmp $value "\""
1122    } elseif {$spaces != -1 || [string trim $value] == ""} {
1123        # use single quotes, since doublequotes are present inside the string
1124        set tmp {'}
1125        append tmp $value {'}
1126    } else {
1127        # no quotes needed
1128        set tmp $value
1129    }
1130    # is there room on the beginning of the line to add the string?
1131    set l [string length $tmp]
1132    set pos [lindex [split [$txt index $mark.l] .] 0]
1133    if {$l + [string length [$txt get $pos.0 $mark.l]] <= 79} {
1134        # will fit
1135        $txt delete ${mark}.l ${mark}.r
1136        $txt insert ${mark}.l $tmp
1137    } else {
1138        # no, stick a CR in front of string
1139        $txt delete ${mark}.l ${mark}.r
1140        $txt insert ${mark}.l \n$tmp
1141    }
1142    # is rest of the line after the inserted string still too long?
1143    set pos [lindex [split [$txt index $mark.r] .] 0]
1144    if {[string length [$txt get $pos.0 $pos.end]] > 79} {
1145        $txt insert $mark.r \n
1146    }
1147}
1148
1149# return the dictionary definition for a list of CIF data names
1150proc GetCIFDefinitions {datanamelist} {
1151    global CIF_dataname_index
1152    set l {}
1153    # compile a list of definition pointers
1154    foreach dataname $datanamelist {
1155        set pointer {}
1156        catch {
1157            set pointer [lindex $CIF_dataname_index($dataname) 0]
1158        }
1159        lappend l [list $dataname $pointer]
1160    }
1161    set l [lsort -index 1 $l]
1162    set pp {}
1163    set dictdefs {}
1164    set def {}
1165    set nlist {}
1166    # merge items with duplicate definitions
1167    foreach item $l {
1168        # is this the first loop through?
1169        foreach {dataname pointer} $item {}
1170        if {$def == ""} {
1171            foreach {nlist pp} $item {}
1172            set def [ReadCIFDefinition $pp]
1173        } elseif {$pp == $pointer} {
1174            # same as last
1175            lappend nlist $dataname
1176        } else {
1177            # add the last entry to the list
1178            set pp $pointer
1179            lappend dictdefs [list $nlist $def]
1180            set nlist $dataname
1181            if {$pointer == ""} {
1182                set def { Undefined dataname}
1183            } else {
1184                # lookup name
1185                set def [ReadCIFDefinition $pointer]
1186            }
1187        }
1188    }
1189    lappend dictdefs [list $nlist $def]
1190    return $dictdefs
1191}
1192
1193# read the CIF definition for a dataname. The pointer contains 3 values
1194# a filename, the number of characters from the start of the file and
1195# the length of the definition.
1196proc ReadCIFDefinition {pointer} {
1197    global CIF
1198    set file {}
1199    set loc {}
1200    set line {}
1201    foreach {file loc len} $pointer {}
1202    if {$file != "" && $loc != "" && $loc != ""} {
1203        set fp {}
1204        foreach path $CIF(cif_path) {
1205            catch {set fp [open [file join $path $file] r]}
1206            if {$fp != ""} break
1207        }
1208        catch {
1209            seek $fp $loc
1210            set line [read $fp $len]
1211            close $fp
1212            # remove superfluous spaces
1213            regsub -all {  +} [StripQuotes $line] { } line
1214        }
1215    }
1216    return $line
1217}
1218
1219# validates that a CIF value is valid for a specific dataname
1220proc ValidateCIFItem {dataname item} {
1221    global CIF_dataname_index
1222    if {[
1223        catch {
1224            foreach {type range elist esd units} [lindex $CIF_dataname_index($dataname) 1] {}
1225        }
1226    ]} {return "warning: dataname $dataname not defined"}
1227    if {$type == "c"} {
1228        if {$elist != ""} {
1229            foreach i $elist {
1230                if {[string tolower $item] == [string tolower [lindex $i 0]]} {return}
1231            }
1232            return "error: value $item is not an allowed option for $dataname"
1233        } else {
1234            set l 0
1235            set err {}
1236            foreach line [split $item \n] {
1237                incr l
1238                if {[string length $line] > 80} {lappend err $l}
1239            }
1240            if {$err != ""} {return "error: line(s) $err are too long"}
1241            return
1242        }
1243    }
1244    if {$type == ""} {return "error: dataname $dataname is not used for CIF data items"}
1245    # validate numbers
1246    if {$type == "n"} {
1247        if {$item == "?" || $item == "."} return
1248        set v $item
1249        # remove s.u., if allowed & present
1250        if {$esd} {
1251            regsub {\([0-9]+\)} $v {} v
1252        }
1253        if [catch {expr $v}] {return "error: value $item is not a valid number for $dataname"}
1254        if {$range != ""} {
1255            # is there a decimal point in the range?
1256            set integer 0
1257            if {[string first . $range] == -1} {set integer 1}
1258            # pull out the range
1259            foreach {min max} [split $range :] {}
1260            if {$integer && int($v) != $v} {
1261                return "error: value $item must be an integer for $dataname"
1262            }
1263            if {$min != ""} {
1264                if {$v < $min} {
1265                    return "error: value $item is too small for $dataname"
1266                }
1267            }
1268            if {$max != ""} {
1269                if {$v > $max} {
1270                    return "error: value $item is too big for $dataname"
1271                }
1272            }
1273        }
1274    }
1275}
1276
1277# displays the dictionary definitions in variable defs into a text widget
1278proc ShowDictionaryDefinition {defs} {
1279    global CIF
1280    set deflist [GetCIFDefinitions $defs]
1281    $CIF(defBox) delete 1.0 end
1282    foreach d $deflist {
1283        foreach {namelist definition} $d {}
1284        foreach n $namelist {
1285            $CIF(defBox) insert end $n dataname
1286            $CIF(defBox) insert end \n
1287        }
1288        $CIF(defBox) insert end \n
1289        $CIF(defBox) insert end $definition
1290        $CIF(defBox) insert end \n
1291        $CIF(defBox) insert end \n
1292    }
1293    $CIF(defBox) tag config dataname -background yellow
1294}
1295
1296# create a widget to display a CIF value
1297proc DisplayCIFvalue {widget dataname loopval value block "row 0"} {
1298    global CIFeditArr CIFinfoArr
1299    global CIF CIF_dataname_index
1300    if {[
1301        catch {
1302            foreach {type range elist esd units} [lindex $CIF_dataname_index($dataname) 1] {}
1303        }
1304    ]} {
1305        set type c
1306        set elist {}
1307    }
1308
1309    lappend CIF(widgetlist) $widget
1310
1311    if $CIF(editmode) {
1312        if {$loopval != ""} {
1313            set widgetinfo [list $dataname $block [expr $loopval -1]]
1314        } else {
1315            set widgetinfo [list $dataname $block 0]
1316        }
1317        if {$type == "n"} {
1318            set CIFeditArr($widget) $value
1319            set CIFinfoArr($widget) $widgetinfo
1320            entry $widget -justify left -textvariable CIFeditArr($widget)
1321            bind $widget <Leave> "CheckChanges $widget"
1322            grid $widget -sticky nsw -column 1 -row $row
1323            if {$units != ""} {
1324                set ws "${widget}u"
1325                label $ws -text "($units)" -bg yellow
1326                grid $ws -sticky nsw -column 2 -row $row
1327            }
1328        } elseif {$elist != ""} {
1329            set CIFeditArr($widget) $value
1330            set CIFinfoArr($widget) $widgetinfo
1331            set enum {}
1332            foreach e $elist {
1333                lappend enum [lindex $e 0]
1334            }
1335            tk_optionMenu $widget CIFeditArr($widget) ""
1336            FixBigOptionMenu $widget $enum "CheckChanges $widget"
1337            AddSpecialEnumOpts $widget "CheckChanges $widget"
1338            grid $widget -sticky nsw -column 1 -row $row
1339        } else {
1340            # count the number of lines in the text
1341            set nlines [llength [split $value \n]]
1342            if {$nlines < 1} {
1343                set nlines 1
1344            } elseif {$nlines > 10} {
1345                set nlines 10
1346            }
1347            set ws "${widget}s"
1348            text $widget -height $nlines -width 80 -yscrollcommand "$ws set"
1349            scrollbar $ws -command "$widget yview" -width 10 -bd 1
1350            $widget insert end $value
1351            bind $widget <Leave> "CheckChanges $widget"
1352            set CIFeditArr($widget) $value
1353            set CIFinfoArr($widget) $widgetinfo
1354            if {$nlines > 1} {
1355                grid $ws -sticky nsew -column 1 -row $row
1356                grid $widget -sticky nsew -column 2 -row $row
1357            } else {
1358                grid $widget -sticky nsew -column 1 -columnspan 2 -row $row
1359            }
1360        }
1361    } else {
1362        label $widget -bd 2 -relief groove \
1363                -justify left -anchor w -text $value
1364        grid $widget -sticky nsw -column 1 -row $row
1365        if {$type == "n" && $units != ""} {
1366            set ws "${widget}u"
1367            label $ws -text "($units)" -bg yellow
1368            grid $ws -sticky nsw -column 2 -row $row
1369        }
1370    }
1371}
1372
1373# this is called to see if the user has changed the value for a CIF
1374# data item. If the value has changed, the "Save Changes" button is
1375# made active.
1376proc CheckChanges {widget} {
1377    global CIFeditArr CIFinfoArr CIF
1378    foreach {dataname block index} $CIFinfoArr($widget) {}
1379    global ${block}
1380    set mark [lindex [set ${block}($dataname)] $index]
1381    set orig [StripQuotes [$CIF(txt) get $mark.l $mark.r]]         
1382    set err {}
1383    switch [winfo class $widget] {
1384        Text {
1385            set current [$widget get 1.0 end]
1386            set l 0
1387            foreach line [set linelist [split $current \n]] {
1388                incr l
1389                if {[string length $line] > 80} {lappend err $l}
1390            }
1391            if {$err != ""} {
1392                foreach l $err {
1393                    $widget tag add error $l.0 $l.end
1394                }
1395                $widget tag config error -foreground red
1396            } else {
1397                $widget tag delete error
1398            }
1399            # see if box should expand
1400            set clines [$widget cget -height]
1401            if {$clines <= 2 && \
1402                    [string trim $orig] != [string trim $current]} {
1403                # count the number of lines in the text
1404                set nlines [llength $linelist]
1405                if {[lindex $linelist end] == ""} {incr nlines -1}
1406                if {$nlines == 2} {
1407                    $widget config -height 2
1408                } elseif {$nlines > 2} {
1409                    set i [lsearch [set s [grid info $widget]] -row]
1410                    set row [lindex $s [expr 1+$i]]
1411                    $widget config -height 3
1412                    set ws "${widget}s"
1413                    grid $ws -sticky nsew -column 1 -row $row
1414                    grid $widget -sticky nsew -column 2 -row $row
1415                }
1416            }
1417        }
1418        Entry {
1419            set current [string trim [$widget get]]
1420            set err [ValidateCIFItem [lindex $CIFinfoArr($widget) 0] $current]
1421            if {$err != "" && \
1422                    [string tolower [lindex $err 0]] != "warning:"} {
1423                $widget config -fg red
1424            } else {
1425                $widget config -fg black
1426            }
1427        }
1428        Menubutton {
1429            set current $CIFeditArr($widget)
1430        }
1431    }
1432    if {[string trim $orig] != [string trim $current]} {
1433        if {$CIF(autosave_edits) && $err == ""} {
1434            lappend CIF(entry_changed) $widget
1435            SaveCIFedits
1436            return
1437        }
1438        if {[string first $widget $CIF(entry_changed)] == -1} {
1439            lappend CIF(entry_changed) $widget
1440        }
1441        $CIF(EditSaveButton) config -state normal
1442    }
1443}
1444
1445# save the CIF edits into the CIF text widget
1446proc SaveCIFedits {} {
1447    global CIFeditArr CIFinfoArr CIF
1448    # validate the entries
1449    set error {}
1450    foreach widget $CIF(entry_changed) {
1451        foreach {dataname block index} $CIFinfoArr($widget) {}
1452        global ${block}
1453        set mark [lindex [set ${block}($dataname)] $index]
1454        set orig [StripQuotes [$CIF(txt) get $mark.l $mark.r]]     
1455        switch [winfo class $widget] {
1456            Text {
1457                set current [$widget get 1.0 end]
1458                set l 0
1459                foreach line [split $current \n] {
1460                    incr l
1461                    if {[string length $line] > 80} {
1462                        lappend error "Error: line $l for $dataname is >80 characters"
1463                    }
1464                }
1465            }
1466            Entry {
1467                set current [string trim [$widget get]]
1468                set err [ValidateCIFItem [lindex $CIFinfoArr($widget) 0] $current]
1469                if {$err != "" && [lindex $err 0] != "warning:"} {
1470                    lappend error $err
1471                }
1472            }
1473        }
1474    }
1475    if {$error != ""} {
1476        set msg "The attempted changes cannot be saved due to:\n"
1477        foreach err $error {
1478            append msg "  " $err \n
1479        }
1480        append msg \n {Please correct and then press "Save Changes"}
1481        MyMessageBox -parent . -title "Invalid Changes?" \
1482                -message $msg -icon error -type Continue -default continue
1483        return
1484    }
1485    foreach widget $CIF(entry_changed) {
1486        foreach {dataname block index} $CIFinfoArr($widget) {}
1487        global ${block}
1488        set mark [lindex [set ${block}($dataname)] $index]
1489        switch [winfo class $widget] {
1490            Text {
1491                set value [string trim [$widget get 1.0 end]]
1492            }
1493            Entry {
1494                set value [string trim [$widget get]]
1495            }
1496            Menubutton {
1497                set value $CIFeditArr($widget)
1498            }
1499        }
1500        ReplaceMarkedText $CIF(txt) $mark $value
1501        incr CIF(changes)
1502    }
1503    set CIF(entry_changed) {}
1504    $CIF(EditSaveButton) config -state disabled
1505    pack $CIF(EditSaveButton) -side left
1506}
1507
1508# add a new "row" to a CIF loop. At least for now, we only add at the end.
1509proc AddToCIFloop {block loop} {
1510    global $block CIF
1511    # check for unsaved changes here
1512    if {[CheckForCIFEdits]} return
1513
1514    set looplist [set ${block}($loop)]
1515    set length [llength [set ${block}([lindex $looplist 0])]]
1516    # find the line following the last entry in the list
1517    set var [lindex $looplist end]
1518    set line [lindex [split [\
1519            $CIF(txt) index [lindex [set ${block}($var)] end].r \
1520            ] .] 0]
1521    incr line
1522    set epos $line.0
1523    $CIF(txt) insert $epos \n
1524    # insert a ? token for each entry & add to marker list for each variable
1525    foreach var $looplist {
1526        incr CIF(changes)
1527        # go to next line?
1528        if {[string length \
1529                [$CIF(txt) get "$epos linestart" "$epos lineend"]\
1530                ] > 78} {
1531            $CIF(txt) insert $epos \n
1532            set epos [$CIF(txt) index "$epos + 1c"]
1533        }
1534        $CIF(txt) insert $epos "? "
1535        incr CIF(markcount)
1536        $CIF(txt) mark set $CIF(markcount).l "$epos"
1537        $CIF(txt) mark set $CIF(markcount).r "$epos + 1c"
1538        $CIF(txt) mark gravity $CIF(markcount).l left
1539        $CIF(txt) mark gravity $CIF(markcount).r right
1540        set epos [$CIF(txt) index "$epos + 2c"]
1541        lappend ${block}($var) $CIF(markcount)
1542    }
1543    # now show the value we have added
1544    set frame [$CIF(displayFrame) getframe]
1545    set max [lindex [$CIF(LoopSpinBox) cget -range] 1]
1546    incr max
1547    $CIF(LoopSpinBox) configure -range "1 $max 1"
1548    $CIF(LoopSpinBox) setvalue last
1549    ShowLoopVar $block $loop
1550}
1551
1552proc DeleteCIFRow {} {
1553    global CIF
1554    global CIFinfoArr CIFeditArr
1555
1556    set delrow [$CIF(LoopSpinBox) getvalue]
1557
1558    set msg {Are you sure you want to delete the following loop entries}
1559    append msg " (row number [expr 1+$delrow])?\n"
1560    set widget ""
1561    foreach widget $CIF(widgetlist) {
1562        set var [lindex $CIFinfoArr($widget) 0]
1563        append msg "\n$var\n\t"
1564        # get the value
1565        switch [winfo class $widget] {
1566            Text {
1567                set value [string trim [$widget get 1.0 end]]
1568            }
1569            Entry {
1570                set value [string trim [$widget get]]
1571            }
1572            Menubutton {
1573                set value $CIFeditArr($widget)
1574            }
1575        }
1576        append msg $value \n
1577    }
1578    if {$widget == ""} {
1579        error "this should not happen"
1580    }
1581    foreach {dataname block index} $CIFinfoArr($widget) {}
1582    global $block
1583    if {[llength [set ${block}($dataname)]] == 1} {
1584        MyMessageBox -parent . -title "Not only row" \
1585                -message {Sorry, this program is unable to delete all entries from a loop.} \
1586                -icon warning -type {Ignore} -default Ignore
1587        return
1588    }
1589
1590    set ans [MyMessageBox -parent . -title "Delete Row?" \
1591                -message $msg \
1592                -icon question -type {Keep Delete} -default Keep]
1593    if {$ans == "keep"} {return}
1594
1595    foreach widget $CIF(widgetlist) {
1596        foreach {dataname block index} $CIFinfoArr($widget) {}
1597        global $block
1598        set mark [lindex [set ${block}($dataname)] $index]
1599        $CIF(txt) delete $mark.l $mark.r
1600        set ${block}($dataname) [lreplace [set ${block}($dataname)] $index $index]
1601    }
1602
1603    set max [lindex [$CIF(LoopSpinBox) cget -range] 1]
1604    incr max -1
1605    $CIF(LoopSpinBox) configure -range "1 $max 1"
1606    $CIF(LoopSpinBox) setvalue last
1607}
1608
1609# initialize misc variables
1610set CIF(entry_changed) {}
1611set CIF(changes) 0
1612set CIF(widgetlist) {}
1613set CIF(lastShownItem) {}
1614set CIF(lastLoopIndex) {}
1615set CIF(autosave_edits) 0
Note: See TracBrowser for help on using the repository browser.