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
                }
            }
        }