home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / tcl / expect / expect-4.7 / example / rftp < prev    next >
Encoding:
Text File  |  1993-04-12  |  8.7 KB  |  352 lines
  1. #!../expect -f
  2. # rftp - ftp a directory hierarchy (i.e. recursive ftp)
  3. # Version 2.6
  4. # Don Libes, NIST
  5.  
  6. # rftp is much like ftp except that the command ~g copies everything in
  7. # the remote current working directory to the local current working
  8. # directory.  Similarly ~p copies in the reverse direction.  ~l just
  9. # lists the remote directories.
  10.  
  11. # rftp takes an argument of the host to ftp to.  Username and password
  12. # are prompted for.  Other ftp options can be set interactively at that
  13. # time.  If your local ftp understands .netrc, that is also used.
  14.  
  15. # ~/.rftprc is sourced after the user has logged in to the remote site
  16. # and other ftp commands may be sent at that time.  .rftprc may also be
  17. # used to override the following rftp defaults.  The lines should use
  18. # the same syntax as these:
  19.  
  20. set file_timeout 3600        ;# timeout (seconds) for retrieving files
  21. set timeout 1000000        ;# timeout (seconds) for other ftp dialogue
  22. set default_type binary        ;# default type, i.e., ascii, binary, tenex
  23. set binary {}            ;# files matching are transferred as binary
  24. set ascii {}            ;# as above, but as ascii
  25. set tenex {}            ;# as above, but as tenex
  26.  
  27. # The values of binary, ascii and tenex should be a list of (Tcl) regular
  28. # expressions.  For example, the following definitions would force files
  29. # ending in *.Z and *.tar to be transferred as binaries and everything else
  30. # as text.
  31.  
  32. # set default_type ascii
  33. # set binary {*.Z *.tar}
  34.  
  35. # If you are on a UNIX machine, you can probably safely ignore all of this
  36. # and transfer everything as "binary".
  37.  
  38. # The current implementation requires that the source host be able to
  39. # provide directory listings in UNIX format.  Hence, you cannot copy
  40. # from a VMS host (although you can copy to it).  In fact, there is no
  41. # standard for the output that ftp produces, and thus, ftps that differ
  42. # significantly from the ubiquitous UNIX implementation may not work
  43. # with rftp (at least, not without changing the scanning and parsing).
  44.  
  45. ####################end of documentation###############################
  46.  
  47. trap exit SIGINT        ;# exit on ^C
  48. match_max -d 100000        ;# max size of a directory listing
  49.  
  50. # return name of file from one line of directory listing
  51. proc getname {line} {
  52.     # if it's a symbolic link, return local name
  53.     set i [lsearch line "->"]
  54.     if {-1==$i} {
  55.          # not a sym link, return last token of line as name
  56.          return [lindex $line [expr [llength $line]-1]]
  57.     } else {
  58.          # sym link, return "a" of "a -> b"
  59.          return [lindex $line [expr $i-1]]
  60.     }
  61. }
  62.  
  63. proc putfile {name} {
  64.     global current_type default_type
  65.     global binary ascii tenex
  66.     global file_timeout
  67.  
  68.     case $name    $binary    {set new_type binary} \
  69.             $ascii    {set new_type ascii} \
  70.             $tenex    {set new_type tenex} \
  71.             default    {set new_type $default_type}
  72.  
  73.     if 0!=[string compare $current_type $new_type] {
  74.         settype $new_type
  75.     }
  76.  
  77.     set timeout $file_timeout
  78.     send "put $name\r"
  79.     expect timeout {
  80.         send_user "ftp timed out in response to \"put $name\"\n"
  81.         exit
  82.     } "ftp>*"
  83. }
  84.  
  85. proc getfile {name} {
  86.     global current_type default_type
  87.     global binary ascii tenex
  88.     global file_timeout
  89.  
  90.     case $name    $binary    {set new_type binary} \
  91.             $ascii    {set new_type ascii} \
  92.             $tenex    {set new_type tenex} \
  93.             default    {set new_type $default_type}
  94.  
  95.     if 0!=[string compare $current_type $new_type] {
  96.         settype $new_type
  97.     }
  98.  
  99.     set timeout $file_timeout
  100.     send "get $name\r"
  101.     expect timeout {
  102.         send_user "ftp timed out in response to \"get $name\"\n"
  103.         exit
  104.     } "ftp>*"
  105. }
  106.  
  107. # returns 1 if successful, 0 otherwise
  108. proc putdirectory {name} {
  109.     send "mkdir $name\r"
  110.     expect "550*denied*ftp>*" {
  111.         send_user "failed to make remote directory $name\n"
  112.         return 0
  113.     } timeout {
  114.         send_user "timed out on make remote directory $name\n"
  115.         return 0
  116.     } -re "(257|550.*exists).*ftp>.*"
  117.     # 550 is returned if directory already exists
  118.  
  119.     send "cd $name\r"
  120.     expect "550*ftp>*" {
  121.         send_user "failed to cd to remote directory $name\n"
  122.         return 0
  123.     } timeout {
  124.         send_user "timed out on cd to remote directory $name\n"
  125.         return 0
  126.     } -re "2(5|0)0.*ftp>.*"
  127.     # some ftp's return 200, some return 250
  128.  
  129.     send "lcd $name\r"
  130.     # hard to know what to look for, since my ftp doesn't return status
  131.     # codes.  It is evidentally very locale-dependent.
  132.     # So, assume success.
  133.     expect "ftp>*"
  134.     putcurdirectory
  135.     send "lcd ..\r"
  136.     expect "ftp>*"
  137.     send "cd ..\r"
  138.     expect timeout {
  139.         send_user "failed to cd to remote directory ..\n"
  140.         return 0
  141.     } -re "2(5|0)0.*ftp>.*"
  142.  
  143.     return 1
  144. }
  145.  
  146. # returns 1 if successful, 0 otherwise
  147. proc getdirectory {name transfer} {
  148.     send "cd $name\r"
  149.     # this can fail normally if it's a symbolic link, and we are just
  150.     # experimenting
  151.     expect "550*ftp>*" {
  152.         send_user "failed to cd to remote directory $name\n"
  153.         return 0
  154.     } timeout {
  155.         send_user "timed out on cd to remote directory $name\n"
  156.         return 0
  157.     } -re "2(5|0)0.*ftp>.*"
  158.     # some ftp's return 200, some return 250
  159.  
  160.     if $transfer {
  161.         send "!mkdir $name\r"
  162.         expect "denied*" return timeout return "ftp>"
  163.         send "lcd $name\r"
  164.         # hard to know what to look for, since my ftp doesn't return
  165.         # status codes.  It is evidentally very locale-dependent.
  166.         # So, assume success.
  167.         expect "ftp>*"
  168.     }
  169.     getcurdirectory $transfer
  170.     if $transfer {
  171.         send "lcd ..\r"
  172.         expect "ftp>*"
  173.     }
  174.     send "cd ..\r"
  175.     expect timeout {
  176.         send_user "failed to cd to remote directory ..\n"
  177.         return 0
  178.     } -re "2(5|0)0.*ftp>.*"
  179.  
  180.     return 1
  181. }
  182.  
  183. proc putentry {name type} {
  184.     case $type in \
  185.     d {
  186.         # directory
  187.         if {0==[string compare $name .]
  188.          || 0==[string compare $name ..]} return
  189.         putdirectory $name
  190.     } - {
  191.         # file
  192.         putfile $name
  193.     } l {
  194.         # symlink, could be either file or directory
  195.         # first assume it's a directory
  196.         if [putdirectory $name] return
  197.         putfile $name
  198.     } default {
  199.         send_user "can't figure out what $name is, skipping\n"
  200.     }
  201. }
  202.  
  203. proc getentry {name type transfer} {
  204.     case $type in \
  205.     d {
  206.         # directory
  207.         getdirectory $name $transfer
  208.     } - {
  209.         # file
  210.         if !$transfer return
  211.         getfile $name
  212.     } l {
  213.         # symlink, could be either file or directory
  214.         # first assume it's a directory
  215.         if [getdirectory $name $transfer] return
  216.         if !$transfer return
  217.         getfile $name
  218.     } default {
  219.         send_user "can't figure out what $name is, skipping\n"
  220.     }
  221. }
  222.  
  223. proc putcurdirectory {} {
  224.     send "!ls -alg\r"
  225.     expect timeout {
  226.         send_user "failed to get directory listing\n"
  227.         return
  228.     } "ftp>*"
  229.  
  230.     set buf $expect_out(buffer)
  231.  
  232.     for {} 1 {} {
  233.         set split_buf [split $buf ""]
  234.  
  235.         # get a line from the response
  236.         set i [string first "\n" $buf]
  237.         # if end of listing, succeeded!
  238.         if $i==-1 return
  239.         set line [join [lrange $split_buf 0 $i] ""]
  240.         set buf [join [lrange $split_buf [expr 1+$i] end] ""]
  241.  
  242.         set token [lindex $line 0]
  243.         case $token in \
  244.         !ls {
  245.             # original command
  246.         } total {
  247.             # directory header
  248.         } . {
  249.             # unreadable
  250.         } default {
  251.             # either file or directory
  252.             set name [getname $line]
  253.             set type [lindex [split $line ""] 0]
  254.             putentry $name $type
  255.         }
  256.     }
  257. }
  258.  
  259.  
  260. # look at result of "dir".  If transfer==1, get all files and directories
  261. proc getcurdirectory {transfer} {
  262.     send "dir\r"
  263.     expect timeout {
  264.         send_user "failed to get directory listing\n"
  265.         return
  266.     } "ftp>*"
  267.  
  268.     set buf $expect_out(buffer)
  269.  
  270.     for {} 1 {} {
  271.         set split_buf [split $buf ""]
  272.  
  273.         # get a line from the response
  274.         set i [string first "\n" $buf]
  275.         set line [join [lrange $split_buf 0 $i] ""]
  276.         set buf [join [lrange $split_buf [expr 1+$i] end] ""]
  277.  
  278.         set token [lindex $line 0]
  279.         case $token in \
  280.         dir\r {
  281.             # original command
  282.         } 200 {
  283.             # command successful
  284.         } 150 {
  285.             # opening data connection
  286.         } total {
  287.             # directory header
  288.         } 226 {
  289.             # transfer complete, succeeded!
  290.             return
  291.         } ftp>* {
  292.             # next prompt, failed!
  293.             return
  294.         } . {
  295.             # unreadable
  296.         } default {
  297.             # either file or directory
  298.             set name [getname $line]
  299.             set type [lindex [split $line ""] 0]
  300.             getentry $name $type $transfer
  301.         }
  302.     }
  303. }
  304.  
  305. proc settype {t} {
  306.     global current_type
  307.  
  308.     send "type $t\r"
  309.     set current_type $t
  310.     expect "200*ftp>*"
  311. }
  312.  
  313. proc final_msg {} {
  314.     # write over the previous prompt with our message
  315.     send_user "\rQuit ftp or cd to another directory and press ~g, ~p, or ~l\n"
  316.     # and then reprompt
  317.     send_user "ftp> "
  318. }
  319.  
  320. if [file readable ~/.rftprc] {source ~/.rftprc}
  321. set first_time 1
  322.  
  323. if [llength $argv]>2 {
  324.     send_user "usage: rftp [host]
  325.     exit
  326. }
  327.  
  328. send_user "Once logged in, cd to the directory to be transferred and press:\n"
  329. send_user "~p to put the current directory from the local to the remote host\n"
  330. send_user "~g to get the current directory from the remote host to the local host\n"
  331. send_user "~l to list the current directory from the remote host\n"
  332.  
  333. if [llength $argv]==1 {spawn ftp} else {spawn ftp [lindex $argv 1]}
  334. interact -echo ~g {
  335.         if $first_time {
  336.             set first_time 0
  337.             settype $default_type
  338.         }
  339.         getcurdirectory 1
  340.         final_msg
  341. } -echo ~p {
  342.         if $first_time {
  343.             set first_time 0
  344.             settype $default_type
  345.         }
  346.         putcurdirectory
  347.         final_msg
  348. } -echo ~l {
  349.         getcurdirectory 0
  350.         final_msg
  351. }
  352.