projman/lib/procedure.tcl

###########################################################
#                Tcl/Tk Project Manager                   #
#                 Distributed under GPL                   #
#                  all procedure file                     #
# Copyright (c) "Sergey Kalinin", 2001, http://nuk-svk.ru  #
# Author: Sergey Kalinin banzaj28@yandex.ru       #
###########################################################

## INSERT TEXT INTO ENTRY BOmX ##
proc InsertEnt {entry text} {
    $entry delete 0 end
    $entry insert end $text
}

## GET TEXT FROM ENTRY WIDGET ##
proc Text {entry} {
    set text [$entry get]
}
## FONT SELECTOR DIALOG ##
proc SelectFontDlg {font text} {
    set font [SelectFont .fontdlg -parent . -font $font]
    if { $font != "" } {
        InsertEnt $text $font
    }
}
## STATUS BAR OR ANYTHING LABEL TEXT UPDATE ##
proc LabelUpdate {widget value} {
    global fontNormal
    $widget configure -text $value -font $fontNormal
}
proc PopupMenuEditor {x y} {
    tk_popup .popMnuEdit $x $y
}
## GETTING FILE ATTRIBUTES ##
proc FileAttr {file} {
    global tcl_platform
    set fileAttribute ""
    # get file modify time
    if {$tcl_platform(platform) == "windows"} {
        set unixTime [file mtime $file]
        set modifyTime [clock format $unixTime -format "%d/%m/%Y, %H:%M"]
        append fileAttribute $modifyTime
    } elseif {$tcl_platform(platform) == "mac"} {
        
    } elseif {$tcl_platform(platform) == "unix"} {
        set unixTime [file mtime $file]
        set modifyTime [clock format $unixTime -format "%d/%m/%Y, %H:%M"]
        append fileAttribute $modifyTime
    }
    # get file size
    set size [file size $file]
    if {$size < 1024} {
        set fileSize "$size b"
    }
    if {$size >= 1024} {
        set s [expr ($size.0) / 1024]
        set dot [string first "\." $s]
        set int [string range $s 0 [expr $dot - 1]]
        set dec [string range $s [expr $dot + 1] [expr $dot + 2]]
        set fileSize "$int.$dec Kb"
    }
    if {$size >= 1048576} {
        set s [expr ($size.0) / 1048576]
        set dot [string first "\." $s]
        set int [string range $s 0 [expr $dot - 1]]
        set dec [string range $s [expr $dot + 1] [expr $dot + 2]]
        set fileSize "$int.$dec Mb"
    }
    append fileAttribute ", $fileSize"
}

## CLOSE FILE ##
proc CloseFile {} {
    global docDir imgDir tree noteBook ver fontNormal node
    set w [$noteBook itemcget page option insert end settings -text [::msgcat::mc "Settings"]]
    
    $noteBook  raise settings
}
## GET LOCALE NAMES FROM MESSAGES FILE ##
proc GetLocale {} {
    global msgDir localeList
    set localeList ""
    if {[catch {cd $msgDir}] != 0} {
        return ""
    }
    foreach file [lsort [glob -nocomplain *.msg]] {
        lappend localeList [list [file rootname $file]]
    }
    return $localeList
}
## MAKING TAR ARCHIVE ##
proc MakeTGZ {} {
    global activeProject tgzDir tgzNamed workDir projDir env tcl_platform
    if {$activeProject == ""} {
        set answer [tk_messageBox\
                -message [::msgcat::mc "Not found active project"]\
                -type ok -icon warning\
                -title [::msgcat::mc "Warning"]]
        case $answer {
            ok {return 0}
        }
    }
    FileDialog tree save_all
    set file [open [file join $workDir $activeProject.proj] r]
    while {[gets $file line]>=0} {
        scan $line "%s" keyWord
        set string [string range $line [string first "\"" $line] [string last "\"" $line]]
        set string [string trim $string "\""]
        if {$keyWord == "ProjectDirName"} {
            set dir "$string"
        }  
        if {$keyWord == "ProjectVersion"} {
            set version "$string"
        }  
        if {$keyWord == "ProjectRelease"} {
            set release "$string"
        }  
    }
    close $file
    set res [split $tgzNamed "-"]
    set name [lindex $res 0]
    set ver [lindex $res 1]
    set rel [lindex $res 2]
    if {$name == "projectName"} {
        set name $activeProject
    }
    if {$ver == "version"} {
        append name "-$version"
    }
    if {$rel == "release"} {
        append name "-$release"
    }
    # multiplatform featuring #
    if {$tcl_platform(platform) == "windows"} {
        append name ".zip"
    } elseif {$tcl_platform(platform) == "mac"} {
        append name ".zip"
    } elseif {$tcl_platform(platform) == "unix"} {
        append name ".tar.gz"
    }
    catch {cd $projDir} res
    if {[file exists [file join $tgzDir $name]] == 1} {
        set answer [tk_messageBox\
                -message "[::msgcat::mc "File already exists. Overwrite?"] \"$name\" ?"\
                -type yesno -icon question -default yes\
                -title [::msgcat::mc "Question"]]
        case $answer {
            yes {file delete [file join $tgzDir $name]}
            no {return 0}
        }
    }
    # multiplatform featuring #
    if {$tcl_platform(platform) == "windows"} {
        catch [exec pkzip -r -p [file join $tgzDir $name] [file join $activeProject *]] err
    } elseif {$tcl_platform(platform) == "mac"} {
        catch [exec zip -c [file join $tgzDir $name] $activeProject] err
    } elseif {$tcl_platform(platform) == "unix"} {
        catch [exec tar -czvf [file join $tgzDir $name] $activeProject] err
    }
    # message dialog #
    set msg "[::msgcat::mc "Archive created in"] [file join $tgzDir $name]"
    set icon info
    set answer [tk_messageBox\
            -message "$msg"\
            -type ok -icon $icon]
            case $answer {
        ok {return 0}
    }
}

## MAKING RPM ##
proc MakeRPM {} {
    global activeProject tgzDir tgzNamed workDir projDir env tcl_platform

    set answer [tk_messageBox\
            -message "[::msgcat::mc "Not implemented yet"]"\
            -type ok -icon info]
    case $answer {
        ok {return 0}
    }


    if {$activeProject == ""} {
        set answer [tk_messageBox\
                -message "[::msgcat::mc "Not found active project"]"\
                -type ok -icon warning -title [::msgcat::mc "Warning"]]
        case $answer {
            ok {return 0}
        }
    }

    set file [open [file join $workDir $activeProject.proj] r]
    while {[gets $file line]>=0} {
        scan $line "%s" keyWord
        set string [string range $line [string first "\"" $line] [string last "\"" $line]]
        set string [string trim $string "\""]
        if {$keyWord == "ProjectDirName"} {
            set dir "$string"
        }  
        if {$keyWord == "ProjectVersion"} {
            set version "$string"
        }  
        if {$keyWord == "ProjectRelease"} {
            set release "$string"
        }  
    }
    close $file
    set res [split $tgzNamed "-"]
    set name [lindex $res 0]
    set ver [lindex $res 1]
    set rel [lindex $res 2]
    if {$name == "projectName"} {
        set name $activeProject
    }
    if {$ver == "version"} {
        append name "-$version"
    }
    if {$rel == "release"} {
        append name "-$release"
    }
    append name ".tar.gz"
    catch {cd $projDir} res
    if {[file exists $tgzDir/$name] == 1} {
        set answer [tk_messageBox\
                -message "[::msgcat::mc "File already exists. Overwrite?"] \"$name\" ?"\
                -type yesno -icon question -default yes]
        case $answer {
            yes {file delete $tgzDir/$name}
            no {return 0}
        }
    }
    catch [exec tar -czvf $tgzDir/$name $activeProject] pipe
}

## PROGRESS DIALOG ##
proc Progress {oper} {
    global progval
    if {$oper == "start"} {
        set prg [ProgressBar .frmStatus.frmProgress.lblProgress.progress\
                -variable progval -type infinite -borderwidth 0]
        pack $prg -side left -fill both -expand true
    } elseif {$oper == "stop"} {
        destroy .frmStatus.frmProgress.lblProgress.progress
    }
    #    ProgUpdate
}
proc ProgUpdate { } {
    global progval
    set progval 5
}

## SHOW HELP WINDOW ##
proc ShowHelp {} {
    global dataDir
    if {[winfo exists .help] == 1} {
        focus -force .help
        raise .help
    } else {
        TopLevelHelp
    }
    if {[catch {set word [selection get]} error] != 0} {
        set word " "
    } else {
        puts $word
        TopLevelHelp
        SearchWord $word
    }
}

## EXEC EXTERNAL BROWSER AND GOTO URL ##
proc GoToURL {url} {
    global env tcl_platform
    if {$tcl_platform(platform) == "windows"} {
        set pipe [open "|iexplore $url" "r"]
    } elseif {$tcl_platform(platform) == "mac"} {
        set pipe [open "|iexplore $url" "r"]
    } elseif {$tcl_platform(platform) == "unix"} {
        #$env(BROWSER)
        #set pipe [open "|$env(BROWSER) $url" "r"]
        launchBrowser $url
        return
    }
    fileevent $pipe readable
    fconfigure $pipe -buffering none -blocking no
}

proc launchBrowser {url} {
    global tcl_platform
    if {$tcl_platform(platform) eq "windows"} {
        set command [list {*}[auto_execok start] {}]
        if {[file isdirectory $url]} {
            set url [file nativename [file join $url .]]
        }
    } elseif {$tcl_platform(os) eq "Darwin"} {
        set command [list open]
    } else {
        set command [list xdg-open]
    }
    exec {*}$command $url &
}

## SEND EMAIL PROCEDURE ##
proc SendEmail {mail} {
    global env tcl_platform
    if {$tcl_platform(platform) == "windows"} {
    } elseif {$tcl_platform(platform) == "mac"} {
    } elseif {$tcl_platform(platform) == "unix"} {
        set pipe [open "|xdg-open $mail" "r"]
        fileevent $pipe readable
        fconfigure $pipe -buffering none -blocking no
    }
}
## QUIT PROJECT MANAGER PROCEDURE ##
proc Quit {} {
    global workDir
    set v [FileDialog tree close_all]
    if {$v == "cancel"} {
        return
    } else {
        # copy projman.conf file and rewrite them 
        # open projman.conf file and write current main window geometry
        file copy -force [file join $workDir projman.conf] [file join $workDir projman.conf.old]
        set file [open [file join $workDir projman.conf.old] RDONLY]
        set file1 [open [file join $workDir projman.conf] WRONLY]
        while {[gets $file line]>=0} {
            if {[regexp -nocase -all -- {set topLevelGeometry} $line match]} {
                puts $file1 "set topLevelGeometry \"[winfo geometry .]\""
            } else {
                puts $file1 "$line"
            }
        }
        exit
    }
}
## PRINT DIALOG ##
proc PrintDialog {} {
    global fontNormal fontBold selectPrint
    set wp .print
    # destroy the print window if it already exists
    if {[winfo exists $wp]} {
        destroy $wp
    }
    # create the new "find" window
    toplevel $wp
    wm transient $wp .
    wm title $wp [::msgcat::mc "Print ..."]
    wm resizable $wp 0 0
    frame $wp.frmLbl
    frame $wp.frmEnt
    frame $wp.frmField
    frame $wp.frmBtn
    pack $wp.frmLbl $wp.frmEnt $wp.frmField $wp.frmBtn -side top -fill x
    label $wp.frmLbl.lblPrint -text [::msgcat::mc "Print command"] -font $fontNormal
    pack $wp.frmLbl.lblPrint -fill x -expand true -padx 2
    entry $wp.frmEnt.entPrint -font $fontNormal
    pack $wp.frmEnt.entPrint -fill x -expand true -padx 2
    
    checkbutton $wp.frmField.chkSelect -text [::msgcat::mc "Print selected text"] -variable selectPrint\
    -font $fontNormal -onvalue true -offvalue false ;#-command Check
    pack $wp.frmField.chkSelect -fill x -expand true -padx 2
    
    button $wp.frmBtn.btnPrint -text [::msgcat::mc "Print"] -font $fontNormal -width 12 -relief groove\
    -command {
        Print [.print.frmEnt.entPrint get]
        destroy .print
    }
    button $wp.frmBtn.btnCancel -text [::msgcat::mc "Cancel"] -font $fontNormal -width 12 -relief groove\
    -command "destroy .print"
    pack $wp.frmBtn.btnPrint $wp.frmBtn.btnCancel -side left -padx 2 -pady 2 -fill x -expand true
    InsertEnt $wp.frmEnt.entPrint "lpr"
    bind $wp <Escape> "destroy .print"
}
## PRINT COMMAND ##
proc Print {command} {
    global noteBook fontNormal fontBold fileList selectPrint tmpDir
    set node [$noteBook raise]
    set text "$noteBook.f$node.frame.text"
    set command lpr

    if {$node == "newproj" || $node == "settings" || $node == "about" || $node == ""} {
        set answer [tk_messageBox\
                -message "[::msgcat::mc "Don't selected file"]"\
                -type ok -icon warning\
                -title [::msgcat::mc "Warning"]]
                case $answer {
            ok {return 0}
        }
    }
    if {$selectPrint == "true"} {
        set selIndex [$text tag ranges sel]
        set start [lindex $selIndex 0]
        set end [lindex $selIndex 1]
        set prnText [$text get $start $end]
        set file [file join $tmpDir projprn.tmp]
        set f [open $file "w"]
        puts $f $prnText
        close $f
    } else {
        set file [lindex $fileList($node) 0]
    }
    set pipe [open "|$command $file" "r"]
    fileevent $pipe readable
    fconfigure $pipe -buffering none -blocking no
}

## GETTING EXTERNAL MODULES ##
proc Modules {} {
    global tcl_platform
    global module tclDir dataDir binDir
    # TkDIFF loading
    foreach m {tkcvs tkdiff gitk tkregexp} {
        if {$tcl_platform(platform) == "unix"} {
            if {$m == "tkregexp"} {
                set module($m) "[file join $binDir tkregexp.tcl]"
                break
            }
            set string [exec whereis $m]
            scan $string "%s%s" v module($m)
            if {[info exists module($m)] &&  [file isdirectory $module($m)] == 0} {
                puts "Find $module($m)"
            } else {
                set module($m) ""
            }
        }
    }
}
## RUNNING MODULE ##
proc DoModule {mod} {
    global tcl_platform
    global module activeProject projDir tree tclDir dataDir workDir
    if {$activeProject == ""} {
        set answer [tk_messageBox\
        -message "[::msgcat::mc "Not found active project"]"\
        -type ok -icon warning\
        -title [::msgcat::mc "Warning"]]
        case $answer {
            ok {return 0}
        }
    }
    set file [open [file join $workDir $activeProject.proj] r]
    while {[gets $file line]>=0} {
        scan $line "%s" keyWord
        set string [string range $line [string first "\"" $line] [string last "\"" $line]]
        set string [string trim $string "\""]
        if {$keyWord == "ProjectName"} {
            set projName "$string"
        }
        if {$keyWord == "ProjectFileName"} {
            set projFileName "$string"
        }
        if {$keyWord == "ProjectDirName"} {
            set dir "$string"
        }  
        if {$keyWord == "ProjectCompiler"} {
            set projCompiler "$string"
        }  
        if {$keyWord == "ProjectInterp"} {
            set projInterp "$string"
        }  
    }
    close $file
    
    #puts "project dir - $dir"
    
    set curDir [pwd]
    case $mod {
        tkcvs {
            set pipe [open "|$module(tkcvs) -dir $dir" "r"]
            fileevent $pipe readable
            fconfigure $pipe -buffering none -blocking no
        }
        tkdiff {
            set files [$tree selection get]
            if {[llength $files] == 0} {
                set answer [tk_messageBox\
                -message "[::msgcat::mc "Don't selected file"]"\
                -type ok -icon warning\
                -title [::msgcat::mc "Warning"]]
                case $answer {
                    ok {return 0}
                }
            }
            if {[llength $files] == 1} {
                if {$files != ""} {
                    set file1 [$tree itemcget $files -data]
                }
                set command "-r $file1"
            }
            if {[llength $files] == 2} {
                if {[lindex $files 0] != ""} {
                    set file1 [$tree itemcget [lindex $files 0] -data]
                }
                if {[lindex $files 1] != ""} {
                    set file2 [$tree itemcget [lindex $files 1] -data]
                }
                set command "$file1 $file2"
            } 
            if {[llength $files] > 2} {
                set answer [tk_messageBox\
                -message "[::msgcat::mc "Must be one or two file select!"]"\
                -type ok -icon info\
                -title [::msgcat::mc "Warning"]]
                case $answer {
                    ok {return 0}
                }
            }
            set pipe [open "|$module(tkdiff) $command" "r"]
            fileevent $pipe readable
            fconfigure $pipe -buffering none -blocking no
        }
        tkregexp {
            set files [$tree selection get]
            if {[llength $files] == 0} {
                set command ""
            } elseif {[llength $files] == 1} {
                if {$files != ""} {
                    set file [$tree itemcget $files -data]
                }
                set command "$file"
            } else {
                set answer [tk_messageBox\
                -message "[::msgcat::mc "Must be one file select!"]"\
                -type ok -icon info\
                -title [::msgcat::mc "Warning"]]
                case $answer {
                    ok {return 0}
                }
            }
            puts "$module(tkregexp) $command"
            set pipe [open "|$module(tkregexp) $command" "r"]
            fileevent $pipe readable
            fconfigure $pipe -buffering none -blocking no
        }
        gitk {
            cd $dir
            #puts "========== $projDir $dir $curDir"
            set pipe [open "|$module(gitk)" "r"]
            fileevent $pipe readable
            fconfigure $pipe -buffering none -blocking no
        }
    }
}

proc SelectDir {dir} {
    global projDir workDir openProjDir
    set dirName [tk_chooseDirectory -initialdir $dir\
    -title "[::msgcat::mc "Select directory"]"\
        -parent .]
    return $dirName
}
## TOOLBAR ON/OFF PROCEDURE ##
proc ToolBar {} {
    global toolBar
    if {$toolBar == "Yes"} {
        CreateToolBar
    } elseif {$toolBar == "No"} {
        destroy .frmTool.btnNew .frmTool.btnSave .frmTool.btnSaveAs .frmTool.btnSaveAll\
                .frmTool.btnCopy .frmTool.btnPaste .frmTool.btnCut .frmTool.btnDo .frmTool.btnPrint\
                .frmTool.btnDoFile .frmTool.btnTGZ .frmTool.btnHelp .frmTool.btnClose
        .frmTool configure -height 1
    }
}


## LOADING HIGHLIGHT FILES ##
proc HighLight {ext text line lineNumber node} {
    global font tree color noteBook hlDir
    
    if {[file exists [file join $hlDir $ext.tcl]] == 1} {
        HighLight[string toupper $ext] $text $line $lineNumber $node
    } elseif {($ext == "htm") || ($ext == "xml") || ($ext == "fm") || ($ext == "html")} {
        HighLightHTML $text $line $lineNumber $node
    } elseif {($ext == "pl")} {
        HighLightPERL $text $line $lineNumber $node
    } elseif {($ext == "for")} {
        HighLightFORTRAN $text $line $lineNumber $node
    } elseif {($ext == "ml") || ($ext == "mli")} {
        HighLightML $text $line $lineNumber $node
    } elseif {($ext == "rvt") || ($ext == "tml")} {
        HighLightRIVET $text $line $lineNumber $node
    } elseif {($ext == "php") || ($ext == "phtml")} {
        HighLightPHP $text $line $lineNumber $node
    } elseif {($ext == "rb")} {
        HighLightRUBY $text $line $lineNumber $node
    } else {
        HighLightTCL $text $line $lineNumber $node
    }
}

## GET IMAGE FOR tree AND notebook WIDGETS ##
proc GetImage {fileName} {
    global imgDir
    if {[file isdirectory $fileName] == 1} {
        set img "folder"
        set data "dir"
    } elseif {[string match "*.tcl" $fileName] == 1} {
        set img "tcl"
        set data "src"
    } elseif {[string match "*.tk" $fileName] == 1} {
        set img "tk"
        set data "src"
    } elseif {[string match "*.rvt" $fileName] == 1} {
        set img "rvt"
        set data "src"
    } elseif {[string match "*.tex" $fileName] == 1} {
        set img "tex"
        set data "src"
    } elseif {[string match "*.html" $fileName] == 1 || [string match "*.htm" $fileName] == 1} {
        set img "html"
        set data "src"
    } elseif {[string match "*.gif" $fileName] == 1 || [string match "*.xpm" $fileName] == 1 || \
    [string match "*.png" $fileName] == 1 || [string match "*.jpg" $fileName] == 1 || \
    [string match "*.xbm" $fileName] == 1 || [string match "*.jpeg" $fileName] == 1 || \
    [string match "*.bmp" $fileName] == 1} {
        set img "img"
        set data "img"
    } elseif {[string match "*.xml" $fileName] == 1} {
        set img "xml"
        set data "xml"
    } elseif {[string match "*.java" $fileName] == 1 || [string match "*.ja" $fileName] == 1} {
        set img "java"
        set data "src"
    } elseif {[string match "*.c" $fileName] == 1} {
        set img "c"
        set data "src"
    } elseif {[string match "*.cpp" $fileName] == 1} {
        set img "cpp"
        set data "src"
    } elseif {[string match "*.spec" $fileName] == 1} {
        set img "rpm"
        set data "src"
    } elseif {[string match "*.pl" $fileName] == 1} {
        set img "perl"
        set data "src"
    } elseif {[string match "*.for" $fileName] == 1 || [string match "*.f" $fileName] == 1} {
        set img "fortran"
        set data "src"
    } elseif {[string match "*.ml" $fileName] == 1 || [string match "*.mli" $fileName] == 1} {
        set img "caml"
        set data "src"
    } elseif {[string match "*.tml" $fileName] == 1 || [string match "*.rvt" $fileName] == 1} {
        set img "tclhtml"
        set data "src"
    } elseif {[string match "*.php" $fileName] == 1 || [string match "*.phtml" $fileName] == 1} {
        set img "php"
        set data "src"
    } elseif {[string match "*.rb" $fileName] == 1} {
        set img "ruby"
        set data "src"
    } else {
        set img "file"
        set data "txt"
    }    
    return $img
}

proc GetExtention {node} {
    global fileList
    set ext [string range [file extension [file tail [lindex $fileList($node) 0]]] 1 end]
    return $ext
}