james/tkgoodstuff
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
8.0-final
tkgoodstuff/tcl/Dialer.tcl

1136 lines
31 KiB
Tcl
Raw Permalink Normal View History

Initial commit of Mark Crimmins' code as of Oct. 1, 1997.
2015-07-08 14:33:48 +00:00
#!/bin/sh
# \
exec wish8.0 "$0" ${1+"$@"}
# Dialer; for establishing connection and authorization for
# ppp or term link.
# Version 8.0
# (numbered so as to coincide with the required version of tk)
# Assumes your modem takes AT... commands.
# Works for linux and several other platforms. Your mileage may
# suck.
# M. Crimmins 1/27/97
if {([set tk_version] < 4.1)} {
bgerror "This program requires tk version 4.1 or higher."
exit
}
set file ""
if {$argv != ""} {
set file [lindex $argv 0]
set argv [lreplace $argv 0 0]
}
set debug 0
set send_slow {1 .1}
set quickwait 5
set labelwidth 20
set entrywidth 50
set stringvars { numbers repeatscript port speed init1 init2\
loginscript outcommand }
set booleans {login exitsucc repeat}
# Give the first-time user an example
set numbers "555-1000 555-2000"
set repeatscript { * {{ 555-1000 1} {555-2000 1} {555-1000 3}}}
set repeat 0
set port /dev/modem
set speed 38400
set init1 "ATZ"
set init2 ""
set login 1
set loginscript {
{"" "host: " 10}
{ppp "login: " 20}
{ myloginname@umich.edu "Password: " 5}
{mypassword "" "" }
}
set outcommand "/usr/lib/ppp/pppd $port $speed asyncmap 0 defaultroute crtscts modem noipdefault"
set exitsucc 0
option add *Listbox*font {Helvetica 14} startupFile
option add *Entry*font {Helvetica 14} startupFile
option add *Label*font {Helvetica 14} startupFile
option add *Text*font {Helvetica 14} startupFile
proc DialWindow {} {
global normalbg
wm title . "Dialer"
wm withdraw .
wm iconname . "Dialer"
bind . <Key-Escape> exit
frame .status
pack .status -side left -pady 20 -padx 10
label .status.statuslabel -text "Dialing Status:"
pack .status.statuslabel -side top -pady 5
text .status.text -height 12 -width 40 -takefocus 0
set normalbg [.status.text cget -background]
global statuswindow
set statuswindow .status.text
pack .status.text -side top -fill x -fill y -padx 15
frame .buttons
button .buttons.dial -text Dial -command Dial
button .buttons.settings -text Settings -command EditSettings
button .buttons.next -text "Try Next\nNumber" -command {Next} -state disabled
button .buttons.abort -text Abort -command {Abort} -state disabled
button .buttons.dismiss -text Dismiss -command {exit}
pack .buttons.dial .buttons.settings .buttons.next .buttons.abort .buttons.dismiss \
-side top -expand y -fill x -padx 15 -pady 5
pack .buttons -side left -fill x -expand y
.status.statuslabel configure -font [.buttons.dial cget -font]
focus .buttons.dial
update
set x [expr ([winfo screenwidth .] - [winfo reqwidth .] )/2]
set y [expr ([winfo screenheight .] - [winfo reqheight .] )/2]
wm geometry . +$x+$y
wm deiconify .
}
proc Next {} {
global numaborted
set numaborted 1
}
proc Abort {} {
global aborted
set aborted 1
}
proc DoAbort {} {
global normalbg
Hangup
Outstatus "Aborted"
ResetButtons
.status.text config -background $normalbg
}
proc Hangup {} {
global id port
Outmodem ""
after 1250
Outmodem + 0
after 100
Outmodem + 0
after 100
Outmodem + 0
if [Dialexpect {} OK {} 3 ] {
Dialexpect ATH OK {} 3
after 500
}
exec stty sane < $port > $port
exec stty 38400 raw -echo clocal < $port > $port
return 1
}
proc CloseLine {} {
global id
if [info exists id] {
close -i $id
catch "unset id"
}
}
proc CheckBoth {} {
global aborted numaborted
expr $aborted || $numaborted
}
proc Dial {{repeating 0}} {
global statuswindow id nums loops
global tkgsentok aborted numaborted
global stringvars booleans
foreach v [eval list $stringvars $booleans] {
global $v
}
if !$repeating {
.buttons.dial config -state disabled
.buttons.dismiss config -state disabled
.buttons.abort config -state normal
.buttons.next config -state normal
.status.text config -background yellow
focus .buttons.next
set aborted 0
if !$repeat {
set nums $numbers
set loops 1
} else {
set nums ""
foreach pair [lindex $repeatscript 1] {
for {set i 0} {$i < [lindex $pair 1]} {incr i} {
lappend nums [lindex $pair 0]
}
}
set loops [lindex $repeatscript 0]
}
if ![OpenModem] {return 0}
}
for {set i 0} {$i < [llength $nums]} {incr i} {
set number [lindex $nums $i]
if {($i == ([llength $nums] - 1)) && \
($loops != "*") && ($loops < 2 )} {
.buttons.next config -state disabled
}
set numaborted 0
if ![ModemInit] {
Hangup
ResetButtons
set loops 1
break
}
if { ![DialNumber $number] || ![LoginScript] } {
if $aborted {DoAbort; return}
continue
}
OutCommand
ExitSucc
ResetButtons
focus .buttons.dismiss
return 1
}
catch "incr loops -1"
if {($loops == "*") || ($loops > 0)} {
Dial 1
return
}
.status.text config -background red
Outstatus "Sorry, failed to connect."
ResetButtons
return 0
}
proc OpenModem {} {
global port id
if [catch {set id [open $port w+]}] {
Dialerror "Error opening modem port."
.status.text config -background red
Outstatus "Aborted"
ResetButtons
return 0
}
fconfigure $id -blocking 0 -buffering none
exec stty 38400 raw -echo clocal < $port > $port
return 1
}
proc ModemInit {} {
global init1 init2
#initialize modem
if { $init1 != "" } {
if ![Dialexpect "$init1" "OK\n" "Error initializing modem."] {
set loops 1
return 0
}
if { $init2 != "" } {
if ![Dialexpect "$init2" "OK\n" "Error initializing modem."] {
set loops 1
return 0
}
}
}
return 1
}
proc DialNumber {number} {
global Dialer_expect_out
Outstatus "Dialing $number . . ."
set fail 0
if [Dialexpect ATDT$number \
{ "OK" "BUSY" "NO DIAL TONE" "NO CARRIER" "NO ANSWER" "CONNECT .*\[\r\n\]" } \
{} 45 ] {
switch -regexp -- $Dialer_expect_out {
"OK" { Outstatus " Unknown failure (\"OK\"!)."; set fail 1}
"BUSY" { Outstatus " Line is busy."; set fail 1}
"NO CARRIER" {
Outstatus " No carrier (no answer or phone line not connected)."
set fail 1
} "NO DIAL TONE" {
Outstatus " No dial tone (no busy signal or ringing detected)."
set fail 1
} "NO ANSWER" { Outstatus " No answer." ; set fail 1}
"CONNECT .*\[\r\n\]" {Outstatus $Dialer_expect_out}
}
if $fail {
after 1000
return 0
}
} else {
Hangup
return 0
}
return 1
}
proc LoginScript {} {
global loginscript login
.status.text config -background yellowgreen
if !$login {return 1}
Outstatus "Running login script. . ."
foreach entry $loginscript {
if ![Dialexpect [lindex $entry 0] \
[lindex $entry 1] \
"In login script, never got \"[lindex $entry 1]\"" \
[lindex $entry 2] ] {
Hangup
return 0
}
}
Outstatus "Login script succeeded."
.status.text config -background chartreuse1
return 1
}
proc OutCommand {} {
global outcommand
if {$outcommand != ""} {
Outstatus "Setting up the network:"
Outstatus " ([string range $outcommand 0 30] . . .)"
eval exec $outcommand &
}
}
proc ExitSucc {} {
global exitsucc
if !$exitsucc return
if {[lsearch [winfo interps] tkgoodstuff] != -1} {
if {[send tkgoodstuff {lsearch $TKG(clients) Net}] != -1} {
send tkgoodstuff Net_start_wait
send tkgoodstuff {DEBUG {Dialer suggests we look for net-up}}
}
}
bell; after 250 { bell; after 5000 exit }
}
proc ResetButtons {} {
.buttons.dial config -state normal
.buttons.dismiss config -state normal
.buttons.next config -state normal
.buttons.abort config -state disabled
.buttons.next config -state disabled
focus .buttons.dial
}
proc Dialexpect "outstring instrings {error none} \"wait $quickwait\"" {
global statuswindow global quickwait id aborted numaborted Dialer_expect_out
set Dialer_expect_out ""
if ![info exists id] { bgerror "no channel with id $id"}
if [CheckBoth] {return 0}
if { [regexp " *(&PAUSE|&pause) *(.*)$" $outstring l v pause] && ($pause != -1)} {
if { [scan $pause "%f" pause1] && [info exists pause1]} {
after [format %.0f [expr $pause1 * 1000]]
}
} elseif [regexp " *(&RETURN|&return) *$" $outstring l l] {
DEBUG "Sending return character. . ."
Outmodem ""
} elseif {$outstring != ""} {
DEBUG "Sending \"$outstring\". . ."
Outmodem "$outstring"
}
if {$instrings == ""} {return 1}
DEBUG "Waiting $wait seconds for \"$instrings\""
set timeout 1000
for {set i 0} {$i < $wait} {incr i} {
if [CheckBoth] {return 0}
if ![info exists id] { bgerror "no \$id"}
if [DialerExpect $id $instrings $timeout] {
return 1
}
}
DEBUG "Never got $instrings."
if [CheckBoth] {return 0}
if {$error != "none"} {Dialerror $error}
return 0
}
proc DialerExpect {id strings timeout} {
after $timeout DialerCancelExpect
fileevent $id readable [list DialerRead $strings $id]
global Dialer_cancelexpect
vwait Dialer_cancelexpect
fileevent $id readable {}
global Dialer_expect_out Dialer_expect_in
set Dialer_expect_in ""
set result [expr ![string match "" $Dialer_expect_out]]
return $result
}
proc DialerRead {strings id} {
global Dialer_expect_in Dialer_expect_out
append Dialer_expect_in [read $id]
foreach string $strings {
if [regexp $string $Dialer_expect_in Dialer_expect_out] {
DialerCancelExpect
}
}
}
proc DialerCancelExpect {} {
global Dialer_cancelexpect
set Dialer_cancelexpect 0
}
proc Outmodem {string {return 1}} {
global id
switch $return {
1 {eval puts -nonewline $id \"$string\\r\"}
0 {eval puts -nonewline $id \"$string\"}
}
}
proc Outstatus {string} {
global statuswindow
$statuswindow insert end "$string\n"
$statuswindow see end
update
}
proc DEBUG {string} {
global debug
switch $debug {
0 return
1 "Outstatus $string"
2 "puts $string"
}
}
proc Dialerror {error {die 0}} {
global statuswindow id
Outstatus "$error"
if $die {
if [info exists id] { close -i $id }
bgerror "$error"
exit
}
}
proc EditSettings {} {
global labelwidth file
set w .editsettings
catch {destroy $w}
toplevel $w
bind $w <Key-Escape> "destroy $w"
wm title $w "Dialer Settings"
wm iconname $w "Dialer Settings"
trace variable file w UpdateFileDisplay
frame $w.menu -relief raised -bd 2
pack $w.menu -side top -fill x
set m $w.menu.file.m
menubutton $w.menu.file -text "File" -menu $m -underline 0
menu $m
$m add command -label "Open settings file" -command Open
$m add command -label "New settings file" -command New
$m add command -label "Save settings" -command Save
$m add command -label "Save settings As ..." -command SaveAs
pack $w.menu.file -side left
set m $w.menu.help.m
menubutton $w.menu.help -text "Help" -menu $m -underline 0
menu $m
$m add command -label "About Dialer" -command About
$m add separator
$m add command -label "Dialer Help" -command HelpSettings
pack $w.menu.help -side right
button .b
set bfont [.b cget -font]
destroy .b
frame $w.curfile
label $w.curfile.label -font $bfont
UpdateFileDisplay
pack $w.curfile.label -side left
label $w.curfile.file -textvariable file -font $bfont
pack $w.curfile.file -side left
pack $w.curfile -expand y -pady 10
global labelwidth entrywidth
frame $w.numbers
radiobutton $w.numbers.check -variable repeat -value 0
pack $w.numbers.check -side left -padx 10
label $w.numbers.numberslabel -text "Dial these numbers:" -width $labelwidth -anchor c
pack $w.numbers.numberslabel -side left
entry $w.numbers.numbersentry -textvariable numbers -width $entrywidth
pack $w.numbers.numbersentry -side left -fill x -expand y
frame $w.repeat
radiobutton $w.repeat.check -variable repeat -value 1
pack $w.repeat.check -side left -padx 10
label $w.repeat.label1 -text "Dial from repeat script"
pack $w.repeat.label1 -side left
AddEntry $w port Port:
AddEntry $w speed Speed:
AddEntry $w init1 "Modem\ninit string"
AddEntry $w init2 "Second modem\ninit string"
AddEntry $w outcommand "Command to execute\nwhen logged in:"
frame $w.login
checkbutton $w.login.check -variable login
pack $w.login.check -side left -padx 10
label $w.login.label1 -text "Run login script when connected"
pack $w.login.label1 -side left
frame $w.exitsucc
checkbutton $w.exitsucc.check -variable exitsucc
pack $w.exitsucc.check -side left -padx 10
label $w.exitsucc.label1 -text "Exit on successful connection"
pack $w.exitsucc.label1 -side left
pack $w.numbers $w.repeat $w.port $w.speed $w.init1 $w.init2 $w.outcommand $w.login $w.exitsucc\
-fill x -pady 5
frame $w.buttons
button $w.buttons.ers -command EditRepeatScript -text "Edit\nRepeat Script"
pack $w.buttons.ers -side left -expand y -fill y -padx 15 -pady 15
button $w.buttons.els -command EditLoginScript -text "Edit\nLogin Script"
pack $w.buttons.els -side left -expand y -fill y -padx 15 -pady 15
button $w.buttons.dismiss -text Dismiss -command "destroy $w"
pack $w.buttons.dismiss -side left -expand y -fill y -padx 15 -pady 15
pack $w.buttons -fill x -expand y
}
proc UpdateFileDisplay args {
global file
if {$file == ""} {
.editsettings.curfile.label config -text "(No current file)"
} else {
.editsettings.curfile.label config -text "File: "
}
}
proc AddEntry { w v s } {
global labelwidth entrywidth
frame $w.$v
label $w.$v.[set v]label -text $s -width $labelwidth -anchor c
pack $w.$v.[set v]label -side left
entry $w.$v.[set v]entry -textvariable $v -width $entrywidth
pack $w.$v.[set v]entry -side left -fill x -expand y
}
proc EditRepeatScript {} {
global labelwidth repeatscript rscript file repeat
set entrywidth 25
set w .editrepeatscript
catch {destroy $w}
toplevel $w
bind $w <Key-Escape> "UpdateRepeatScript; destroy $w"
wm title $w "Dialer Repeat Script"
wm iconname $w "Dialer Repeat Script"
frame $w.title -relief raised
pack $w.title -fill x -expand y
label $w.title.0 -text "Numer:"
pack $w.title.0 -pady 10 -fill x -expand y -side left
label $w.title.1 -text "Repeat ___ times:"
pack $w.title.1 -pady 10 -fill x -expand y -side left
frame $w.entries
pack $w.entries
frame $w.entries.0
frame $w.entries.1
pack $w.entries.0 $w.entries.1 -side left -fill x
foreach s {0 1} {
for {set i 0} {$i<16} {incr i} {
set rscript($i,$s) [lindex [lindex [lindex $repeatscript 1] $i] $s]
entry $w.entries.$s.entry$i -width $entrywidth \
-textvariable rscript($i,$s)
pack $w.entries.$s.entry$i -padx 5 -pady 3 -fill x
}
}
frame $w.grep
label $w.grep.greplabel -text "Repeat entire script ___ times:\n(\"*\" means forever)" -anchor c
pack $w.grep.greplabel -side left
entry $w.grep.grepentry -textvariable loops -width 4
pack $w.grep.grepentry -side left
pack $w.grep -fill x -pady 10
frame $w.buttons
button $w.buttons.dismiss -text Dismiss -command "UpdateRepeatScript; destroy $w"
pack $w.buttons.dismiss -side left -expand y -fill y -padx 15 -pady 15
pack $w.buttons -side bottom -fill x -expand y
}
proc UpdateRepeatScript {} {
global rscript repeatscript loops
set repeatscript ""
set i 0
set s ""
while {($rscript($i,0) != "") || \
($rscript($i,1) != "")} {
lappend s [list $rscript($i,0) $rscript($i,1) ]
incr i
}
set repeatscript [list $loops $s]
}
proc EditLoginScript {} {
global labelwidth loginscript script file
set entrywidth 25
set w .editloginscript
catch {destroy $w}
toplevel $w
bind $w <Key-Escape> "UpdateScript; destroy $w"
wm title $w "Dialer Login Script"
wm iconname $w "Dialer Login Script"
frame $w.title -relief raised
pack $w.title -fill x -expand y
label $w.title.0 -text "Send:"
pack $w.title.0 -pady 10 -fill x -expand y -side left
label $w.title.1 -text "Then Expect:"
pack $w.title.1 -pady 10 -fill x -expand y -side left
label $w.title.2 -text "After ___ seconds:"
pack $w.title.2 -pady 10 -fill x -expand y -side left
frame $w.entries
pack $w.entries
frame $w.entries.0
frame $w.entries.1
frame $w.entries.2
pack $w.entries.0 $w.entries.1 $w.entries.2 -side left -fill x
foreach s {0 1 2} {
for {set i 0} {$i<16} {incr i} {
set script($i,$s) [lindex [lindex $loginscript $i] $s]
entry $w.entries.$s.entry$i -width $entrywidth \
-textvariable script($i,$s)
pack $w.entries.$s.entry$i -padx 5 -pady 3 -fill x
}
}
frame $w.buttons
button $w.buttons.dismiss -text Dismiss -command "UpdateScript; destroy $w"
pack $w.buttons.dismiss -side left -expand y -fill y -padx 15 -pady 15
pack $w.buttons -side bottom -fill x -expand y
}
proc UpdateScript {} {
global script loginscript
set loginscript ""
set i 0
while {($script($i,0) != "") || \
($script($i,1) != "") || \
($script($i,2) != "")} {
lappend loginscript [list $script($i,0) $script($i,1) $script($i,2) ]
incr i
}
}
proc HelpSettings {} {
set text "
This Dialer assumes you have a basically Hayes-compatible modem (like\
nearly all modems sold these days).
All settings, including a login script, are saved in a settings file.\
In the Settings window, you can open and save settings files. You can\
also select a settings file from the command line as follows:
\ \ \ \"Dialer mysettingsfile\"
If no settings file is given on the command line, Dialer looks for th\
file \".DialSettings\" in your home directory.\
To make the Dialer start dialing on invocation, you add \"Dial\" to the\
command line:
\ \ \ \"Dialer mysettingsfile Dial\"
(The Dialer also can be started automatically by the \"tkgoodstuff\"\
button bar's \"Net\" client.)
There are two dialing strategies to choose between:
1. Each phone number in the list of phone numbers will be tried in\
succession. You can use the usual Hayes characters in the dial string\
(consult your modem manual). NOTE to those who want to type\
\"ATDP555-7777\" here: you should not include the \"ATD\" command, but\
only the phone number.
2. A repeat script will be followed (which you edit by pressing a\
button in the Settings window). Each number will be tried a specified\
number of times, and the whole list will be tried a specified number of\
time (or forever).
The \"port\" is a unix device file governing the serial port to which\
your modem is connected, such as /dev/modem or /dev/cua1. (Linux\
users: remember that /dev/cua0 is COM1, . . ., and /dev/cua3 is\
COM4.)
The speed is the baud rate OF THE PORT, which typically is best set\
higher than the modem's baud rate. You don't need to set the modem\
baud rate explicitly (though you can do so in one of the init\
strings if necessary).
The modem init strings are \"AT...\" commands to send to the modem (we\
look for an \"OK\" from the modem afterwards). These are optional, and\
can be anything from \"AT\" to \"ATZ\" to the monstrously long ones modem\
freaks swear by (the author uses \"ATZ4\" with his Sportster v.34).
The entry \"command to execute when logged in\" allows you to start up\
your networking software once you have dialed in and authenticated to\
the server (through the login script, as described below). Here you\
can start, for instance, ppp or term. The author, for his dynamic ppp\
connection from home, uses:
\ \ \ \"/usr/lib/ppp/pppd /dev/modem 38400 asyncmap 0 defaultroute crtscts\
modem noipdefault\"
There is a checkbox which enables using the login script (on which more\
below).
And there is a checkbox which tells the Dialer window to disappear\
once all its tasks are completed sucessfully (including launching the\
networking command, if you have set one). Note that the Dialer itself\
does not check whether the networking command is successful in setting\
up the networking (for this indication, and for an easy way to use\
the dialer when needed, the author modestly suggests using his\
\"tkgoodstuff\" button bar's \"Net\" button).
To edit the login script associated with the current settings file,\
press the \"Edit Login Script\" button (did you guess that?). The login\
script is a sequence of \"steps\". Each step involves (optionally)\
sending a string to the modem (which automatically will be followed by\
a carriage return), and then (optionally) waiting a certain number of\
seconds for a string from the modem. If you leave the entries for the\
send (or expect) strings empty, then at that step no string will be\
sent (or expected). A send string of \"&pause 2.5\" will not send a\
string but instead will pause for 2.5 seconds. A send string of\
\"&return\" will send just a return character\
You can include special characters according to\
tcl's backslash substitution rules (see \"man Tcl\").
"
set w .loginscripthelp
catch {destroy $w}
toplevel $w
wm title $w "Dialer Help"
wm iconname $w "Dialer Help"
button .b
label $w.title -text "DIALER HELP" \
-font [.b cget -font]
destroy .b
pack $w.title -pady 10 -fill x -expand y
frame $w.view
text $w.view.text -width 80 -height 20 \
-takefocus 0 -yscrollcommand "$w.view.scrollbar set" \
-relief sunken -borderwidth 2 -state disabled \
-wrap word
pack $w.view.text -side left -fill both -expand 1
scrollbar $w.view.scrollbar -command "$w.view.text yview"
pack $w.view.scrollbar -side left -fill y -padx 3
pack $w.view -side top -fill both -expand 1 -padx 10
$w.view.text configure -state normal
$w.view.text insert end "$text"
$w.view.text configure -state disabled
frame $w.buttons
button $w.buttons.dismiss -text Dismiss -command "destroy $w"
pack $w.buttons.dismiss -side left -expand y -fill y -padx 15 -pady 15
pack $w.buttons -side bottom -fill x -expand y
}
proc About {} {
set text "
Dialer, by Mark Crimmins (markcrim@umich.edu), copyright 1995.
Look for the latest version in the tkgoodstuff distribution at:
\ \ \ ftp://merv.philosophy.lsa.umich.edu/pub
"
set w .about
catch {destroy $w}
toplevel $w
wm title $w "About Dialer"
wm iconname $w "About Dialer"
button .b
label $w.title -text "About Dialer" \
-font [.b cget -font]
destroy .b
pack $w.title -pady 10 -fill x -expand y
frame $w.view -relief groove -borderwidth 5
message $w.view.text -width 18c -text $text
pack $w.view.text -side left -fill both -expand 1
pack $w.view -side top -fill both -expand 1 -padx 10
frame $w.buttons
button $w.buttons.dismiss -text Dismiss -command "destroy $w"
pack $w.buttons.dismiss -side left -expand y -fill y -padx 15 -pady 15
pack $w.buttons -side bottom -fill x -expand y
}
proc Save {{f ""}} {
global file stringvars booleans
if {$f != ""} {set file $f}
if {$file == ""} {SaveAs; return}
set id [ open $file w ]
puts $id "\#Dialer Settings File"
foreach v [eval list $stringvars $booleans] {
global $v
puts $id "set $v \{[set $v]\}"
}
close $id
}
proc Open {} {
global file
if ![select f "Open file:"] {
return
}
if ![file exists $f] {
bgerror "Error: $f doesn't exist."
return
}
if ![file readable $f] {
bgerror "Error: $f isn't readable."
return
}
set file $f
GetSettings
}
proc New {} {
global file
if ![select f "New file name:"] {
return
}
if [file exists $f] {
bgerror "Error: can't create $f: file exists"
return
}
if [catch "exec touch $f"] {
bgerror "Error: can't create $f."
return
}
ClearSettings
set file $f
wm title . "Dialer"
}
proc SaveAs {} {
global file
if ![select f "File name:"] {
return
}
if [file exists $f] {
bgerror "Error: can't create $f: file exists"
return
}
if [catch "exec touch $f"] {
bgerror "Error: can't create $f."
return
}
set file $f
Save
}
proc ClearSettings {} {
global stringvars booleans
foreach v $stringvars {
global $v
set $v ""
}
foreach v $booleans {
global $v
set $v 0
}
}
proc GetSettings {} {
global file
global stringvars booleans
foreach v [eval list $stringvars $booleans] {
global $v
}
set id [open $file]
gets $id s
close $id
if {$s != "\#Dialer Settings File"} {
bgerror "File $file is not a dialer settings file."
return
}
source $file
global loops
set loops [lindex $repeatscript 0]
}
proc select {var {message "Open File"}} {
global selection
set selection ""
fileselect selectdone $message
tkwait window .fileSelectWindow
uplevel "set $var \"$selection\""
if { $selection == "" } {
return 0
} else {
return 1
}
}
proc selectdone {f} {
global selection
set selection $f
}
#
# fileselect.tcl --
# simple file selector.
#
# Mario Jorge Silva msilva@cs.Berkeley.EDU
# University of California Berkeley Ph: +1(510)642-8248
# Computer Science Division, 571 Evans Hall Fax: +1(510)642-5775
# Berkeley CA 94720
#
# Layout:
#
# file: +----+
# ____________________ | OK |
# +----+
#
# +------------------+ Cancel
# | .. |S
# | file1 |c
# | file2 |r
# | |b
# | filen |a
# | |r
# +------------------+
# currrent-directory
#
# Copyright 1993 Regents of the University of California
# Permission to use, copy, modify, and distribute this
# software and its documentation for any purpose and without
# fee is hereby granted, provided that this copyright
# notice appears in all copies. The University of California
# makes no representations about the suitability of this
# software for any purpose. It is provided "as is" without
# express or implied warranty.
#
# names starting with "fileselect" are reserved by this module
# no other names used.
# use the "option" command for further configuration
# this is the default proc called when "OK" is pressed
# to indicate yours, give it as the first arg to "fileselect"
proc fileselect.default.cmd {f} {
puts stderr "selected file $f"
}
# this is the default proc called when error is detected
# indicate your own pro as an argument to fileselect
proc fileselect.default.errorHandler {errorMessage} {
puts stdout "error: $errorMessage"
catch { cd ~ }
}
# this is the proc that creates the file selector box
proc fileselect {
{cmd fileselect.default.cmd}
{purpose "Open file:"}
{w .fileSelectWindow}
{errorHandler fileselect.default.errorHandler}} {
catch {destroy $w}
toplevel $w
grab $w
wm title $w "Select File"
# path independent names for the widgets
global fileselect
set fileselect(entry) $w.file.eframe.entry
set fileselect(list) $w.file.sframe.list
set fileselect(scroll) $w.file.sframe.scroll
set fileselect(ok) $w.bframe.okframe.ok
set fileselect(cancel) $w.bframe.cancel
set fileselect(dirlabel) $w.file.dirlabel
# widgets
frame $w.file -bd 10
frame $w.bframe -bd 10
pack append $w \
$w.file {left filly} \
$w.bframe {left expand frame n}
frame $w.file.eframe
frame $w.file.sframe
label $w.file.dirlabel -anchor e -width 24 -text [pwd]
pack append $w.file \
$w.file.eframe {top frame w} \
$w.file.sframe {top fillx} \
$w.file.dirlabel {top frame w}
label $w.file.eframe.label -anchor w -width 24 -text $purpose
entry $w.file.eframe.entry -relief sunken
pack append $w.file.eframe \
$w.file.eframe.label {top expand frame w} \
$w.file.eframe.entry {top fillx frame w}
scrollbar $w.file.sframe.yscroll -relief sunken \
-command "$w.file.sframe.list yview"
listbox $w.file.sframe.list -relief sunken \
-yscroll "$w.file.sframe.yscroll set"
pack append $w.file.sframe \
$w.file.sframe.yscroll {right filly} \
$w.file.sframe.list {left expand fill}
# buttons
frame $w.bframe.okframe -borderwidth 2 -relief sunken
button $w.bframe.okframe.ok -text OK -relief raised -padx 10 \
-command "fileselect.ok.cmd $w $cmd $errorHandler"
button $w.bframe.cancel -text cancel -relief raised -padx 10 \
-command "fileselect.cancel.cmd $w"
pack append $w.bframe.okframe $w.bframe.okframe.ok {padx 10 pady 10}
pack append $w.bframe $w.bframe.okframe {expand padx 20 pady 20}\
$w.bframe.cancel {top}
# Fill the listbox with a list of the files in the directory (run
# the "/bin/ls" command to get that information).
# to not display the "." files, remove the -a option and fileselect
# will still work
$fileselect(list) insert end ".."
foreach i [exec /bin/ls -a [pwd]] {
if {[string compare $i "."] != 0 && \
[string compare $i ".."] != 0 } {
$fileselect(list) insert end $i
}
}
# Set up bindings for the browser.
bind $fileselect(entry) <Return> {eval $fileselect(ok) invoke; break}
bind $fileselect(entry) <Control-c> {eval $fileselect(cancel) invoke; break}
bind $w <Control-c> {eval $fileselect(cancel) invoke;break}
bind $w <Return> {eval $fileselect(ok) invoke;break}
# tk_listboxSingleSelect $fileselect(list)
bind $fileselect(list) <Button-1> {
# puts stderr "button 1 release"
%W selection set [%W nearest %y]
$fileselect(entry) delete 0 end
$fileselect(entry) insert 0 [%W get [%W nearest %y]]
break
}
bind $fileselect(list) <Key> {
%W selection set [%W nearest %y]
$fileselect(entry) delete 0 end
$fileselect(entry) insert 0 [%W get [%W nearest %y]]
break
}
bind $fileselect(list) <Double-ButtonPress-1> {
# puts stderr "double button 1"
%W selection set [%W nearest %y]
$fileselect(entry) delete 0 end
$fileselect(entry) insert 0 [%W get [%W nearest %y]]
$fileselect(ok) invoke
break
}
bind $fileselect(list) <Return> {
%W selection set [%W nearest %y]
$fileselect(entry) delete 0 end
$fileselect(entry) insert 0 [%W get [%W nearest %y]]
$fileselect(ok) invoke
break
}
# set kbd focus to entry widget
focus $fileselect(entry)
}
# auxiliary button procedures
proc fileselect.cancel.cmd {w} {
# puts stderr "Cancel"
destroy $w
}
proc fileselect.ok.cmd {w cmd errorHandler} {
global fileselect
set selected [$fileselect(entry) get]
# some nasty file names may cause "file isdirectory" to return an error
set sts [catch {
file isdirectory $selected
} errorMessage ]
if { $sts != 0 } then {
$errorHandler $errorMessage
destroy $w
return
}
# clean the text entry and prepare the list
$fileselect(entry) delete 0 end
$fileselect(list) delete 0 end
$fileselect(list) insert end ".."
# selection may be a directory. Expand it.
if {[file isdirectory $selected] != 0} {
cd $selected
set dir [pwd]
$fileselect(dirlabel) configure -text $dir
foreach i [exec /bin/ls -a $dir] {
if {[string compare $i "."] != 0 && \
[string compare $i ".."] != 0} {
$fileselect(list) insert end $i
}
}
return
}
destroy $w
$cmd $selected
}
##### end of fileselect code
# Main Program
DialWindow
if {($file != "") || \
([file exists $env(HOME)/.DialSettings] && \
![catch {set file $env(HOME)/.DialSettings}]) } {
ClearSettings
GetSettings
}
eval $argv
Reference in New Issue Copy Permalink