ftpdemo.tcl

Go to the documentation of this file.

/* ! /bin/sh*/
/*  -*- tcl -*- \*/
exec tclsh "$0" ${1+"$@"}

/*    - simple tcl/tk test script for FTP library package -*/
/* */
/*    Required: tcl/tk8.3*/
/* */
/*    Created:  07/97 */
/*    Changed:  07/00 */
/*    Version:    1.1*/
/* */
/*    Copyright (C) 1997,1998 Steffen Traeger*/
/*  EMAIL:  Steffen.Traeger@t-online.de*/
/*  URL:    http://home.t-online.de/home/Steffen.Traeger*/
/* */
/*    This program is free software; you can redistribute it and/or */
/*    modify it. */
/*    This program is distributed in the hope that it will be useful,*/
/*    but WITHOUT ANY WARRANTY; without even the implied warranty of*/
/*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.*/
/* */
/* */

package require Tcl 8.3
package require Tk
package require ftp 2.0

/*  set palette under X*/
if { [string range [winfo server .] 0 0] == "X" } {
    option add *background          LightGray
    tk_Palette =  LightGray
    option add *Text.foreground     black
    option add *Text.background     [option get . selectBackground Listbox]
    option add *Listbox.background      [option get . selectBackground Listbox]
    option add *Listbox.selectBackground    [option get . insertBackground Listbox]
    option add *Listbox.selectForeground    white    
    option add *Entry.background        [option get . selectBackground Listbox]
    option add *Entry.selectBackground  [option get . insertBackground Listbox]
    option add *Entry.selectForeground      white
    option add *borderWidth         2
} else {
    option add *Checkbutton.borderWidth 0
    option add *Radiobutton.borderWidth 0

}   

/*  main window*/
wm title . "ftp Test"
wm iconname . ftptest
wm minsize . 1 1

/*  split area*/
frame .msg -bd 1 -relief raised
  pack .msg -in . -side top -fill both -expand 1
frame .op -bd 1 -relief raised
  pack .op -in . -side top -fill x
frame .but -bd 1 -relief raised
  pack .but -in . -side top -fill both -expand 1
  
/* */
/*  Frame 1*/
/* */
/*  Options*/
frame .op.f -bd 3
  pack .op.f -in .op -side top -fill x
  
/*  options   */
frame .op.f.f1 -bd 3
  pack .op.f.f1 -in .op.f -side left -fill both
label .op.f.f1.l -bd 2 -text "Server Options: " -relief flat -anchor w
  pack .op.f.f1.l -in .op.f.f1 -side top -fill x

frame .op.f.f1.server -bd 2
  pack .op.f.f1.server -in .op.f.f1 -side top -fill x -padx 15
label .op.f.f1.server.l -text "Host: " -width 10 -relief flat -anchor w
  pack .op.f.f1.server.l -in .op.f.f1.server -side left -fill x
entry .op.f.f1.server.e -width 20
  pack .op.f.f1.server.e -in .op.f.f1.server -side left -fill x

frame .op.f.f1.port -bd 2
  pack .op.f.f1.port -in .op.f.f1 -side top -fill x -padx 15
label .op.f.f1.port.l -text "Port: " -width 10 -relief flat -anchor w
  pack .op.f.f1.port.l -in .op.f.f1.port -side left -fill x
entry .op.f.f1.port.e -width 5
  pack .op.f.f1.port.e -in .op.f.f1.port -side left -fill x

frame .op.f.f1.username -bd 2
  pack .op.f.f1.username -in .op.f.f1 -side top -fill x -padx 15
label .op.f.f1.username.l -text "Username: " -width 10 -relief flat -anchor w
  pack .op.f.f1.username.l -in .op.f.f1.username -side left -fill x
entry .op.f.f1.username.e -width 10
  pack .op.f.f1.username.e -in .op.f.f1.username -side left -fill x

frame .op.f.f1.password -bd 2
  pack .op.f.f1.password -in .op.f.f1 -side top -fill x -padx 15
label .op.f.f1.password.l -text "Password: " -width 10 -relief flat -anchor w
  pack .op.f.f1.password.l -in .op.f.f1.password -side left -fill x
entry .op.f.f1.password.e -width 10 -show "*"
  pack .op.f.f1.password.e -in .op.f.f1.password -side left -fill x

frame .op.f.f1.directory -bd 2
  pack .op.f.f1.directory -in .op.f.f1 -side top -fill x -padx 15
label .op.f.f1.directory.l -text "Directory: " -width 10 -relief flat -anchor w
  pack .op.f.f1.directory.l -in .op.f.f1.directory -side left -fill x
entry .op.f.f1.directory.e -width 20
  pack .op.f.f1.directory.e -in .op.f.f1.directory -side left -fill x

/*  Separator*/
frame .op.f.sep1 -bd 1 -relief sunken
  pack .op.f.sep1 -in .op.f -fill y -side left -pady 2 -padx 4
frame .op.f.sep1.f -bd 1 -relief flat
  pack .op.f.sep1.f -in .op.f.sep1 -fill y -side left

frame .op.f.f2 -bd 3
  pack .op.f.f2 -in .op.f -side left -fill both -ipadx 15  
/*  transfer mode  */
label .op.f.f2.l2 -borderwidth 2 -anchor w -text "Transfer mode:" 
  pack .op.f.f2.l2 -in .op.f.f2 -side top -fill x
radiobutton .op.f.f2.active -anchor w -text "Active" -variable test(mode) -value "active"
  pack .op.f.f2.active -in .op.f.f2 -side top -fill x -padx 15
radiobutton .op.f.f2.passive -anchor w -text "Passive" -variable test(mode) -value "passive"
  pack .op.f.f2.passive -in .op.f.f2 -side top -fill x -padx 15

/* */
/*  Frame 2 */
/* */
/*  debugging  */
label .op.f.f2.l1 -borderwidth 2 -anchor w -text "Debugging:" 
  pack .op.f.f2.l1 -in .op.f.f2 -side top -fill x 
checkbutton .op.f.f2.debug -anchor w -text "Debug" -variable ftp::DEBUG
  pack .op.f.f2.debug -in .op.f.f2 -side top -fill x  -padx 15
checkbutton .op.f.f2.verbose -anchor w -text "Verbose" -variable ftp::VERBOSE
  pack .op.f.f2.verbose -in .op.f.f2 -side top -fill x -padx 15

/* Iterations*/
frame .op.f.f2.loops -bd 2
  pack .op.f.f2.loops -in .op.f.f2 -side top -fill x -pady 2
label .op.f.f2.loops.l -borderwidth 2 -text "Iterations: " -relief flat -anchor w
  pack .op.f.f2.loops.l -in .op.f.f2.loops -side left -fill x
entry .op.f.f2.loops.e -borderwidth 2 -width 5
  pack .op.f.f2.loops.e -in .op.f.f2.loops -side left -fill x

/*  Separator*/
frame .op.f.sep2 -bd 1 -relief sunken
  pack .op.f.sep2 -in .op.f -fill y -side left -pady 2 -padx 4
frame .op.f.sep2.f -bd 1 -relief flat
  pack .op.f.sep2.f -in .op.f.sep2 -fill y -side left

/* */
/*  Frame 3*/
/* */
frame .op.f.f3 -bd 3
  pack .op.f.f3 -in .op.f -side left -fill both -expand 1 -ipadx 15

label .op.f.f3.l1  -anchor w -width 10 -text "Variable trace:" 
  pack .op.f.f3.l1 -in .op.f.f3 -side top -fill x 

frame .op.f.f3.v0 -bd 0
  pack .op.f.f3.v0 -in .op.f.f3 -side top -fill x -pady 2 -padx 15
label .op.f.f3.v0.name  -anchor w -text "iterations = " 
  pack .op.f.f3.v0.name  -in .op.f.f3.v0 -side left -fill x 
label .op.f.f3.v0.value -anchor w -textvariable test(loop)
  pack .op.f.f3.v0.value -in .op.f.f3.v0 -side top -fill x
frame .op.f.f3.v1 -bd 0
  pack .op.f.f3.v1 -in .op.f.f3 -side top -fill x -pady 2 -padx 15
label .op.f.f3.v1.name  -anchor w -text "errors = " 
  pack .op.f.f3.v1.name  -in .op.f.f3.v1 -side left -fill x 
label .op.f.f3.v1.value -anchor w -textvariable test(errors)
  pack .op.f.f3.v1.value -in .op.f.f3.v1 -side top -fill x
frame .op.f.f3.v2 -bd 0
  pack .op.f.f3.v2 -in .op.f.f3 -side top -fill x -pady 2 -padx 15
label .op.f.f3.v2.name  -anchor w -text "after queues = " 
  pack .op.f.f3.v2.name  -in .op.f.f3.v2 -side left -fill x 
label .op.f.f3.v2.value -anchor w -textvariable test(after) 
  pack .op.f.f3.v2.value -in .op.f.f3.v2 -side top -fill x
frame .op.f.f3.v4 -bd 0
  pack .op.f.f3.v4 -in .op.f.f3 -side top -fill x -pady 2 -padx 15
label .op.f.f3.v4.name  -anchor w -text "open channels:" 
  pack .op.f.f3.v4.name  -in .op.f.f3.v4 -side top -fill x 
label .op.f.f3.v4.value -anchor w -textvariable test(open) 
  pack .op.f.f3.v4.value -in .op.f.f3.v4 -side top -fill x -padx 8

/* */
/*  Messages*/
frame .msg.f -bd 3
  pack .msg.f -in .msg -side top -fill both -expand 1

frame .msg.f.f1 -bd 2 -relief groove 
  pack .msg.f.f1 -in .msg.f -side left -fill both -padx 2 -pady 2
label .msg.f.f1.l -text "Test commands: " -relief flat -anchor w
  pack .msg.f.f1.l -in .msg.f.f1 -side top -fill x -padx 4 -pady 2

/*  Test commands   */
 idlist =  {}  
foreach {id text} {     quote "System Info"\
            list "List" \
            nlist "NList" \
            dir "Cd, MkDir, RmDir" \
            afile "ASCII Put/Get" \
            bfile "Binary Put/Ret" \
            ren "Rename" \
            append "Append" \
            new "Newer"  \
            reget "Reget" \
            notfound "file not found"} {
    checkbutton .msg.f.f1.$id -anchor w -text $text -variable test($id)
      pack .msg.f.f1.$id -in .msg.f.f1 -side top -fill x -padx 16
     test = ($id) 1
    lappend idlist $id
}
button .msg.f.f1.plus -text "+ all" -command "foreach i {$idlist} { test = (\$i) 1}"
  pack .msg.f.f1.plus -in .msg.f.f1 -side left -fill x -padx 16 -pady 8
button .msg.f.f1.minus -text  "- all" -command "foreach i {$idlist} { test = (\$i) 0}"
  pack .msg.f.f1.minus -in .msg.f.f1 -side left -fill x -pady 8

frame .msg.f.f2 -bd 2 -relief groove 
  pack .msg.f.f2 -in .msg.f -side left -fill both -pady 2

label .msg.f.f2.label -text "Messages:" -anchor w
  pack .msg.f.f2.label -in .msg.f.f2 -side top -fill x -padx 2
scrollbar .msg.f.f2.yscroll -command ".msg.f.f2.text yview" 
  pack .msg.f.f2.yscroll -in .msg.f.f2 -side right -fill y
scrollbar .msg.f.f2.xscroll -relief sunken -orient horizontal -command ".msg.f.f2.text xview" 
  pack .msg.f.f2.xscroll -in .msg.f.f2 -side bottom -fill x
text .msg.f.f2.text -relief sunken -grid =  1 -wrap none -height 20 -width 80 -bg white -fg black\
    -state disabled  -xscrollcommand ".msg.f.f2.xscroll " \
    -yscrollcommand =  ".msg.f.f2.yscroll "
  pack =  .msg.f.f2.text -in .msg.f.f2 -side left  -expand 1 -fill both
.msg.f.f2.text tag configure error -foreground red
.msg.f.f2.text tag configure data -foreground brown
.msg.f.f2.text tag configure control -foreground blue
.msg.f.f2.text tag configure header -foreground white -background black

/* */
/*  Buttons*/
frame .but.f -bd 3
  pack .but.f -in .but -side top -fill both -expand 1

frame .but.f.f1 -bd 3 
  pack .but.f.f1 -in .but.f -side top -fill x -padx 15 -pady 6
button .but.f.f1.start -text "Start Test" -width 12 -state normal -command "StartTest" 
   pack .but.f.f1.start -side left -fill x  -padx 15 
button .but.f.f1.stop -text "Stop Test" -width 12 -state disabled -command "StopTest" 
   pack .but.f.f1.stop -side left -fill x  -padx 15 
button .but.f.f1.close -text "Quit" -width 12 -state normal -command "destroy ." 
   pack .but.f.f1.close -side right -fill x  -padx 15 
button .but.f.f1.save -text "Save Options" -width 12 -state normal -command "SaveConfig" 
   pack .but.f.f1.save -side right -fill x  -padx 15 

/*  procedures ####################################################################*/

/*  overwrite default ftp display message procedure*/
namespace ftp {
ret  DisplayMsg (type s , type msg , optional state ="") {
global test
    .msg.f.f2.text configure -state normal
    
    # change state from "error" to "" for procedure test_9notfound
    if { ($state == "error") && [info exist test(proc)] && ($test(proc) == "test_99notfound") } {
        set state ""
    }
    
    switch -exact -- $state {
      data      {.msg.f.f2.text insert end "$msg\n" data}
      control   {.msg.f.f2.text insert end "$msg\n" control}
      error     {.msg.f.f2.text insert end "$msg\n" error; incr test(errors)}
      header    {.msg.f.f2.text insert end "$msg\n" header}
      default   {.msg.f.f2.text insert end "$msg\n"}
    }
    .msg.f.f2.text configure -state disabled
    .msg.f.f2.text see end
    update idletasks
}}

/*  new tracing open command*/
rename open ftpopen
ret  open (type args) {
global test
    set rc [eval ftpopen $args]
    if {[lsearch -exact $test(open) $rc] == "-1"} {
        lappend test(open) $rc
    }
#puts "open: $test(open)"
    return $rc
}   

/*  new tracing close command*/
rename close ftpclose
ret  close (type args) {
global test
    set rc [eval ftpclose $args]
    set index [lsearch -exact $test(open) $args]
    if {$index != "-1"} {
        set test(open) [lreplace $test(open) $index $index]
    } 
#puts "close: $test(open)"
    return $rc
}   

/*  new tracing socket command*/
rename socket ftpsocket
ret  socket (type args) {
global test
    set rc [eval ftpsocket $args]
    if {[lsearch -exact $test(open) $rc] == "-1"} {
        lappend test(open) $rc
    } 
#puts "socket: $test(open)"
    return $rc
}   


/*  new tracing InitDataConn command*/
namespace ftp {
rename InitDataConn ftpInitDataConn 
ret  InitDataConn (type args) {
global test
    set rc [eval ftpInitDataConn  $args]
    set s [lindex $args 0]
    if {[lsearch -exact $test(open) $s] == "-1"} {
        lappend test(open) $s
    } 
#puts "InitDataConn: $test(open)"
    return $rc
}}

/*  progress bar for put/get operations */
ret  ProgressBar (type state , optional bytes =0 , optional total ={) {filename {}}} {
global progress
     w =  .progress
    switch -exact -- $state {
      init  {
         progress = (percent) "0%"
         progress = (total) $total
         progress = (left) 0
        toplevel $w -bd 0 -class Progressbar
        wm transient $w .
        wm title $w Progress
            wm iconname $w Progress
        wm resizable $w 0 0
        focus $w
        
        frame $w.frame -bd 4
          pack $w.frame -side top -fill both
        label $w.frame.label -text "Transfering $filename..." -relief flat -anchor w -bd 1
          pack $w.frame.label -in $w.frame -side top -fill x -padx 10 -pady 5
        frame $w.frame.bar -bd 1 -relief sunken -bg /* ffffff*/
          pack $w.frame.bar -in $w.frame -side left -padx 10 -pady 5
        frame $w.frame.bar.dummy -bd 0 -width 250 -height 0
          pack $w.frame.bar.dummy -in $w.frame.bar -side top -fill x
        frame $w.frame.bar.pbar -bd 0 -width 0 -height 20
          pack $w.frame.bar.pbar -in $w.frame.bar -side left
        label $w.frame.proz -textvariable progress(percent) -width 5 -relief flat -anchor e -bd 1
          pack $w.frame.proz -in $w.frame -side right -padx 10 -pady 5

        wm withdraw $w
        update idletasks
         x =  [expr {[winfo x .] + ([winfo width .] / 2) - ([winfo reqwidth $w] / 2)}]
         y =  [expr {[winfo y .] + ([winfo height .] / 2) - ([winfo reqheight $w] / 2)}]
        wm geometry $w +$x+$y
        update idletasks
        wm deiconify $w
        update idletasks
      }

      update {
        if {![winfo exist $w]} {return}  
         cur = _width 250
        catch {
             progress = (percent) "[expr {round($bytes) * 100 / $progress(total)}]%";
             cur = _width [expr {round($bytes * 250 / $progress(total))}]
        } msg
        $w.frame.bar.pbar configure -width $cur_width -bg /* 000080*/
        update idletasks
      }

      done  {
        un progress = 
        destroy $w
        update
      }
      default {
          error "Unknown state \"$state\""
      }
    }
}

/* */
/*  1.) list -  returns a long list*/
/* */
ret  test_10list (type loop) {
global test

    # check if enabled
    if {!$test(list)} {return}

    ftp::DisplayMsg $test(conn) "*** TEST $loop.1 (long directory listing)  ***" header
    set remote_list [ftp::List $test(conn)]     
    ftp::DisplayMsg $test(conn) "[llength $remote_list] directory lines!"
}

/* */
/*  2.) nlist - returns a sorted short list*/
/* */
ret  test_20nlist (type loop) {
global test

    # check if enabled
    if {!$test(nlist)} {return}

    ftp::DisplayMsg $test(conn) "*** TEST $loop.2 (short directory listing) ***" header
    set remote_list [ftp::NList $test(conn)]
    ftp::DisplayMsg $test(conn) "[llength $remote_list] directory entries!" 
}


/* */
/*  3.) directory commands (cd, mkdir, rmdir)*/
/*  - creates a remote directory foo*/
/*  - changes to this directory*/
/*  - changes back to parent directory*/
/*  - removes a remote directory foo*/
/* */
ret  test_30dir (type loop) {
global test

    # check if enabled
    if {!$test(dir)} {return}
    ftp::DisplayMsg $test(conn) "*** TEST $loop.3 (directory commands cd,mkdir,rmdir) ***" header
    ftp::Pwd $test(conn)
    ftp::MkDir $test(conn) foo$test(pid)
    ftp::Cd $test(conn) foo$test(pid)
    ftp::Pwd $test(conn)
    ftp::Cd $test(conn) ..
    ftp::Pwd $test(conn)
    ftp::RmDir $test(conn) foo$test(pid)
}

/* */
/*  4.) ascii put/get and delete*/
/*  - go to ascii mode*/
/*  - store a file to remote site*/
/*  - retrieve the same file from remote site*/
/*  - delete a file on remote site*/
/*  - compare the size of both files*/
/*    (file sizes should be equal or only the "\r" difference */
/*     between DOS/WINDOWS <> UNIX*/
/* */
ret  test_40afile (type loop) {
global test

    # check if enabled
    if {!$test(afile)} {return}

    ftp::DisplayMsg $test(conn) "*** TEST $loop.4 (put/get ascii files) ***" header
    set ascii_file ftpdemo.tcl
    set lsize [file size $ascii_file]
    ftp::Type $test(conn) ascii 
    ftp::Put $test(conn) $ascii_file ignore$test(pid).tmp

    # FileSize only works proper in binary mode
    ftp::Type $test(conn) binary
    set rsize [ftp::FileSize $test(conn) ignore$test(pid).tmp]
    ftp::Type $test(conn) ascii 
    ftp::Get $test(conn) ignore$test(pid).tmp
    ftp::Delete $test(conn) ignore$test(pid).tmp

    catch {
        ftp::DisplayMsg $test(conn) "Original File:\t$lsize bytes"
        ftp::DisplayMsg $test(conn) "Stored File:\t$rsize bytes"
        ftp::DisplayMsg $test(conn) "Retrieved File:\t[file size ignore$test(pid).tmp] bytes"
        file delete ignore$test(pid).tmp    }

}

/* */
/*  5.) binary put/get*/
/*  - switch to binary mode*/
/*  - store a file to remote site*/
/*  - retrieve the same file from remote site*/
/*  - delete a file on remote site*/
/*  - compare the size of both files*/
/* */
ret  test_50bfile (type loop) {
global test tk_library

    # check if enabled
    if {!$test(bfile)} {return}

    ftp::DisplayMsg $test(conn) "*** TEST $loop.5 (put/get binary files) ***" header
    set bin_file $tk_library/demos/images/teapot.ppm
    set lsize [file size $bin_file]
    ftp::Type $test(conn) binary

    # Put with ProgressBar
    #   - ProgressBar init ...
    #   - ProgressBar update ... callback defined in ftp!
    #   - ProgressBar done
    ProgressBar init 0 $lsize teapot.ppm
    ftp::Put $test(conn) $bin_file ignore$test(pid).tmp
    ProgressBar done
    
    # Put with ProgressBar
    set rsize [ftp::FileSize $test(conn) ignore$test(pid).tmp]
    ProgressBar init 0 $rsize ignore$test(pid).tmp
    ftp::Get $test(conn) ignore$test(pid).tmp
    ProgressBar done
    
    ftp::Delete $test(conn) ignore$test(pid).tmp

    catch {
        ftp::DisplayMsg $test(conn) "Original File:\t$lsize bytes"
        ftp::DisplayMsg $test(conn) "Stored File:\t$rsize bytes"
        ftp::DisplayMsg $test(conn) "Retrieved File:\t[file size ignore$test(pid).tmp] bytes"
        file delete ignore$test(pid).tmp
    }
    
}

/* */
/*  6.) rename*/
/*  - stores a binary file on remote site and renames it*/
/* */
ret  test_60ren (type loop) {
global test tk_library

    # check if enabled
    if {!$test(ren)} {return}

    ftp::DisplayMsg $test(conn) "*** TEST $loop.6 (renaming remote files) ***" header
    set bin_file $tk_library/demos/images/earth.gif
    ftp::Type $test(conn) binary
    ftp::Put $test(conn) $bin_file ignore$test(pid).tmp
    ftp::Rename $test(conn) ignore$test(pid).tmp renamed$test(pid).tmp 
    ftp::Delete $test(conn) renamed$test(pid).tmp   

}
/* */
/*  7.) append*/
/*  - go to ascii mode*/
/*  - store a ascii file to remote site*/
/*  - appends ascci file on remote site and renames it*/
/*  - delete a file on remote site*/
/*  - compare the size of both files */
/*    remote file must have the double size*/
/*    (file sizes should be equal or only the "\r" difference */
/*     between DOS/WINDOWS <> UNIX*/
/* */
ret  test_70append (type loop) {
global test tk_library

    # check if enabled
    if {!$test(append)} {return}

    ftp::DisplayMsg $test(conn) "*** TEST $loop.7 (append ascii file) ***" header
    set ascii_file ftpdemo.tcl
    set lsize [file size $ascii_file]
    ftp::Type $test(conn) ascii 
    ftp::Append $test(conn) $ascii_file ignore$test(pid).tmp
    ftp::Append $test(conn) $ascii_file ignore$test(pid).tmp
    ftp::Get $test(conn) ignore$test(pid).tmp
    ftp::Delete $test(conn) ignore$test(pid).tmp

    catch {
        ftp::DisplayMsg $test(conn) "Original File:\t$lsize bytes ( * 2 = [expr {$lsize * 2}])"
        ftp::DisplayMsg $test(conn) "Appended File:\t[file size ignore$test(pid).tmp] bytes"
        file delete ignore$test(pid).tmp    }

}

/* */
/*  8.) newer*/
/*  - create a local copy of a a file*/
/*  - create a remote copy of a a file*/
/*  - check date entries*/
/*  - transfer only if the specifieid file is newer*/
/* */
ret  test_80new (type loop) {
global test tk_library

    # check if enabled
    if {!$test(new)} {return}

    ftp::DisplayMsg $test(conn) "*** TEST $loop.8 (newer) ***" header
    set bin_file $tk_library/demos/images/earth.gif
    ftp::Type $test(conn) binary

    file copy $bin_file ignore$test(pid).tmp
    ftp::Put $test(conn) $bin_file ignore$test(pid).tmp
    set datestr "%m/%d/%Y, %H:%M"

    set out {}
    catch {
        append out "Local File:\t[clock format [file mtime ignore$test(pid).tmp] -format $datestr -gmt 1]" \n
        append out "Remote File:\t[clock format [ftp::ModTime $test(conn) ignore$test(pid).tmp] -format $datestr -gmt 1]" \n
    }

    ftp::Newer $test(conn) ignore$test(pid).tmp 
    
    catch { 
        append out "Local File:\t[clock format [file mtime ignore$test(pid).tmp] -format $datestr -gmt 1] (after ftp::Newer)" 
    }

    ftp::Delete $test(conn) ignore$test(pid).tmp
    catch {file delete ignore$test(pid).tmp}
    ftp::DisplayMsg $test(conn) $out

}

/* */
/*  9.) reget - reget command*/
/*  - store file to remote site*/
/*  - write 6 bytes to local file*/
/*  - test the reget at position 6*/
/* */
ret  test_90reget (type loop) {
global test tk_library

    # check if enabled
    if {!$test(reget)} {return}

    ftp::DisplayMsg $test(conn) "*** TEST $loop.9 (reget command) ***" header
    set bin_file $tk_library/demos/images/earth.gif
    ftp::Type $test(conn) binary
    ftp::Put $test(conn) $bin_file ignore$test(pid).tmp
    set f [open ignore$test(pid).tmp w]
    puts -nonewline $f "123456"
    close $f
    ftp::Reget $test(conn) ignore$test(pid).tmp
    ftp::Delete $test(conn) ignore$test(pid).tmp

    catch {
        ftp::DisplayMsg $test(conn) "Original File:\t\t[file size $bin_file]"
        ftp::DisplayMsg $test(conn) "Transfered  File:\t[file size ignore$test(pid).tmp]"
        file delete ignore$test(pid).tmp
    }
}

/** 
 * 10.) not existing file/directory
 *  all command with a not existing file name as parameter
 *  - nlist, filesize, modtime, delete, rename, cd, rmdir, put, get, reget, newer
 *  - write 6 bytes to local file
 *  - test the reget at position 6
 *
 */
ret  test_99notfound (type loop) {
global test tk_library

    # check if enabled
    if {!$test(notfound)} {return}

    ftp::DisplayMsg $test(conn) "*** TEST $loop.10 (not existing file/directory) ***" header
    ftp::NList $test(conn) filenotfound     
    ftp::FileSize $test(conn) filenotfound      
    ftp::ModTime $test(conn) filenotfound       
    ftp::Rename $test(conn) filenotfound filenotfound
    ftp::Delete $test(conn) filenotfound
    ftp::Cd $test(conn) filenotfound
    ftp::RmDir $test(conn) filenotfound
    ftp::Put $test(conn) filenotfound
    ftp::Get $test(conn) filenotfound
    ftp::Reget $test(conn) filenotfound
    ftp::Newer $test(conn) filenotfound
}

/*  save preferences*/
ret  SaveConfig () {
global cnf

    set cnf(server) [.op.f.f1.server.e get]
    set cnf(port) [.op.f.f1.port.e get]
    set cnf(username) [.op.f.f1.username.e get]
    set cnf(password) [.op.f.f1.password.e get]
    set cnf(directory) [.op.f.f1.directory.e get]
    set cnf(loops) [.op.f.f2.loops.e get]
    set cnf(debug) $ftp::DEBUG
    set cnf(verbose) $ftp::VERBOSE

    set f [open $cnf(configfile) w]
    puts $f  [array get cnf]    
    close $f
}

/*  load preferences*/
ret  LoadConfig () {
global cnf

    # Defaults
    set cnf(server) "xxx"
    set cnf(port) 21
    set cnf(username) "xxx"
    set cnf(password) "xxx"
    set cnf(directory) ""
    set cnf(loops) 1
    set cnf(debug) 0
    set cnf(verbose) 1
    
    if {[file exists $cnf(configfile)]} {
        set f [open $cnf(configfile) r]
        array set cnf [read $f]
        close $f
    }
    
    .op.f.f1.server.e delete 0 end
    .op.f.f1.server.e insert 0 $cnf(server)
    .op.f.f1.port.e delete 0 end
    .op.f.f1.port.e insert 0 $cnf(port)
    .op.f.f1.username.e delete 0 end
    .op.f.f1.username.e insert 0 $cnf(username)
    .op.f.f1.password.e delete 0 end
    .op.f.f1.password.e insert 0 $cnf(password)
    .op.f.f1.directory.e delete 0 end
    .op.f.f1.directory.e insert 0 $cnf(directory)
    .op.f.f2.loops.e delete 0 end
    .op.f.f2.loops.e insert 0 $cnf(loops)
    set ::ftp::DEBUG $cnf(debug)
    set ::ftp::VERBOSE $cnf(verbose)
}

/*  stop the test*/
ret  StopTest () {
global test
    set test(break) 1
}

/*  start the test*/
ret  StartTest () {
global test

    .but.f.f1.stop configure -state normal
    .but.f.f1.start configure -state disabled
    
    .msg.f.f2.text configure -state normal
    .msg.f.f2.text delete 1.0 end
    .msg.f.f2.text configure -state disabled -fg black

    set loops [.op.f.f2.loops.e get]
    set server [.op.f.f1.server.e get]
    set port [.op.f.f1.port.e get]
    set username [.op.f.f1.username.e get]
    set passwd [.op.f.f1.password.e get]
    set dir [.op.f.f1.directory.e get]

    # open a ftp server connection
    set test(errors) 0
    set test(open) {}
    set test(pid) [pid]
    set start_time [clock seconds]
    ftp::DisplayMsg "" "*** Test started at [clock format [clock seconds]  -format %d.%m.%Y\ %H:%M:%S ] ..." header
    if {[set conn [ftp::Open $server $username $passwd -port $port -progress {ProgressBar update} -mode $test(mode) -blocksize 8196 -timeout 60]] >= 0} {

        if {$test(quote)} {
            ftp::DisplayMsg $conn [ftp::Quote $conn syst]
                ftp::DisplayMsg $conn [ftp::Quote $conn site umask 022]
                ftp::DisplayMsg $conn [ftp::Quote $conn help]
            }
               
               
        if { $dir != "" } {
            ftp::Cd $conn $dir
        }
        
            # begin test loop
            set test(break) 0
                set test(conn) $conn
            for {set test(loop) 1} {$test(loop) <= $loops} {incr test(loop)} {
                if {$test(break)} {break}
            foreach test(proc) [lsort [info proc test*]] {
                    if {$test(break)} {break}
                    
                    # count entries in the after queues
                    set test(after) [after info]

                    # run procedure
                eval $test(proc) $test(loop) 
            }
            }
            if {$test(break)} {
                ftp::DisplayMsg "... user break!" error
            } else {
            incr test(loop) -1
        }
        
            ftp::Close $conn
        set stop_time [clock seconds]
        set elapsed [expr {$stop_time - $start_time}]
        if { $elapsed == 0 } { set elapsed 1}
            ftp::DisplayMsg "" "************************* THE END *************************" header
            ftp::DisplayMsg "" "=> $loops iterations takes $elapsed seconds" 
        ftp::DisplayMsg "" "=> $test(errors) error(s) occured" 
    }
    .but.f.f1.stop configure -state disabled
    .but.f.f1.start configure -state normal
}

/*  Help*/
ret  Help () {
    .msg.f.f2.text configure -state normal
    .msg.f.f2.text delete 1.0 end
    .msg.f.f2.text insert 1.0 "          **** CONFIGURATION HELP *****
    
Ftp_demo is the simple user interface to the ftp test program. It
checks all ftp commands of the FTP library package against an
existing FTP server. It requires some configuration entries specified
in the form below.

- Host ... Host FTP server on which the connection will be established
- Username ... Users login name at host 
- Password ... Users password at host 
- Directory ... Starting directory when differs from root \"/\"
- Iterations ... Count of interations for the test algorithm (default 1)    

The message window shows all responses from the remote server, as well
as report on data transfer statistics and file sizes. Two switches 
toggles enhanced output:

1. Debug...Enables debugging (return code, state, real FTP commands )
2. Verbose ... Forces to show all responses from the FTP server 

Active or passive file transfer mode is selected in the upper frame.
When ftpdemo uses the active mode it waits for the server to open
a connection to transfer files or get file listings. In passive mode
the server waits for ftpdemo to open a connection to transfer files
or get file listings. Passive mode is normally a requirement when
accessing sites via a firewall.

Press \"Save Options\" to save these options in a configuration file. 
Options will be restored next time you start the ftpdemo program.
Check marked test commands and start test by pressing \"Start test\"
button. Any time the test program can be canceled by pressing the
\"Stop test\" button.
 
NOTE:
-----
THE FTP_DEMO PROGRAM IS A DEVELOPMENT AND DEBUGGING TOOL RATHER THAN
A USEFUL FTP USER INTERFACE. FEEL FREE TO USE IT.


            ***"
    .msg.f.f2.text configure -state disabled -fg darkgreen
}

/*  main ##########################################################################*/

/*  default file transfer mode ... active*/
 test = (mode) active

/*  Configuration file*/
 cnf = (configfile) "ftpdemo.cnf"
LoadConfig

Help