home *** CD-ROM | disk | FTP | other *** search
/ H4CK3R 5 / hacker05 / 05_HACK_05.ISO / programacao / freewrap / TCLLIBsampleApp.exe / sample / tcllib / tcllib1.0 / ftp / ftpdemo.tcl < prev    next >
Encoding:
Text File  |  2001-08-17  |  26.9 KB  |  861 lines
  1. #!/bin/sh
  2. # the next line restarts using wish \
  3. exec wish8.3 "$0" "$@"
  4. #
  5. #   - simple tcl/tk test script for FTP library package -
  6. #
  7. #   Required:    tcl/tk8.3
  8. #
  9. #   Created:    07/97 
  10. #   Changed:    07/00 
  11. #   Version:    1.1
  12. #
  13. #   Copyright (C) 1997,1998 Steffen Traeger
  14. #    EMAIL:    Steffen.Traeger@t-online.de
  15. #    URL:    http://home.t-online.de/home/Steffen.Traeger
  16. #
  17. #   This program is free software; you can redistribute it and/or 
  18. #   modify it. 
  19. #   This program is distributed in the hope that it will be useful,
  20. #   but WITHOUT ANY WARRANTY; without even the implied warranty of
  21. #   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  22. #
  23. ########################################################################
  24.  
  25. package require Tcl 8
  26. package require Tk
  27. package require ftp 2.0
  28.  
  29. # set palette under X
  30. if { [string range [winfo server .] 0 0] == "X" } {
  31.     option add *background            LightGray
  32.     tk_setPalette LightGray
  33.     option add *Text.foreground        black
  34.     option add *Text.background        [option get . selectBackground Listbox]
  35.     option add *Listbox.background        [option get . selectBackground Listbox]
  36.     option add *Listbox.selectBackground     [option get . insertBackground Listbox]
  37.     option add *Listbox.selectForeground      white    
  38.     option add *Entry.background        [option get . selectBackground Listbox]
  39.     option add *Entry.selectBackground     [option get . insertBackground Listbox]
  40.     option add *Entry.selectForeground      white
  41.     option add *borderWidth            2
  42. } else {
  43.     option add *Checkbutton.borderWidth    0
  44.     option add *Radiobutton.borderWidth    0
  45.  
  46. }   
  47.  
  48. # main window
  49. wm title . "ftp Test"
  50. wm iconname . ftptest
  51. wm minsize . 1 1
  52.  
  53. # split area
  54. frame .msg -bd 1 -relief raised
  55.   pack .msg -in . -side top -fill both -expand 1
  56. frame .op -bd 1 -relief raised
  57.   pack .op -in . -side top -fill x
  58. frame .but -bd 1 -relief raised
  59.   pack .but -in . -side top -fill both -expand 1
  60.   
  61. ####################################################################
  62. # Frame 1
  63. #
  64. # Options
  65. frame .op.f -bd 3
  66.   pack .op.f -in .op -side top -fill x
  67.   
  68. ### options   
  69. frame .op.f.f1 -bd 3
  70.   pack .op.f.f1 -in .op.f -side left -fill both
  71. label .op.f.f1.l -bd 2 -text "Server Options: " -relief flat -anchor w
  72.   pack .op.f.f1.l -in .op.f.f1 -side top -fill x
  73.  
  74. frame .op.f.f1.server -bd 2
  75.   pack .op.f.f1.server -in .op.f.f1 -side top -fill x -padx 15
  76. label .op.f.f1.server.l -text "Host: " -width 10 -relief flat -anchor w
  77.   pack .op.f.f1.server.l -in .op.f.f1.server -side left -fill x
  78. entry .op.f.f1.server.e -width 20
  79.   pack .op.f.f1.server.e -in .op.f.f1.server -side left -fill x
  80.  
  81. frame .op.f.f1.port -bd 2
  82.   pack .op.f.f1.port -in .op.f.f1 -side top -fill x -padx 15
  83. label .op.f.f1.port.l -text "Port: " -width 10 -relief flat -anchor w
  84.   pack .op.f.f1.port.l -in .op.f.f1.port -side left -fill x
  85. entry .op.f.f1.port.e -width 5
  86.   pack .op.f.f1.port.e -in .op.f.f1.port -side left -fill x
  87.  
  88. frame .op.f.f1.username -bd 2
  89.   pack .op.f.f1.username -in .op.f.f1 -side top -fill x -padx 15
  90. label .op.f.f1.username.l -text "Username: " -width 10 -relief flat -anchor w
  91.   pack .op.f.f1.username.l -in .op.f.f1.username -side left -fill x
  92. entry .op.f.f1.username.e -width 10
  93.   pack .op.f.f1.username.e -in .op.f.f1.username -side left -fill x
  94.  
  95. frame .op.f.f1.password -bd 2
  96.   pack .op.f.f1.password -in .op.f.f1 -side top -fill x -padx 15
  97. label .op.f.f1.password.l -text "Password: " -width 10 -relief flat -anchor w
  98.   pack .op.f.f1.password.l -in .op.f.f1.password -side left -fill x
  99. entry .op.f.f1.password.e -width 10 -show "*"
  100.   pack .op.f.f1.password.e -in .op.f.f1.password -side left -fill x
  101.  
  102. frame .op.f.f1.directory -bd 2
  103.   pack .op.f.f1.directory -in .op.f.f1 -side top -fill x -padx 15
  104. label .op.f.f1.directory.l -text "Directory: " -width 10 -relief flat -anchor w
  105.   pack .op.f.f1.directory.l -in .op.f.f1.directory -side left -fill x
  106. entry .op.f.f1.directory.e -width 20
  107.   pack .op.f.f1.directory.e -in .op.f.f1.directory -side left -fill x
  108.  
  109. # Separator
  110. frame .op.f.sep1 -bd 1 -relief sunken
  111.   pack .op.f.sep1 -in .op.f -fill y -side left -pady 2 -padx 4
  112. frame .op.f.sep1.f -bd 1 -relief flat
  113.   pack .op.f.sep1.f -in .op.f.sep1 -fill y -side left
  114.  
  115. frame .op.f.f2 -bd 3
  116.   pack .op.f.f2 -in .op.f -side left -fill both -ipadx 15  
  117. ### transfer mode  
  118. label .op.f.f2.l2 -borderwidth 2 -anchor w -text "Transfer mode:" 
  119.   pack .op.f.f2.l2 -in .op.f.f2 -side top -fill x
  120. radiobutton .op.f.f2.active -anchor w -text "Active" -variable test(mode) -value "active"
  121.   pack .op.f.f2.active -in .op.f.f2 -side top -fill x -padx 15
  122. radiobutton .op.f.f2.passive -anchor w -text "Passive" -variable test(mode) -value "passive"
  123.   pack .op.f.f2.passive -in .op.f.f2 -side top -fill x -padx 15
  124.  
  125. ####################################################################
  126. # Frame 2 
  127. #
  128. ### debugging  
  129. label .op.f.f2.l1 -borderwidth 2 -anchor w -text "Debugging:" 
  130.   pack .op.f.f2.l1 -in .op.f.f2 -side top -fill x 
  131. checkbutton .op.f.f2.debug -anchor w -text "Debug" -variable ftp::DEBUG
  132.   pack .op.f.f2.debug -in .op.f.f2 -side top -fill x  -padx 15
  133. checkbutton .op.f.f2.verbose -anchor w -text "Verbose" -variable ftp::VERBOSE
  134.   pack .op.f.f2.verbose -in .op.f.f2 -side top -fill x -padx 15
  135.  
  136. #Iterations
  137. frame .op.f.f2.loops -bd 2
  138.   pack .op.f.f2.loops -in .op.f.f2 -side top -fill x -pady 2
  139. label .op.f.f2.loops.l -borderwidth 2 -text "Iterations: " -relief flat -anchor w
  140.   pack .op.f.f2.loops.l -in .op.f.f2.loops -side left -fill x
  141. entry .op.f.f2.loops.e -borderwidth 2 -width 5
  142.   pack .op.f.f2.loops.e -in .op.f.f2.loops -side left -fill x
  143.  
  144. # Separator
  145. frame .op.f.sep2 -bd 1 -relief sunken
  146.   pack .op.f.sep2 -in .op.f -fill y -side left -pady 2 -padx 4
  147. frame .op.f.sep2.f -bd 1 -relief flat
  148.   pack .op.f.sep2.f -in .op.f.sep2 -fill y -side left
  149.  
  150. ####################################################################
  151. # Frame 3
  152. #
  153. frame .op.f.f3 -bd 3
  154.   pack .op.f.f3 -in .op.f -side left -fill both -expand 1 -ipadx 15
  155.  
  156. label .op.f.f3.l1  -anchor w -width 10 -text "Variable trace:" 
  157.   pack .op.f.f3.l1 -in .op.f.f3 -side top -fill x 
  158.  
  159. frame .op.f.f3.v0 -bd 0
  160.   pack .op.f.f3.v0 -in .op.f.f3 -side top -fill x -pady 2 -padx 15
  161. label .op.f.f3.v0.name  -anchor w -text "iterations = " 
  162.   pack .op.f.f3.v0.name  -in .op.f.f3.v0 -side left -fill x 
  163. label .op.f.f3.v0.value -anchor w -textvariable test(loop)
  164.   pack .op.f.f3.v0.value -in .op.f.f3.v0 -side top -fill x
  165. frame .op.f.f3.v1 -bd 0
  166.   pack .op.f.f3.v1 -in .op.f.f3 -side top -fill x -pady 2 -padx 15
  167. label .op.f.f3.v1.name  -anchor w -text "errors = " 
  168.   pack .op.f.f3.v1.name  -in .op.f.f3.v1 -side left -fill x 
  169. label .op.f.f3.v1.value -anchor w -textvariable test(errors)
  170.   pack .op.f.f3.v1.value -in .op.f.f3.v1 -side top -fill x
  171. frame .op.f.f3.v2 -bd 0
  172.   pack .op.f.f3.v2 -in .op.f.f3 -side top -fill x -pady 2 -padx 15
  173. label .op.f.f3.v2.name  -anchor w -text "after queues = " 
  174.   pack .op.f.f3.v2.name  -in .op.f.f3.v2 -side left -fill x 
  175. label .op.f.f3.v2.value -anchor w -textvariable test(after) 
  176.   pack .op.f.f3.v2.value -in .op.f.f3.v2 -side top -fill x
  177. frame .op.f.f3.v4 -bd 0
  178.   pack .op.f.f3.v4 -in .op.f.f3 -side top -fill x -pady 2 -padx 15
  179. label .op.f.f3.v4.name  -anchor w -text "open channels:" 
  180.   pack .op.f.f3.v4.name  -in .op.f.f3.v4 -side top -fill x 
  181. label .op.f.f3.v4.value -anchor w -textvariable test(open) 
  182.   pack .op.f.f3.v4.value -in .op.f.f3.v4 -side top -fill x -padx 8
  183.  
  184. #####################################################################################
  185. # Messages
  186. frame .msg.f -bd 3
  187.   pack .msg.f -in .msg -side top -fill both -expand 1
  188.  
  189. frame .msg.f.f1 -bd 2 -relief groove 
  190.   pack .msg.f.f1 -in .msg.f -side left -fill both -padx 2 -pady 2
  191. label .msg.f.f1.l -text "Test commands: " -relief flat -anchor w
  192.   pack .msg.f.f1.l -in .msg.f.f1 -side top -fill x -padx 4 -pady 2
  193.  
  194. ### Test commands   
  195. set idlist {}  
  196. foreach {id text} {     quote "System Info"\
  197.             list "List" \
  198.             nlist "NList" \
  199.             dir "Cd, MkDir, RmDir" \
  200.             afile "ASCII Put/Get" \
  201.             bfile "Binary Put/Ret" \
  202.             ren "Rename" \
  203.             append "Append" \
  204.             new "Newer"  \
  205.             reget "Reget" \
  206.             notfound "file not found"} {
  207.     checkbutton .msg.f.f1.$id -anchor w -text $text -variable test($id)
  208.         pack .msg.f.f1.$id -in .msg.f.f1 -side top -fill x -padx 16
  209.       set test($id) 1
  210.       lappend idlist $id
  211. }
  212. button .msg.f.f1.plus -text "+ all" -command "foreach i {$idlist} {set test(\$i) 1}"
  213.   pack .msg.f.f1.plus -in .msg.f.f1 -side left -fill x -padx 16 -pady 8
  214. button .msg.f.f1.minus -text  "- all" -command "foreach i {$idlist} {set test(\$i) 0}"
  215.   pack .msg.f.f1.minus -in .msg.f.f1 -side left -fill x -pady 8
  216.  
  217. frame .msg.f.f2 -bd 2 -relief groove 
  218.   pack .msg.f.f2 -in .msg.f -side left -fill both -pady 2
  219.  
  220. label .msg.f.f2.label -text "Messages:" -anchor w
  221.   pack .msg.f.f2.label -in .msg.f.f2 -side top -fill x -padx 2
  222. scrollbar .msg.f.f2.yscroll -command ".msg.f.f2.text yview" 
  223.   pack .msg.f.f2.yscroll -in .msg.f.f2 -side right -fill y
  224. scrollbar .msg.f.f2.xscroll -relief sunken -orient horizontal -command ".msg.f.f2.text xview" 
  225.   pack .msg.f.f2.xscroll -in .msg.f.f2 -side bottom -fill x
  226. text .msg.f.f2.text -relief sunken -setgrid 1 -wrap none -height 20 -width 80 -bg white -fg black\
  227.     -state disabled  -xscrollcommand ".msg.f.f2.xscroll set" \
  228.     -yscrollcommand ".msg.f.f2.yscroll set"
  229.   pack .msg.f.f2.text -in .msg.f.f2 -side left  -expand 1 -fill both
  230. .msg.f.f2.text tag configure error -foreground red
  231. .msg.f.f2.text tag configure data -foreground brown
  232. .msg.f.f2.text tag configure control -foreground blue
  233. .msg.f.f2.text tag configure header -foreground white -background black
  234.  
  235. #####################################################################################
  236. # Buttons
  237. frame .but.f -bd 3
  238.   pack .but.f -in .but -side top -fill both -expand 1
  239.  
  240. frame .but.f.f1 -bd 3 
  241.   pack .but.f.f1 -in .but.f -side top -fill x -padx 15 -pady 6
  242. button .but.f.f1.start -text "Start Test" -width 12 -state normal -command "StartTest" 
  243.    pack .but.f.f1.start -side left -fill x  -padx 15 
  244. button .but.f.f1.stop -text "Stop Test" -width 12 -state disabled -command "StopTest" 
  245.    pack .but.f.f1.stop -side left -fill x  -padx 15 
  246. button .but.f.f1.close -text "Quit" -width 12 -state normal -command "destroy ." 
  247.    pack .but.f.f1.close -side right -fill x  -padx 15 
  248. button .but.f.f1.save -text "Save Options" -width 12 -state normal -command "SaveConfig" 
  249.    pack .but.f.f1.save -side right -fill x  -padx 15 
  250.  
  251. ################ procedures ####################################################################
  252.  
  253. # overwrite default ftp display message procedure
  254. namespace eval ftp {
  255. proc DisplayMsg {s msg {state ""}} {
  256. global test
  257.     .msg.f.f2.text configure -state normal
  258.     
  259.     # change state from "error" to "" for procedure test_9notfound
  260.     if { ($state == "error") && [info exist test(proc)] && ($test(proc) == "test_99notfound") } {
  261.         set state ""
  262.     }
  263.     
  264.     switch -exact -- $state {
  265.       data        {.msg.f.f2.text insert end "$msg\n" data}
  266.       control    {.msg.f.f2.text insert end "$msg\n" control}
  267.       error        {.msg.f.f2.text insert end "$msg\n" error; incr test(errors)}
  268.       header    {.msg.f.f2.text insert end "$msg\n" header}
  269.       default     {.msg.f.f2.text insert end "$msg\n"}
  270.     }
  271.     .msg.f.f2.text configure -state disabled
  272.     .msg.f.f2.text see end
  273.     update idletasks
  274. }}
  275.  
  276. # new tracing open command
  277. rename open ftpopen
  278. proc open {args} {
  279. global test
  280.     set rc [eval ftpopen $args]
  281.     if {[lsearch -exact $test(open) $rc] == "-1"} {
  282.         lappend test(open) $rc
  283.     }
  284. #puts "open: $test(open)"
  285.     return $rc
  286. }    
  287.  
  288. # new tracing close command
  289. rename close ftpclose
  290. proc close {args} {
  291. global test
  292.     set rc [eval ftpclose $args]
  293.     set index [lsearch -exact $test(open) $args]
  294.     if {$index != "-1"} {
  295.         set test(open) [lreplace $test(open) $index $index]
  296.     } 
  297. #puts "close: $test(open)"
  298.     return $rc
  299. }    
  300.  
  301. # new tracing socket command
  302. rename socket ftpsocket
  303. proc socket {args} {
  304. global test
  305.     set rc [eval ftpsocket $args]
  306.     if {[lsearch -exact $test(open) $rc] == "-1"} {
  307.         lappend test(open) $rc
  308.     } 
  309. #puts "socket: $test(open)"
  310.     return $rc
  311. }    
  312.  
  313.  
  314. # new tracing InitDataConn command
  315. namespace eval ftp {
  316. rename InitDataConn ftpInitDataConn 
  317. proc InitDataConn {args} {
  318. global test
  319.     set rc [eval ftpInitDataConn  $args]
  320.     set s [lindex $args 0]
  321.     if {[lsearch -exact $test(open) $s] == "-1"} {
  322.         lappend test(open) $s
  323.     } 
  324. #puts "InitDataConn: $test(open)"
  325.     return $rc
  326. }}
  327.  
  328. # progress bar for put/get operations 
  329. proc ProgressBar {state {bytes 0} {total {}} {filename {}}} {
  330. global progress
  331.     set w .progress
  332.     switch -exact -- $state {
  333.       init    {
  334.         set progress(percent) "0%"
  335.         set progress(total) $total
  336.         set progress(left) 0
  337.          toplevel $w -bd 0 -class Progressbar
  338.         wm transient $w .
  339.         wm title $w Progress
  340.             wm iconname $w Progress
  341.         wm resizable $w 0 0
  342.         focus $w
  343.         
  344.         frame $w.frame -bd 4
  345.             pack $w.frame -side top -fill both
  346.         label $w.frame.label -text "Transfering $filename..." -relief flat -anchor w -bd 1
  347.             pack $w.frame.label -in $w.frame -side top -fill x -padx 10 -pady 5
  348.         frame $w.frame.bar -bd 1 -relief sunken -bg #ffffff
  349.             pack $w.frame.bar -in $w.frame -side left -padx 10 -pady 5
  350.         frame $w.frame.bar.dummy -bd 0 -width 250 -height 0
  351.             pack $w.frame.bar.dummy -in $w.frame.bar -side top -fill x
  352.         frame $w.frame.bar.pbar -bd 0 -width 0 -height 20
  353.             pack $w.frame.bar.pbar -in $w.frame.bar -side left
  354.         label $w.frame.proz -textvariable progress(percent) -width 5 -relief flat -anchor e -bd 1
  355.             pack $w.frame.proz -in $w.frame -side right -padx 10 -pady 5
  356.  
  357.         wm withdraw $w
  358.         update idletasks
  359.         set x [expr {[winfo x .] + ([winfo width .] / 2) - ([winfo reqwidth $w] / 2)}]
  360.         set y [expr {[winfo y .] + ([winfo height .] / 2) - ([winfo reqheight $w] / 2)}]
  361.         wm geometry $w +$x+$y
  362.         update idletasks
  363.         wm deiconify $w
  364.         update idletasks
  365.        }
  366.  
  367.       update {
  368.          if {![winfo exist $w]} {return}  
  369.         set cur_width 250
  370.         catch {
  371.             set progress(percent) "[expr {round($bytes) * 100 / $progress(total)}]%";
  372.             set cur_width [expr {round($bytes * 250 / $progress(total))}]
  373.         } msg
  374.         $w.frame.bar.pbar configure -width $cur_width -bg #000080
  375.         update idletasks
  376.       }
  377.  
  378.       done     {
  379.           unset progress
  380.         destroy $w
  381.         update
  382.       }
  383.       default {
  384.           error "Unknown state \"$state\""
  385.       }
  386.     }
  387. }
  388.  
  389. #
  390. # 1.) list -  returns a long list
  391. #
  392. proc test_10list {loop} {
  393. global test
  394.  
  395.     # check if enabled
  396.     if {!$test(list)} {return}
  397.  
  398.     ftp::DisplayMsg $test(conn) "*** TEST $loop.1 (long directory listing)  ***" header
  399.     set remote_list [ftp::List $test(conn)]        
  400.     ftp::DisplayMsg $test(conn) "[llength $remote_list] directory lines!"
  401. }
  402.  
  403. #
  404. # 2.) nlist - returns a sorted short list
  405. #
  406. proc test_20nlist {loop} {
  407. global test
  408.  
  409.     # check if enabled
  410.     if {!$test(nlist)} {return}
  411.  
  412.     ftp::DisplayMsg $test(conn) "*** TEST $loop.2 (short directory listing) ***" header
  413.     set remote_list [ftp::NList $test(conn)]
  414.     ftp::DisplayMsg $test(conn) "[llength $remote_list] directory entries!" 
  415. }
  416.  
  417.  
  418. #
  419. # 3.) directory commands (cd, mkdir, rmdir)
  420. #    - creates a remote directory foo
  421. #    - changes to this directory
  422. #    - changes back to parent directory
  423. #    - removes a remote directory foo
  424. #
  425. proc test_30dir {loop} {
  426. global test
  427.  
  428.     # check if enabled
  429.     if {!$test(dir)} {return}
  430.     ftp::DisplayMsg $test(conn) "*** TEST $loop.3 (directory commands cd,mkdir,rmdir) ***" header
  431.     ftp::Pwd $test(conn)
  432.     ftp::MkDir $test(conn) foo$test(pid)
  433.     ftp::Cd $test(conn) foo$test(pid)
  434.     ftp::Pwd $test(conn)
  435.     ftp::Cd $test(conn) ..
  436.     ftp::Pwd $test(conn)
  437.     ftp::RmDir $test(conn) foo$test(pid)
  438. }
  439.  
  440. #
  441. # 4.) ascii put/get and delete
  442. #    - go to ascii mode
  443. #    - store a file to remote site
  444. #    - retrieve the same file from remote site
  445. #    - delete a file on remote site
  446. #    - compare the size of both files
  447. #      (file sizes should be equal or only the "\r" difference 
  448. #       between DOS/WINDOWS <> UNIX
  449. #
  450. proc test_40afile {loop} {
  451. global test
  452.  
  453.     # check if enabled
  454.     if {!$test(afile)} {return}
  455.  
  456.     ftp::DisplayMsg $test(conn) "*** TEST $loop.4 (put/get ascii files) ***" header
  457.     set ascii_file ftp.tcl
  458.     set lsize [file size $ascii_file]
  459.     ftp::Type $test(conn) ascii    
  460.     ftp::Put $test(conn) $ascii_file ignore$test(pid).tmp
  461.  
  462.     # FileSize only works proper in binary mode
  463.     ftp::Type $test(conn) binary
  464.     set rsize [ftp::FileSize $test(conn) ignore$test(pid).tmp]
  465.     ftp::Type $test(conn) ascii    
  466.     ftp::Get $test(conn) ignore$test(pid).tmp
  467.     ftp::Delete $test(conn) ignore$test(pid).tmp
  468.  
  469.     catch {
  470.           ftp::DisplayMsg $test(conn) "Original File:\t$lsize bytes"
  471.         ftp::DisplayMsg $test(conn) "Stored File:\t$rsize bytes"
  472.           ftp::DisplayMsg $test(conn) "Retrieved File:\t[file size ignore$test(pid).tmp] bytes"
  473.         file delete ignore$test(pid).tmp    }
  474.  
  475. }
  476.  
  477. #
  478. # 5.) binary put/get
  479. #    - switch to binary mode
  480. #    - store a file to remote site
  481. #    - retrieve the same file from remote site
  482. #    - delete a file on remote site
  483. #    - compare the size of both files
  484. #
  485. proc test_50bfile {loop} {
  486. global test tk_library
  487.  
  488.     # check if enabled
  489.     if {!$test(bfile)} {return}
  490.  
  491.     ftp::DisplayMsg $test(conn) "*** TEST $loop.5 (put/get binary files) ***" header
  492.     set bin_file $tk_library/demos/images/teapot.ppm
  493.     set lsize [file size $bin_file]
  494.     ftp::Type $test(conn) binary
  495.  
  496.     # Put with ProgressBar
  497.     #   - ProgressBar init ...
  498.     #   - ProgressBar update ... callback defined in ftp!
  499.     #   - ProgressBar done
  500.     ProgressBar init 0 $lsize teapot.ppm
  501.     ftp::Put $test(conn) $bin_file ignore$test(pid).tmp
  502.     ProgressBar done
  503.     
  504.     # Put with ProgressBar
  505.     set rsize [ftp::FileSize $test(conn) ignore$test(pid).tmp]
  506.     ProgressBar init 0 $rsize ignore$test(pid).tmp
  507.     ftp::Get $test(conn) ignore$test(pid).tmp
  508.     ProgressBar done
  509.     
  510.     ftp::Delete $test(conn) ignore$test(pid).tmp
  511.  
  512.     catch {
  513.         ftp::DisplayMsg $test(conn) "Original File:\t$lsize bytes"
  514.         ftp::DisplayMsg $test(conn) "Stored File:\t$rsize bytes"
  515.         ftp::DisplayMsg $test(conn) "Retrieved File:\t[file size ignore$test(pid).tmp] bytes"
  516.         file delete ignore$test(pid).tmp
  517.     }
  518.     
  519. }
  520.  
  521. #
  522. # 6.) rename
  523. #    - stores a binary file on remote site and renames it
  524. #
  525. proc test_60ren {loop} {
  526. global test tk_library
  527.  
  528.     # check if enabled
  529.     if {!$test(ren)} {return}
  530.  
  531.     ftp::DisplayMsg $test(conn) "*** TEST $loop.6 (renaming remote files) ***" header
  532.     set bin_file $tk_library/demos/images/earth.gif
  533.     ftp::Type $test(conn) binary
  534.     ftp::Put $test(conn) $bin_file ignore$test(pid).tmp
  535.     ftp::Rename $test(conn) ignore$test(pid).tmp renamed$test(pid).tmp 
  536.     ftp::Delete $test(conn) renamed$test(pid).tmp    
  537.  
  538. }
  539. #
  540. # 7.) append
  541. #    - go to ascii mode
  542. #    - store a ascii file to remote site
  543. #    - appends ascci file on remote site and renames it
  544. #    - delete a file on remote site
  545. #    - compare the size of both files 
  546. #      remote file must have the double size
  547. #      (file sizes should be equal or only the "\r" difference 
  548. #       between DOS/WINDOWS <> UNIX
  549. #
  550. proc test_70append {loop} {
  551. global test tk_library
  552.  
  553.     # check if enabled
  554.     if {!$test(append)} {return}
  555.  
  556.     ftp::DisplayMsg $test(conn) "*** TEST $loop.7 (append ascii file) ***" header
  557.     set ascii_file ftp.tcl
  558.     set lsize [file size $ascii_file]
  559.     ftp::Type $test(conn) ascii    
  560.     ftp::Append $test(conn) $ascii_file ignore$test(pid).tmp
  561.     ftp::Append $test(conn) $ascii_file ignore$test(pid).tmp
  562.     ftp::Get $test(conn) ignore$test(pid).tmp
  563.     ftp::Delete $test(conn) ignore$test(pid).tmp
  564.  
  565.     catch {
  566.           ftp::DisplayMsg $test(conn) "Original File:\t$lsize bytes ( * 2 = [expr {$lsize * 2}])"
  567.           ftp::DisplayMsg $test(conn) "Appended File:\t[file size ignore$test(pid).tmp] bytes"
  568.         file delete ignore$test(pid).tmp    }
  569.  
  570. }
  571.  
  572. #
  573. # 8.) newer
  574. #    - create a local copy of a a file
  575. #    - create a remote copy of a a file
  576. #    - check date entries
  577. #    - transfer only if the specifieid file is newer
  578. #
  579. proc test_80new {loop} {
  580. global test tk_library
  581.  
  582.     # check if enabled
  583.     if {!$test(new)} {return}
  584.  
  585.     ftp::DisplayMsg $test(conn) "*** TEST $loop.8 (newer) ***" header
  586.     set bin_file $tk_library/demos/images/earth.gif
  587.     ftp::Type $test(conn) binary
  588.  
  589.     file copy $bin_file ignore$test(pid).tmp
  590.     ftp::Put $test(conn) $bin_file ignore$test(pid).tmp
  591.     set datestr "%m/%d/%Y, %H:%M"
  592.  
  593.     set out {}
  594.     catch {
  595.          append out "Local File:\t[clock format [file mtime ignore$test(pid).tmp] -format $datestr -gmt 1]" \n
  596.         append out "Remote File:\t[clock format [ftp::ModTime $test(conn) ignore$test(pid).tmp] -format $datestr -gmt 1]" \n
  597.     }
  598.  
  599.     ftp::Newer $test(conn) ignore$test(pid).tmp    
  600.     
  601.     catch {    
  602.         append out "Local File:\t[clock format [file mtime ignore$test(pid).tmp] -format $datestr -gmt 1] (after ftp::Newer)" 
  603.     }
  604.  
  605.     ftp::Delete $test(conn) ignore$test(pid).tmp
  606.     catch {file delete ignore$test(pid).tmp}
  607.     ftp::DisplayMsg $test(conn) $out
  608.  
  609. }
  610.  
  611. #
  612. # 9.) reget - reget command
  613. #    - store file to remote site
  614. #    - write 6 bytes to local file
  615. #    - test the reget at position 6
  616. #
  617. proc test_90reget {loop} {
  618. global test tk_library
  619.  
  620.     # check if enabled
  621.     if {!$test(reget)} {return}
  622.  
  623.     ftp::DisplayMsg $test(conn) "*** TEST $loop.9 (reget command) ***" header
  624.     set bin_file $tk_library/demos/images/earth.gif
  625.     ftp::Type $test(conn) binary
  626.     ftp::Put $test(conn) $bin_file ignore$test(pid).tmp
  627.     set f [open ignore$test(pid).tmp w]
  628.     puts -nonewline $f "123456"
  629.     close $f
  630.     ftp::Reget $test(conn) ignore$test(pid).tmp
  631.     ftp::Delete $test(conn) ignore$test(pid).tmp
  632.  
  633.     catch {
  634.         ftp::DisplayMsg $test(conn) "Original File:\t\t[file size $bin_file]"
  635.         ftp::DisplayMsg $test(conn) "Transfered  File:\t[file size ignore$test(pid).tmp]"
  636.         file delete ignore$test(pid).tmp
  637.     }
  638. }
  639.  
  640. ##
  641. # 10.) not existing file/directory
  642. #    all command with a not existing file name as parameter
  643. #    - nlist, filesize, modtime, delete, rename, cd, rmdir, put, get, reget, newer
  644. #    - write 6 bytes to local file
  645. #    - test the reget at position 6
  646. #
  647. proc test_99notfound {loop} {
  648. global test tk_library
  649.  
  650.     # check if enabled
  651.     if {!$test(notfound)} {return}
  652.  
  653.     ftp::DisplayMsg $test(conn) "*** TEST $loop.10 (not existing file/directory) ***" header
  654.     ftp::NList $test(conn) filenotfound        
  655.     ftp::FileSize $test(conn) filenotfound        
  656.     ftp::ModTime $test(conn) filenotfound        
  657.     ftp::Rename $test(conn) filenotfound filenotfound
  658.     ftp::Delete $test(conn) filenotfound
  659.     ftp::Cd $test(conn) filenotfound
  660.     ftp::RmDir $test(conn) filenotfound
  661.     ftp::Put $test(conn) filenotfound
  662.     ftp::Get $test(conn) filenotfound
  663.     ftp::Reget $test(conn) filenotfound
  664.     ftp::Newer $test(conn) filenotfound
  665. }
  666.  
  667. # save preferences
  668. proc SaveConfig {} {
  669. global cnf
  670.  
  671.     set cnf(server) [.op.f.f1.server.e get]
  672.     set cnf(port) [.op.f.f1.port.e get]
  673.     set cnf(username) [.op.f.f1.username.e get]
  674.     set cnf(password) [.op.f.f1.password.e get]
  675.     set cnf(directory) [.op.f.f1.directory.e get]
  676.     set cnf(loops) [.op.f.f2.loops.e get]
  677.     set cnf(debug) $ftp::DEBUG
  678.     set cnf(verbose) $ftp::VERBOSE
  679.  
  680.     set f [open $cnf(configfile) w]
  681.     puts $f  [array get cnf]    
  682.     close $f
  683. }
  684.  
  685. # load preferences
  686. proc LoadConfig {} {
  687. global cnf
  688.  
  689.     # Defaults
  690.     set cnf(server) "xxx"
  691.     set cnf(port) 21
  692.     set cnf(username) "xxx"
  693.     set cnf(password) "xxx"
  694.     set cnf(directory) ""
  695.     set cnf(loops) 1
  696.     set cnf(debug) 0
  697.     set cnf(verbose) 1
  698.     
  699.     if {[file exists $cnf(configfile)]} {
  700.         set f [open $cnf(configfile) r]
  701.         array set cnf [read $f]
  702.         close $f
  703.     }
  704.     
  705.     .op.f.f1.server.e delete 0 end
  706.     .op.f.f1.server.e insert 0 $cnf(server)
  707.     .op.f.f1.port.e delete 0 end
  708.     .op.f.f1.port.e insert 0 $cnf(port)
  709.     .op.f.f1.username.e delete 0 end
  710.     .op.f.f1.username.e insert 0 $cnf(username)
  711.     .op.f.f1.password.e delete 0 end
  712.     .op.f.f1.password.e insert 0 $cnf(password)
  713.     .op.f.f1.directory.e delete 0 end
  714.     .op.f.f1.directory.e insert 0 $cnf(directory)
  715.     .op.f.f2.loops.e delete 0 end
  716.     .op.f.f2.loops.e insert 0 $cnf(loops)
  717.     set ::ftp::DEBUG $cnf(debug)
  718.     set ::ftp::VERBOSE $cnf(verbose)
  719. }
  720.  
  721. # stop the test
  722. proc StopTest {} {
  723. global test
  724.     set test(break) 1
  725. }
  726.  
  727. # start the test
  728. proc StartTest {} {
  729. global test
  730.  
  731.     .but.f.f1.stop configure -state normal
  732.     .but.f.f1.start configure -state disabled
  733.     
  734.     .msg.f.f2.text configure -state normal
  735.     .msg.f.f2.text delete 1.0 end
  736.     .msg.f.f2.text configure -state disabled -fg black
  737.  
  738.     set loops [.op.f.f2.loops.e get]
  739.     set server [.op.f.f1.server.e get]
  740.     set port [.op.f.f1.port.e get]
  741.     set username [.op.f.f1.username.e get]
  742.     set passwd [.op.f.f1.password.e get]
  743.     set dir [.op.f.f1.directory.e get]
  744.  
  745.     # open a ftp server connection
  746.     set test(errors) 0
  747.     set test(open) {}
  748.     set test(pid) [pid]
  749.     set start_time [clock seconds]
  750.      ftp::DisplayMsg "" "*** Test started at [clock format [clock seconds]  -format %d.%m.%Y\ %H:%M:%S ] ..." header
  751.     if {[set conn [ftp::Open $server $username $passwd -port $port -progress {ProgressBar update} -mode $test(mode) -blocksize 8196 -timeout 60]] >= 0} {
  752.  
  753.         if {$test(quote)} {
  754.             ftp::DisplayMsg $conn [ftp::Quote $conn syst]
  755.                 ftp::DisplayMsg $conn [ftp::Quote $conn site umask 022]
  756.                 ftp::DisplayMsg $conn [ftp::Quote $conn help]
  757.             }
  758.                
  759.                
  760.         if { $dir != "" } {
  761.             ftp::Cd $conn $dir
  762.         }
  763.         
  764.             # begin test loop
  765.             set test(break) 0
  766.                 set test(conn) $conn
  767.             for {set test(loop) 1} {$test(loop) <= $loops} {incr test(loop)} {
  768.                 if {$test(break)} {break}
  769.             foreach test(proc) [lsort [info proc test*]] {
  770.                     if {$test(break)} {break}
  771.                     
  772.                     # count entries in the after queues
  773.                     set test(after) [after info]
  774.  
  775.                     # run procedure
  776.                 eval $test(proc) $test(loop) 
  777.             }
  778.             }
  779.             if {$test(break)} {
  780.                 ftp::DisplayMsg "... user break!" error
  781.             } else {
  782.             incr test(loop) -1
  783.         }
  784.         
  785.             ftp::Close $conn
  786.         set stop_time [clock seconds]
  787.         set elapsed [expr {$stop_time - $start_time}]
  788.         if { $elapsed == 0 } { set elapsed 1}
  789.             ftp::DisplayMsg "" "************************* THE END *************************" header
  790.             ftp::DisplayMsg "" "=> $loops iterations takes $elapsed seconds" 
  791.          ftp::DisplayMsg "" "=> $test(errors) error(s) occured" 
  792.     }
  793.     .but.f.f1.stop configure -state disabled
  794.     .but.f.f1.start configure -state normal
  795. }
  796.  
  797. # Help
  798. proc Help {} {
  799.     .msg.f.f2.text configure -state normal
  800.     .msg.f.f2.text delete 1.0 end
  801.     .msg.f.f2.text insert 1.0 "          **** CONFIGURATION HELP *****
  802.     
  803. Ftp_demo is the simple user interface to the ftp test program. It
  804. checks all ftp commands of the FTP library package against an
  805. existing FTP server. It requires some configuration entries specified
  806. in the form below.
  807.  
  808. - Host ... Host FTP server on which the connection will be established
  809. - Username ... Users login name at host 
  810. - Password ... Users password at host 
  811. - Directory ... Starting directory when differs from root \"/\"
  812. - Iterations ... Count of interations for the test algorithm (default 1)    
  813.  
  814. The message window shows all responses from the remote server, as well
  815. as report on data transfer statistics and file sizes. Two switches 
  816. toggles enhanced output:
  817.  
  818. 1. Debug...Enables debugging (return code, state, real FTP commands )
  819. 2. Verbose ... Forces to show all responses from the FTP server 
  820.  
  821. Active or passive file transfer mode is selected in the upper frame.
  822. When ftpdemo uses the active mode it waits for the server to open
  823. a connection to transfer files or get file listings. In passive mode
  824. the server waits for ftpdemo to open a connection to transfer files
  825. or get file listings. Passive mode is normally a requirement when
  826. accessing sites via a firewall.
  827.  
  828. Press \"Save Options\" to save these options in a configuration file. 
  829. Options will be restored next time you start the ftpdemo program.
  830. Check marked test commands and start test by pressing \"Start test\"
  831. button. Any time the test program can be canceled by pressing the
  832. \"Stop test\" button.
  833.  
  834. NOTE:
  835. -----
  836. THE FTP_DEMO PROGRAM IS A DEVELOPMENT AND DEBUGGING TOOL RATHER THAN
  837. A USEFUL FTP USER INTERFACE. FEEL FREE TO USE IT.
  838.  
  839.  
  840.             ***"
  841.     .msg.f.f2.text configure -state disabled -fg darkgreen
  842. }
  843.  
  844. ################ main ##########################################################################
  845.  
  846. # default file transfer mode ... active
  847. set test(mode) active
  848.  
  849. # Configuration file
  850. set cnf(configfile) "ftpdemo.cnf"
  851. LoadConfig
  852.  
  853. Help
  854.  
  855.  
  856.  
  857.  
  858.  
  859.  
  860.  
  861.