Generated from save.tk with ROBODoc v3.2.2 on Mon Jul 16 19:51:56 2001

TABLE OF CONTENTS

  1. SpecTcl/save_project_as
  2. SpecTcl/save_project
  3. SpecTcl/save_backup
  4. SpecTcl/get_generic_options
  5. SpecTcl/get_file_data
  6. SpecTcl/compile_project
  7. SpecTcl/run_app
  8. SpecTcl/identify_levels
  9. SpecTcl/sort_widgets2
  10. SpecTcl/save_if_dirty

SpecTcl/save_project_as

SOURCE
    proc save_project_as {} {
        global file_select_types P
    
        set filename [tk_getSaveFile -filetypes $file_select_types \
                -defaultextension .$P(file_suffix)]
    
        if [string match "" $filename] {
            return 0
        }
    
        # (Patch): some versions of Tk don't handle the -defaultext switch
    
        if {[file extension $filename] == ""} {
            set filename $filename.$P(file_suffix)
        }
    
        if [save_project $filename] {
            set P(file_untitled) 0
            return 1
        } else {
            return 0
        }
    }

SpecTcl/save_project

SOURCE
    proc save_project {file} {
        dputs "Saving $file"
        global Widgets _Message Id P Current Version
        global Widget_data f Colors
    
        if {[edit_statusFile $file] != 0} {
            tk_messageBox -type ok -icon warning -message \
             "Please exit the external editor before attempting to save this file."
            return 0
        }
    
        if {$file == ""} {
            return 0
        }
    
        save_backup $file
    
        if {[catch {open "$file" "w"} fd]} {
            tk_messageBox -type ok -icon error -title "Save Error" -message \
                "Error opening \"$file\" for writing"
            set _Message "Can't open file $file"
            return 0
        }
        set P(project_dir) [file dirname $file]
        cd $P(project_dir)
        set Current(project) [file root [file tail $file]]
    
        busy_on
        set result [get_file_data]
    
        puts $fd $result
        close $fd
        port_ownThisFile $file
    
        update idletasks
    
        set _Message "save completed"
        set Current(dirty) ""
        busy_off
        return 1
    }

SpecTcl/save_backup

SOURCE
    proc save_backup {fileName} {
        if ![file exists $fileName] {
            return
        }
    
        set errMsg [concat "Error writing to backup file \"$fileName.bak\".\n" \
                "\"$fileName\" will be saved without a backup."]
    
        if {[file exists $fileName.bak] && ![file writable $fileName.bak]} {
            tk_messageBox -type ok -icon error -title "Backup Error" -message \
                $errMsg
            return
        }
        if [catch {
            if [file exists $fileName.bak] {
                file delete $fileName.bak
            }
            if [file exists $fileName] {
                file copy $fileName $fileName.bak
            }
        } error] {
            tk_messageBox -type ok -icon error -title "Backup Error" -message \
                $errMsg
        }
    
        return
    }

SpecTcl/get_generic_options

SOURCE
    proc get_generic_options {} {
        global widgets Widget_data
    
        set opts "\n\t"
        foreach w [lsort $widgets] {
            upvar #0 sample_$w data
    
            append opts "\t"
            lappend opts $w
            set lst "\n\t\t"
            foreach i [lsort [array names data]] {
                append lst "\t"
                set value $data($i)
                if {[info exists Widget_data(infilter:$i)]} {
                    $Widget_data(infilter:$i) value
                }       
                lappend lst $i $value
                append lst "\n\t\t"
            }
            lappend opts $lst
            append opts "\n\t"
        }
        return $opts
    }

SpecTcl/get_file_data

SOURCE
    proc get_file_data {{start_widget ""}} {
        global Widgets _Message Id P Current Version
        global Widget_data Colors
    
        outline_inhibit 1
        set result ""
    
        append result \
            "$Id, version $Version, created:  [clock format [clock seconds]]\n"
        set_title $Current(project)
    
        # compute geometry options (fix padding name clash)
        blt_get .can geom
    
        set_frame_level .can.f
        set Widgets(f) 1
        set widget_list [lsort [array names Widgets]]
        if {$start_widget != ""} {
            set widget_list $start_widget
            set widget_list [concat $widget_list [get_children $start_widget]]
        }
        foreach item $widget_list {
            set _Message "saving $item"
            update
            append result "Widget $item\n"
    
            upvar #0 $item data
            if {$item == "f"} {
                widget_extract .can.f
                set data(Colors) $Colors
                set data(generic_options) [get_generic_options]
            } else {
                widget_extract .can.f.$item
            }
    
            set class $data(type)
            foreach i [lsort [array names data]] {
    
                # figure out what "type" of option we have
                # since {,i}pad[xy] are used both for geometry
                # and configuration, handle them specially
    
                # skip configuration values that are defaulted!
                # This doesn't catch equivalent forms of the
                # same value
    
                set skip 0
                foreach type "$class geometry table" {
                    if {![catch {set default $Widget_data(default:$type,$i)}]} {
                        set attrib $i
                        if {$item == "f"} {
                            set thisitem ""
                        } else {
                            set thisitem ".$item"
                        }
                        if {[regexp {highlight(.*)} $i dummy what]} {
                            set what [format %s%s \
                                [string toupper [string range $what 0 0]] \
                                [string range $what 1 end]]
                            set attrib "highlight$what"
                        }
                        
                        set defaultdb \
                            [option get .can.f$thisitem $attrib widgetDefault]
    
                        if {$defaultdb != ""} {
                            set default $defaultdb
                        }
                        if {([string compare [list $default] [list $data($i)]] ==0)
                            || ([string compare $default [list $data($i)]] == 0)} {
                            incr skip
                            break
                        }
                    }
                }
                if {$skip} {
                    continue
                }
                set map $i
                if {[info exists Widget_data(default:$class,$i)]} {
                    set type configure
                } elseif {[info exists geom(-$i)]} {
                    set type geometry
                } elseif {[string match *wad* $i]} {
                    set type geometry
                    regsub wad $i pad map
                } elseif {[string match *align* $i]} {
                    set type geometry
                    regsub align $i anchor map
                } elseif {"$i" == "master" && "$item" == "$start_widget"} {
                } else {
                    set type other
                }
    
                # run the input conversion filters
                set value $data($i)
                if {[info exists Widget_data(infilter:$i)]} {
                    $Widget_data(infilter:$i) value
                }
                append result \t[list $type $map $value]\n
            }
        }
        outline_inhibit 0
        return $result
    }

SpecTcl/compile_project

SOURCE
    proc compile_project {} {
        global Current P
    
        set _Message "Generating $P(include_suffix) code"
        update idletasks
        compile_$P(file_suffix) \
            [file join $P(project_dir) $Current(project).$P(file_suffix)] \
            [file join $P(project_dir) $Current(project).$P(target_suffix)]
    
        return
    }

SpecTcl/run_app

SOURCE
    proc run_app {name} {
        global _Message Widgets Current P
        # compute frame stacking and tabbing order
        set_frame_level .can.f
        
        set _Message "Starting test application"
        update idletasks
        
        set init {
            load {} Tk
            tk appname {test_%1$s}
            wm title . {SpecTcl - %1$s}
            bind . <Destroy> exit
            # wm protocol . WM_DELETE_WINDOW {after idle exit}
            wm protocol . WM_DELETE_WINDOW exit
            source {%2$s}
            %3$s
        }
        
        catch {test_interp eval exit}
        set test [interp create test_interp]
        interp alias $test exit {} exit_interp $test
        if {[file readable $name.$P(include_suffix)]} {
            set start "source \"$name.$P(include_suffix)\""
            set _Message "Starting \"$name.$P(include_suffix)\""
            update idletasks
        } else {
            set start  "[list ${name}_ui] ."
        }
        set user_code [format $init $name \
            [file join $P(project_dir) $name.$P(target_suffix)] $start]
        set result [catch {$test eval $user_code} msg]
        if {$result} {
            bgerror "Bug in user defined code:\n$msg"
        }
    }

SpecTcl/identify_levels

SOURCE
    proc identify_levels {{start .can.f} {level 0}} {
        dputs $start $level
        upvar \#0 [winfo name $start] data
        set data(level) $level
        incr level
        foreach qq [grid slaves $start] {
            if {[regexp {frame\#[0-9]$} $qq]} {
                set array [winfo name $qq]
                global $array
                set [set array](level) $level
                identify_levels $qq $level
            }
        }
    }

SpecTcl/sort_widgets2

SOURCE
    proc sort_widgets2 {w1 w2} {
        upvar #0 $w1 a $w2 b
        if {$a(type) != "frame" && $b(type) != "frame"} {
            return 0
        }
        if {$a(type) != "frame"} {
            return 1
        }
        if {$b(type) != "frame"} {
            return -1
        }
    
        # both frames look for child master relationship
    
        return [expr $a(level) - $b(level)]
    }

SpecTcl/save_if_dirty

SOURCE
    proc save_if_dirty {{askUser 1} {message ""} {type yesnocancel}} {
        global Current P
    
        check_project_file_exist
    
        if {$Current(dirty) == ""} {
            return 1
        }
    
        if {$askUser == 0} {
            set answer yes
        } else {
            if ![string comp $message ""] {
                set message \
                    "\"$Current(project)\" has been modified. Save all changes?"
            }
            set answer [tk_messageBox -message $message -type $type \
                    -icon warning]
        }
    
        switch -- $answer {
            yes {
                if $P(file_untitled) {
                    return [save_project_as]
                } else {
                    return [save_project [file join $P(project_dir) \
                            $Current(project).$P(file_suffix)]]
                }
            }
            no {
                return 1
            }
            cancel {
                return 0
            }
        }
    }