Gabriele Cosmo
548 lines
14 KiB
PSL
548 lines
14 KiB
PSL
## Public.proc
|
|
## (Momo, GGE, GAG, FB procedure)
|
|
# File List window model
|
|
#
|
|
# This must be revised to have better display of the file's path
|
|
# The absolute path is displayed so that it demands too large width.
|
|
# 1998 7 5 displaying $w.info.label1 only the currect dir name
|
|
##
|
|
## k.ohtubo(Tubocky)
|
|
##
|
|
## 1998.3.17
|
|
## Tcl/Tk version 8.0
|
|
## 1998 July 5 GEANT4 Beta-01
|
|
|
|
proc File_List_Skeleton w {
|
|
global env
|
|
|
|
if [winfo exists $w] {
|
|
raise $w
|
|
focus $w.name.ent
|
|
return
|
|
}
|
|
|
|
toplevel $w -highlightthickness 0
|
|
|
|
|
|
frame $w.butt -highlightthickness 0
|
|
pack $w.butt -side top -fill x
|
|
|
|
button $w.butt.b0 -text O.K. -bd 3 -highlightthickness 0
|
|
button $w.butt.b1 -text Clear -bd 3 -highlightthickness 0
|
|
button $w.butt.b2 -text Cancel -bd 3 -highlightthickness 0
|
|
pack $w.butt.b0 $w.butt.b1 $w.butt.b2 -side left
|
|
|
|
|
|
frame $w.info -highlightthickness 0
|
|
pack $w.info -side top -fill x
|
|
|
|
label $w.info.label0 -text "Current Dir:" -anchor w \
|
|
-highlightthickness 0
|
|
pack $w.info.label0 -side left
|
|
|
|
set END [string length $env(HOME)]
|
|
set Path ~[string range $env(G_PATH) $END end]
|
|
## cut out the current dir
|
|
set dlist [file split $Path]
|
|
set cdir [lindex $dlist end]
|
|
##supress label $w.info.label1 -text $Path -anchor w -highlightthickness 0
|
|
label $w.info.label1 -text $cdir -anchor w -highlightthickness 0
|
|
pack $w.info.label1 -side left -fill x -expand 1
|
|
|
|
|
|
frame $w.name -highlightthickness 0
|
|
pack $w.name -side top -fill x
|
|
|
|
label $w.name.label -text File -highlightthickness 0
|
|
pack $w.name.label -side left
|
|
|
|
entry $w.name.ent -highlightthickness 0
|
|
pack $w.name.ent -side left -fill x -expand 1
|
|
|
|
|
|
frame $w.select -highlightthickness 0
|
|
pack $w.select -side top -fill both
|
|
|
|
listbox $w.select.list -width 20 -height 20 \
|
|
-yscrollcommand "$w.select.scroll set" \
|
|
-highlightthickness 0
|
|
pack $w.select.list -side left -fill both -expand 1
|
|
|
|
scrollbar $w.select.scroll -command "$w.select.list yview" \
|
|
-highlightthickness 0
|
|
pack $w.select.scroll -side left -fill y
|
|
|
|
focus $w.name.ent
|
|
}
|
|
|
|
# Change Path (Like Unix command "cd")
|
|
proc Change_Path DIR {
|
|
global env
|
|
|
|
if {![info exists env(G_PATH)]} {
|
|
Message_Skeleton -icon warning -button O.K. \
|
|
-message "Warning!\nCheck \"G_PATH\" value."
|
|
.msgskeleton.butt.0 configure -command {destroy .msgskeleton}
|
|
return
|
|
}
|
|
|
|
set DIR [string trimright $DIR "/"]
|
|
|
|
if {$DIR == "\."} {
|
|
return $env(G_PATH)
|
|
}
|
|
if {$DIR == "\.\."} {
|
|
set END [expr [string last "/" $env(G_PATH)] -1]
|
|
set env(G_PATH) [string range $env(G_PATH) 0 $END]
|
|
return $env(G_PATH)
|
|
}
|
|
|
|
if {![file isdirectory $env(G_PATH)/$DIR]} {
|
|
return It_is_file
|
|
}
|
|
|
|
foreach l [glob $env(G_PATH)/*/] {
|
|
set l [string trimright $l "/"]
|
|
set END [expr [string last "/" $l] + 1]
|
|
set l [string range $l $END end]
|
|
if {$DIR == $l} {
|
|
set env(G_PATH) $env(G_PATH)/$DIR
|
|
return $env(G_PATH)
|
|
}
|
|
}
|
|
|
|
return It_is_file
|
|
}
|
|
|
|
# Putout File name List
|
|
proc Put_File_List w {
|
|
global env
|
|
|
|
if {![winfo exists $w.select.list]} {
|
|
Message_Skeleton -icon warning -button O.K. \
|
|
-message "Warning!\nWhat's happen?"
|
|
.msgskeleton.butt.0 configure -command {destroy .msgskeleton}
|
|
return
|
|
}
|
|
|
|
$w.select.list delete 0 end
|
|
foreach l [glob $env(G_PATH)/\.* $env(G_PATH)/*] {
|
|
set END [expr [string last "/" $l] + 1]
|
|
if {[file isdirectory $l]} {
|
|
set l $l/
|
|
}
|
|
set l [string range $l $END end]
|
|
$w.select.list insert end $l
|
|
}
|
|
}
|
|
|
|
# Define window size
|
|
proc Win_Size w {
|
|
update
|
|
wm geometry $w {}
|
|
scan [wm geometry $w] %dx%d WIDTH HEIGHT
|
|
wm minsize $w $WIDTH $HEIGHT
|
|
}
|
|
|
|
# Change Font on window
|
|
proc Change_Font {FONT WIDGET} {
|
|
global errorCode errorInfo
|
|
if {![catch {winfo children $WIDGET} LIST]} {
|
|
foreach w $LIST {
|
|
Change_Font $FONT $w
|
|
}
|
|
} else {
|
|
if {$errorCode != "NONE"} {
|
|
set errorCode NONE
|
|
}
|
|
if {$errorInfo != ""} {
|
|
set errorInfo ""
|
|
}
|
|
return
|
|
}
|
|
foreach w $LIST {
|
|
catch {eval $w configure -font "$FONT"}
|
|
}
|
|
catch {eval $WIDGET configure -font "$FONT"}
|
|
|
|
if {$errorCode != "NONE"} {
|
|
set errorCode NONE
|
|
}
|
|
if {$errorInfo != ""} {
|
|
set errorInfo ""
|
|
}
|
|
}
|
|
|
|
# Scroll Link
|
|
proc Scroll_Link {WIDGET args} {
|
|
foreach w [split $WIDGET] {
|
|
eval $w yview $args
|
|
}
|
|
}
|
|
|
|
# Change Color on window(FG BG)
|
|
proc Change_Color {F B WIDGET} {
|
|
global errorCode errorInfo
|
|
if {![catch {winfo children $WIDGET} LIST]} {
|
|
foreach w $LIST {
|
|
Change_Color $F $B $w
|
|
}
|
|
} else {
|
|
if {$errorCode != "NONE"} {
|
|
set errorCode NONE
|
|
}
|
|
if {$errorInfo != ""} {
|
|
set errorInfo ""
|
|
}
|
|
return
|
|
}
|
|
foreach w $LIST {
|
|
catch {$w configure -foreground $F}
|
|
catch {$w configure -background $B}
|
|
}
|
|
catch {$WIDGET configure -foreground $F}
|
|
catch {$WIDGET configure -background $B}
|
|
|
|
if {$errorCode != "NONE"} {
|
|
set errorCode NONE
|
|
}
|
|
if {$errorInfo != ""} {
|
|
set errorInfo ""
|
|
}
|
|
}
|
|
|
|
# Check value (int,double,boolean,string)
|
|
proc Value_Check {TYPE VALUE} {
|
|
switch $TYPE {
|
|
int -
|
|
i { if {[regexp {^[+-]?0x[0-9a-fA-F]+$} $VALUE] || \
|
|
[regexp {^[+-]?0x[0-9a-fA-F]+\.$} $VALUE] || \
|
|
[regexp {^[+-]?0x[0-9a-fA-F]*\.[0-9a-fA-F]+$} $VALUE] || \
|
|
[regexp {^[+-]?0x[0-9a-fA-F]+\.?[eE][+-]?[0-9a-fA-F]+$} $VALUE] || \
|
|
[regexp {^[+-]?0x[0-9a-fA-F]*\.[0-9a-fA-F]+[eE][+-]?[0-9a-fA-F]+$} $VALUE]} {
|
|
set ANSWER [tk_messageBox -type yesnocancel -icon question \
|
|
-message "This value $VALUE is hexadecimal.\nChange to [expr $VALUE]?"]
|
|
switch $ANSWER {
|
|
yes { return [Value_Check $TYPE [expr $VALUE]]}
|
|
no { if {[string index $VALUE 0] != "0"} {
|
|
set FLAG [string index $VALUE 0]
|
|
} else {
|
|
set FLAG ""
|
|
}
|
|
set HEAD [expr [string first 0x $VALUE] + 2]
|
|
set VALUE $FLAG[string range $VALUE $HEAD end]
|
|
return [Value_Check $TYPE $VALUE]
|
|
}
|
|
cancel {return ERROR}
|
|
}
|
|
} elseif {[regexp {^[+-]?0[0-7]+$} $VALUE] || \
|
|
[regexp {^[+-]?0[0-7]+\.$} $VALUE] || \
|
|
[regexp {^[+-]?0[0-7]+\.[0-7]+$} $VALUE] || \
|
|
[regexp {^[+-]?0[0-7]+\.?[eE][+-]?[0-7]+$} $VALUE] || \
|
|
[regexp {^[+-]?0[0-7]+\.[0-7]+[eE][+-]?[0-7]+$} $VALUE]} {
|
|
if {[string index $VALUE 0] != "0"} {
|
|
set FLAG [string index $VALUE 0]
|
|
set VALUE [string range $VALUE 1 end]
|
|
} else {
|
|
set FLAG ""
|
|
}
|
|
set ANSWER [tk_messageBox -type yesnocancel -icon question \
|
|
-message "This value $VALUE is octal.\nChange to [expr $VALUE]?"]
|
|
switch $ANSWER {
|
|
yes { return [Value_Check $TYPE $FLAG[expr $VALUE]]}
|
|
no { while {[string index $VALUE 0] == "0"} {
|
|
set VALUE [string range $VALUE 1 end]
|
|
}
|
|
return [Value_Check $TYPE $FLAG$VALUE]
|
|
}
|
|
cancel {return ERROR}
|
|
}
|
|
} elseif {[regexp {^[+-]?0[0-9]+$} $VALUE] || \
|
|
[regexp {^[+-]?0[0-9]+\.$} $VALUE] || \
|
|
[regexp {^[+-]?0[0-9]+\.[0-9]+$} $VALUE] || \
|
|
[regexp {^[+-]?0[0-9]+\.?[eE][+-]?[0-9]+$} $VALUE] || \
|
|
[regexp {^[+-]?0[0-9]+\.[0-9]+[eE][+-]?[0-9]+$} $VALUE]} {
|
|
if {[string index $VALUE 0] != "0"} {
|
|
set FLAG [string index $VALUE 0]
|
|
set VALUE [string range $VALUE 1 end]
|
|
} else {
|
|
set FLAG ""
|
|
}
|
|
while {[string index $VALUE 0] == "0"} {
|
|
set VALUE [string range $VALUE 1 end]
|
|
}
|
|
return [Value_Check $TYPE $FLAG$VALUE]
|
|
} elseif {[regexp {^[+-]?[0-9]+\.$} $VALUE] || \
|
|
[regexp {^[+-]?[0-9]*\.[0-9]+$} $VALUE] || \
|
|
[regexp {^[+-]?[0-9]+\.?[eE][+-]?[0-9]+$} $VALUE] || \
|
|
[regexp {^[+-]?[0-9]*\.[0-9]+[eE][+-]?[0-9]+$} $VALUE]} {
|
|
set ANSWER [tk_messageBox -type yesnocancel -icon question \
|
|
-message "This value is $VALUE.\nType is $TYPE.\nChange to integer?"]
|
|
switch $ANSWER {
|
|
yes { return [Value_Check $TYPE [expr int($VALUE)]]}
|
|
no { return ERROR}
|
|
cancel {return ERROR}
|
|
}
|
|
} elseif {[regexp {^[+-]?[0-9]+$} $VALUE]} {
|
|
return $VALUE
|
|
} else {
|
|
tk_messageBox -type ok -icon question \
|
|
-message "Check!\nParameter type doesn't match."
|
|
return ERROR
|
|
}
|
|
}
|
|
double -
|
|
d { if {[regexp {^[+-]?0x[0-9a-fA-F]+$} $VALUE] || \
|
|
[regexp {^[+-]?0x[0-9a-fA-F]+\.$} $VALUE] || \
|
|
[regexp {^[+-]?0x[0-9a-fA-F]*\.[0-9a-fA-F]+$} $VALUE] || \
|
|
[regexp {^[+-]?0x[0-9a-fA-F]+\.?[eE][+-]?[0-9a-fA-F]+$} $VALUE] || \
|
|
[regexp {^[+-]?0x[0-9a-fA-F]*\.[0-9a-fA-F]+[eE][+-]?[0-9a-fA-F]+$} $VALUE]} {
|
|
set ANSWER [tk_messageBox -type yesnocancel -icon question \
|
|
-message "This value $VALUE is hexadecimal.\nChange to [expr $VALUE]?"]
|
|
switch $ANSWER {
|
|
yes { return [Value_Check $TYPE [expr $VALUE]]}
|
|
no { if {[string index $VALUE 0] != "0"} {
|
|
set FLAG [string index $VALUE 0]
|
|
} else {
|
|
set FLAG ""
|
|
}
|
|
set HEAD [expr [string first 0x $VALUE] + 2]
|
|
set VALUE $FLAG[string range $VALUE $HEAD end]
|
|
return [Value_Check $TYPE $VALUE]
|
|
}
|
|
cancel {return ERROR}
|
|
}
|
|
} elseif {[regexp {^[+-]?0[0-7]+$} $VALUE] || \
|
|
[regexp {^[+-]?0[0-7]+\.$} $VALUE] || \
|
|
[regexp {^[+-]?0[0-7]+\.[0-7]+$} $VALUE] || \
|
|
[regexp {^[+-]?0[0-7]+\.?[eE][+-]?[0-7]+$} $VALUE] || \
|
|
[regexp {^[+-]?0[0-7]+\.[0-7]+[eE][+-]?[0-7]+$} $VALUE]} {
|
|
if {[string index $VALUE 0] != "0"} {
|
|
set FLAG [string index $VALUE 0]
|
|
set VALUE [string range $VALUE 1 end]
|
|
} else {
|
|
set FLAG ""
|
|
}
|
|
set ANSWER [tk_messageBox -type yesnocancel -icon question \
|
|
-message "This value $VALUE is octal.\nChange to [expr $VALUE]?"]
|
|
switch $ANSWER {
|
|
yes { return [Value_Check $TYPE $FLAG[expr $VALUE]]}
|
|
no { while {[string index $VALUE 0] == "0"} {
|
|
set VALUE [string range $VALUE 1 end]
|
|
}
|
|
return [Value_Check $TYPE $FLAG$VALUE]
|
|
}
|
|
cancel {return ERROR}
|
|
}
|
|
} elseif {[regexp {^[+-]?0[0-9]+$} $VALUE] || \
|
|
[regexp {^[+-]?0[0-9]+\.$} $VALUE] || \
|
|
[regexp {^[+-]?0[0-9]+\.[0-9]+$} $VALUE] || \
|
|
[regexp {^[+-]?0[0-9]+\.?[eE][+-]?[0-9]+$} $VALUE] || \
|
|
[regexp {^[+-]?0[0-9]+\.[0-9]+[eE][+-]?[0-9]+$} $VALUE]} {
|
|
if {[string index $VALUE 0] != "0"} {
|
|
set FLAG [string index $VALUE 0]
|
|
set VALUE [string range $VALUE 1 end]
|
|
} else {
|
|
set FLAG ""
|
|
}
|
|
while {[string index $VALUE 0] == "0"} {
|
|
set VALUE [string range $VALUE 1 end]
|
|
}
|
|
return [Value_Check $TYPE $FLAG$VALUE]
|
|
} elseif {[regexp {^[+-]?[0-9]+$} $VALUE]} {
|
|
return $VALUE.0
|
|
} elseif {[regexp {^[+-]?[0-9]+\.$} $VALUE] || \
|
|
[regexp {^[+-]?[0-9]*\.[0-9]+$} $VALUE] || \
|
|
[regexp {^[+-]?[0-9]+\.?[eE][+-]?[0-9]+$} $VALUE] || \
|
|
[regexp {^[+-]?[0-9]*\.[0-9]+[eE][+-]?[0-9]+$} $VALUE]} {
|
|
return $VALUE
|
|
} else {
|
|
tk_messageBox -type ok -icon question \
|
|
-message "Check!\nParameter type doesn't match."
|
|
return ERROR
|
|
}
|
|
}
|
|
boolean -
|
|
b { foreach B {TRUE FALSE YES NO T F Y N 1 0} {
|
|
if {[regexp -nocase -- $B $VALUE]} {
|
|
return $VALUE
|
|
}
|
|
}
|
|
return ERROR
|
|
}
|
|
char -
|
|
c -
|
|
string -
|
|
s { return $VALUE}
|
|
default {
|
|
tk_messageBox -type ok -icon warning \
|
|
-message "Type is \"$TYPE\".\nWhat's this?"
|
|
return ERROR
|
|
}
|
|
}
|
|
}
|
|
|
|
# Tab key off for all
|
|
proc Tab_off {} {
|
|
bind all <Tab> {}
|
|
bind all <Shift-Tab> {}
|
|
}
|
|
|
|
# Delete key bind for entry & text
|
|
proc Del_Bind {} {
|
|
bind Entry <Delete> {
|
|
if [%W selection present] {
|
|
%W delete sel.first sel.last
|
|
} else {
|
|
set X [expr [%W index insert] - 1]
|
|
if {$X>= 0} {
|
|
%W delete $X
|
|
}
|
|
if {[%W index @0] >= [%W index insert]} {
|
|
set RANGE [%W xview]
|
|
set LEFT [lindex $RANGE 0]
|
|
set RIGHT [lindex $RANGE 1]
|
|
%W xview moveto [expr $LEFT - ($RIGHT - $LEFT)/2.0]
|
|
}
|
|
}
|
|
}
|
|
bind Text <Delete> {
|
|
if {[%W tag nextrange sel 1.0 end] != ""} {
|
|
%W delete sel.first sel.last
|
|
} elseif [%W compare insert != 1.0] {
|
|
%W delete insert-1c
|
|
%W see insert
|
|
}
|
|
}
|
|
}
|
|
|
|
# Dialog box model
|
|
proc Message_Skeleton args {
|
|
global FONT F_COLOR B_COLOR
|
|
|
|
if [winfo exists .msgskeleton] {
|
|
destroy .msgskeleton
|
|
}
|
|
|
|
set COUNT [llength $args]
|
|
for {set i 0} {$i < $COUNT} {incr i} {
|
|
switch -- [lindex $args $i] {
|
|
"-icon" {
|
|
incr i
|
|
set ICON [lindex $args $i]
|
|
}
|
|
"-butt" -
|
|
"-button" {
|
|
incr i
|
|
set BUTTON [lindex $args $i]
|
|
}
|
|
"-message" {
|
|
incr i
|
|
set MESSAGE [lindex $args $i]
|
|
}
|
|
}
|
|
}
|
|
|
|
set FOCUS [focus]
|
|
toplevel .msgskeleton -highlightthickness 0
|
|
wm transient .msgskeleton .
|
|
wm title .msgskeleton "Dialog Box"
|
|
wm protocol .msgskeleton WM_DELETE_WINDOW {
|
|
grab release .msgskeleton
|
|
focus $FOCUS
|
|
}
|
|
|
|
|
|
frame .msgskeleton.info -highlightthickness 0
|
|
pack .msgskeleton.info -side top -fill both -expand 1
|
|
|
|
if [info exists ICON] {
|
|
label .msgskeleton.info.icon -bitmap $ICON -highlightthickness 0
|
|
pack .msgskeleton.info.icon -padx 15 -pady 5 -side left
|
|
}
|
|
|
|
if [info exists MESSAGE] {
|
|
message .msgskeleton.info.msg -text $MESSAGE -width 7c -highlightthickness 0
|
|
pack .msgskeleton.info.msg -pady 5 -side left -fill both -expand 1
|
|
}
|
|
|
|
|
|
frame .msgskeleton.butt -highlightthickness 0
|
|
pack .msgskeleton.butt -padx 5 -side top -fill x -expand 1
|
|
|
|
set COUNT 0
|
|
if [info exists BUTTON] {
|
|
foreach i [split $BUTTON] {
|
|
button .msgskeleton.butt.$COUNT -text " $i " -bd 3 \
|
|
-highlightthickness 0
|
|
pack .msgskeleton.butt.$COUNT -padx 3 -pady 3 -side left -expand 1
|
|
incr COUNT
|
|
}
|
|
} else {
|
|
button .msgskeleton.butt.$COUNT -text " OK " -bd 3 \
|
|
-command {destroy .msgskeleton} -highlightthickness 0
|
|
pack .msgskeleton.butt.$COUNT -padx 3 -pady 3 -side left -expand 1
|
|
}
|
|
|
|
|
|
wm withdraw .msgskeleton
|
|
update
|
|
set x [expr [winfo screenwidth .msgskeleton]/2 \
|
|
- [winfo width .msgskeleton]/2]
|
|
set y [expr [winfo screenheight .msgskeleton]/2 \
|
|
- [winfo height .msgskeleton]/2]
|
|
wm geom .msgskeleton +$x+$y
|
|
wm deiconify .msgskeleton
|
|
|
|
Win_Size .msgskeleton
|
|
Tab_off
|
|
Control
|
|
grab set .msgskeleton
|
|
focus $FOCUS
|
|
}
|
|
|
|
proc Another_Line STRING {
|
|
if {[string first "\\n" $STRING] >= 0} {
|
|
set HEAD [string first "\\n" $STRING]
|
|
set TAIL [expr $HEAD + 2]
|
|
incr HEAD -1
|
|
set STRING [string range $STRING 0 $HEAD]\n[string range $STRING $TAIL end]
|
|
set STRING [Another_Line $STRING]
|
|
} elseif {[string first ". " $STRING] >= 0} {
|
|
set HEAD [string first ". " $STRING]
|
|
set TAIL [expr $HEAD + 2]
|
|
incr HEAD -1
|
|
set STRING [string range $STRING 0 $HEAD].\n[string range $STRING $TAIL end]
|
|
set STRING [Another_Line $STRING]
|
|
}
|
|
return $STRING
|
|
}
|
|
|
|
proc Control {} {
|
|
global CTRL
|
|
|
|
bind Text <Control-k> {
|
|
if [%W compare insert == {insert lineend}] {
|
|
set CTRL(%W) "\n"
|
|
%W delete insert
|
|
} else {
|
|
scan [%W index insert] %%d.%%d LINE HEAD
|
|
set CTRL(%W) [%W get insert $LINE.end]
|
|
%W delete insert {insert lineend}
|
|
}
|
|
}
|
|
|
|
bind Entry <Control-k> {
|
|
set CTRL(%W) [string range [%W get] [%W index insert] end]
|
|
%W delete insert end
|
|
}
|
|
|
|
foreach WIDGET {Text Entry} {
|
|
bind $WIDGET <Control-y> {
|
|
if {[info exists CTRL(%W)]} {
|
|
%W insert insert $CTRL(%W)
|
|
}
|
|
}
|
|
}
|
|
}
|