New version of ProjMan
This commit is contained in:
svkalinin
@@ -1,694 +1,73 @@
|
||||
###########################################################
|
||||
# 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 #
|
||||
###########################################################
|
||||
######################################################
|
||||
# ProjMan 2
|
||||
# Distributed under GNU Public License
|
||||
# Author: Sergey Kalinin svk@nuk-svk.ru
|
||||
# Copyright (c) "", 2022, https://nuk-svk.ru
|
||||
######################################################
|
||||
#
|
||||
# All procedures module
|
||||
#
|
||||
######################################################
|
||||
|
||||
## 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 activeProject
|
||||
set v [FileDialog tree close_all]
|
||||
if {$v == "cancel"} {
|
||||
return
|
||||
global dir
|
||||
Config::write $dir(cfg)
|
||||
exit
|
||||
}
|
||||
|
||||
proc ViewFilesTree {} {
|
||||
global cfgVariables
|
||||
if {$cfgVariables(toolBarShow) eq "true"} {
|
||||
.frmBody.panel forget .frmBody.frmTree
|
||||
set cfgVariables(toolBarShow) false
|
||||
} 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 .]\""
|
||||
} elseif {[regexp -nocase -all -- {set workingProject} $line match]} {
|
||||
puts "set workingProject \"$activeProject\""
|
||||
puts $file1 "set workingProject \"$activeProject\""
|
||||
puts "Current project - $activeProject"
|
||||
} else {
|
||||
puts "> $line"
|
||||
puts $file1 "$line"
|
||||
}
|
||||
}
|
||||
exit
|
||||
.frmBody.panel insert 0 .frmBody.frmTree
|
||||
set cfgVariables(toolBarShow) true
|
||||
}
|
||||
}
|
||||
## 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
|
||||
# Enable/Disabled line numbers in editor
|
||||
proc ViewLineNumbers {} {
|
||||
global cfgVariables nbEditor
|
||||
# Changed global settigs
|
||||
if {$cfgVariables(lineNumberShow) eq "true"} {
|
||||
set cfgVariables(lineNumberShow) false
|
||||
} else {
|
||||
set file [lindex $fileList($node) 0]
|
||||
set cfgVariables(lineNumberShow) true
|
||||
}
|
||||
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
|
||||
}
|
||||
# apply changes for opened tabs
|
||||
foreach node [$nbEditor tabs] {
|
||||
$node.frmText.t configure -linemap $cfgVariables(lineNumberShow)
|
||||
}
|
||||
}
|
||||
|
||||
proc SelectDir {dir} {
|
||||
global projDir workDir openProjDir
|
||||
set dirName [tk_chooseDirectory -initialdir $dir\
|
||||
-title "[::msgcat::mc "Select directory"]"\
|
||||
-parent .]
|
||||
return $dirName
|
||||
proc Del {} {
|
||||
return
|
||||
}
|
||||
## 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
|
||||
|
||||
proc YScrollCommand {txt canv} {
|
||||
$txt yview
|
||||
$canv yview"
|
||||
}
|
||||
|
||||
proc ResetModifiedFlag {w} {
|
||||
global modified nbEditor
|
||||
$w.frmText.t edit modified false
|
||||
set modified($w) "false"
|
||||
set lbl [string trimleft [$nbEditor tab $w -text] "* "]
|
||||
puts "ResetModifiedFlag: $lbl"
|
||||
$nbEditor tab $w -text $lbl
|
||||
}
|
||||
proc SetModifiedFlag {w} {
|
||||
global modified nbEditor
|
||||
#$w.frmText.t edit modified false
|
||||
set modified($w) "true"
|
||||
set lbl [$nbEditor tab $w -text]
|
||||
puts "SetModifiedFlag: $w; $modified($w); >$lbl<"
|
||||
if {[regexp -nocase -all -- {^\*} $lbl match] == 0} {
|
||||
set lbl "* $lbl"
|
||||
}
|
||||
$nbEditor tab $w -text $lbl
|
||||
}
|
||||
|
||||
|
||||
## 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
|
||||
} elseif {($ext == "sh")} {
|
||||
HighLightSHELL $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
|
||||
}
|
||||
|
||||
# Get system command name from PATH environment variable
|
||||
proc GetSystemCommand {} {
|
||||
global tcl_platform env systemCmdList
|
||||
switch -exact -- $tcl_platform(platform) {
|
||||
"unix" {
|
||||
foreach path [split $env(PATH) ":"] {
|
||||
foreach commandName [lsort [glob -nocomplain [file join $path *]]] {
|
||||
lappend systemCmdList [file tail $commandName]
|
||||
}
|
||||
}
|
||||
}
|
||||
"windows" {
|
||||
foreach path [split $env(PATH) ";"] {
|
||||
foreach commandName [lsort [glob -nocomplain [file join $path *]]] {
|
||||
lappend systemCmdList [file tail $commandName]
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
Reference in New Issue
Block a user