1# ftp.tcl -- 2# 3# FTP library package for Tcl 8.2+. Originally written by Steffen 4# Traeger (Steffen.Traeger@t-online.de); modified by Peter MacDonald 5# (peter@pdqi.com) to support multiple simultaneous FTP sessions; 6# Modified by Steve Ball (Steve.Ball@zveno.com) to support 7# asynchronous operation. 8# 9# Copyright (c) 1996-1999 by Steffen Traeger <Steffen.Traeger@t-online.de> 10# Copyright (c) 2000 by Ajuba Solutions 11# Copyright (c) 2000 by Zveno Pty Ltd 12# 13# See the file "license.terms" for information on usage and redistribution 14# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 15# 16# RCS: @(#) $Id: ftp.tcl,v 1.47 2008/08/05 20:34:32 andreas_kupries Exp $ 17# 18# core ftp support: ftp::Open <server> <user> <passwd> <?options?> 19# ftp::Close <s> 20# ftp::Cd <s> <directory> 21# ftp::Pwd <s> 22# ftp::Type <s> <?ascii|binary|tenex?> 23# ftp::List <s> <?directory?> 24# ftp::NList <s> <?directory?> 25# ftp::FileSize <s> <file> 26# ftp::ModTime <s> <file> <?newtime?> 27# ftp::Delete <s> <file> 28# ftp::Rename <s> <from> <to> 29# ftp::Put <s> <(local | -data "data" -channel chan)> <?remote?> 30# ftp::Append <s> <(local | -data "data" | -channel chan)> <?remote?> 31# ftp::Get <s> <remote> <?(local | -variable varname | -channel chan)?> 32# ftp::Reget <s> <remote> <?local?> 33# ftp::Newer <s> <remote> <?local?> 34# ftp::MkDir <s> <directory> 35# ftp::RmDir <s> <directory> 36# ftp::Quote <s> <arg1> <arg2> ... 37# 38# Internal documentation. Contents of a session state array. 39# 40# --------------------------------------------- 41# key value 42# --------------------------------------------- 43# State Current state of the session and the currently executing command. 44# RemoteFileName Name of the remote file, for put/get 45# LocalFileName Name of local file, for put/get 46# inline 1 - Put/Get is inline (from data, to variable) 47# filebuffer 48# PutData Data to move when inline 49# SourceCI Channel to read from, "Put" 50# --------------------------------------------- 51# 52 53package require Tcl 8.2 54package require log ; # tcllib/log, general logging facility. 55 56namespace eval ::ftp { 57 namespace export DisplayMsg Open Close Cd Pwd Type List NList \ 58 FileSize ModTime Delete Rename Put Append Get Reget \ 59 Newer Quote MkDir RmDir 60 61 variable serial 0 62 variable VERBOSE 0 63 variable DEBUG 0 64} 65 66############################################################################# 67# 68# DisplayMsg -- 69# 70# This is a simple procedure to display any messages on screen. 71# Can be intercepted by the -output option to Open 72# 73# namespace ftp { 74# proc DisplayMsg {msg} { 75# ...... 76# } 77# } 78# 79# Arguments: 80# msg - message string 81# state - different states {normal, data, control, error} 82# 83proc ::ftp::DisplayMsg {s msg {state ""}} { 84 85 upvar ::ftp::ftp$s ftp 86 87 if { ([info exists ftp(Output)]) && ($ftp(Output) != "") } { 88 eval [concat $ftp(Output) {$s $msg $state}] 89 return 90 } 91 92 # FIX #476729. Instead of changing the documentation this 93 # procedure is changed to enforce the documented 94 # behaviour. IOW, this procedure will not throw 95 # errors anymore. At the same time printing to stdout 96 # is exchanged against calls into the 'log' module 97 # tcllib, which is much easier to customize for the 98 # needs of any application using the ftp module. The 99 # variable VERBOSE is still relevant as it controls 100 # whether this procedure is called or not. 101 102 global errorInfo 103 switch -exact -- $state { 104 data {log::log debug "$state | $msg"} 105 control {log::log debug "$state | $msg"} 106 error {log::log error "$state | E: $msg:\n$errorInfo"} 107 default {log::log debug "$state | $msg"} 108 } 109 return 110} 111 112############################################################################# 113# 114# Timeout -- 115# 116# Handle timeouts 117# 118# Arguments: 119# - 120# 121proc ::ftp::Timeout {s} { 122 upvar ::ftp::ftp$s ftp 123 124 after cancel $ftp(Wait) 125 set ftp(state.control) 1 126 127 DisplayMsg "" "Timeout of control connection after $ftp(Timeout) sec.!" error 128 Command $ftp(Command) timeout 129 return 130} 131 132############################################################################# 133# 134# WaitOrTimeout -- 135# 136# Blocks the running procedure and waits for a variable of the transaction 137# to complete. It continues processing procedure until a procedure or 138# StateHandler sets the value of variable "finished". 139# If a connection hangs the variable is setting instead of by this procedure after 140# specified seconds in $ftp(Timeout). 141# 142# 143# Arguments: 144# - 145# 146 147proc ::ftp::WaitOrTimeout {s} { 148 upvar ::ftp::ftp$s ftp 149 150 set retvar 1 151 152 if { ![string length $ftp(Command)] && [info exists ftp(state.control)] } { 153 154 set ftp(Wait) [after [expr {$ftp(Timeout) * 1000}] [list [namespace current]::Timeout $s]] 155 156 vwait ::ftp::ftp${s}(state.control) 157 set retvar $ftp(state.control) 158 } 159 160 if {$ftp(Error) != ""} { 161 set errmsg $ftp(Error) 162 set ftp(Error) "" 163 DisplayMsg $s $errmsg error 164 } 165 166 return $retvar 167} 168 169############################################################################# 170# 171# WaitComplete -- 172# 173# Transaction completed. 174# Cancel execution of the delayed command declared in procedure WaitOrTimeout. 175# 176# Arguments: 177# value - result of the transaction 178# 0 ... Error 179# 1 ... OK 180# 181 182proc ::ftp::WaitComplete {s value} { 183 upvar ::ftp::ftp$s ftp 184 185 if {![info exists ftp(Command)]} { 186 set ftp(state.control) $value 187 return $value 188 } 189 if { ![string length $ftp(Command)] && [info exists ftp(state.data)] } { 190 vwait ::ftp::ftp${s}(state.data) 191 } 192 193 catch {after cancel $ftp(Wait)} 194 set ftp(state.control) $value 195 return $ftp(state.control) 196} 197 198############################################################################# 199# 200# PutsCtrlSocket -- 201# 202# Puts then specified command to control socket, 203# if DEBUG is set than it logs via DisplayMsg 204# 205# Arguments: 206# command - ftp command 207# 208 209proc ::ftp::PutsCtrlSock {s {command ""}} { 210 upvar ::ftp::ftp$s ftp 211 variable DEBUG 212 213 if { $DEBUG } { 214 DisplayMsg $s "---> $command" 215 } 216 217 puts $ftp(CtrlSock) $command 218 flush $ftp(CtrlSock) 219 return 220} 221 222############################################################################# 223# 224# StateHandler -- 225# 226# Implements a finite state handler and a fileevent handler 227# for the control channel 228# 229# Arguments: 230# sock - socket name 231# If called from a procedure than this argument is empty. 232# If called from a fileevent than this argument contains 233# the socket channel identifier. 234 235proc ::ftp::StateHandler {s {sock ""}} { 236 upvar ::ftp::ftp$s ftp 237 variable DEBUG 238 variable VERBOSE 239 240 # disable fileevent on control socket, enable it at the and of the state machine 241 # fileevent $ftp(CtrlSock) readable {} 242 243 # there is no socket (and no channel to get) if called from a procedure 244 245 set rc " " 246 set msgtext {} 247 248 if { $sock != "" } { 249 250 set number 0 ;# Error condition 251 catch {set number [gets $sock bufline]} 252 253 if { $number > 0 } { 254 255 # get return code, check for multi-line text 256 257 if {![regexp -- "^-?(\[0-9\]+)( |-)?(.*)$" $bufline all rc multi_line msgtext]} { 258 set errmsg "C: Internal Error @ line 255.\ 259 Regex pattern not matching the input \"$bufline\"" 260 if {$VERBOSE} { 261 DisplayMsg $s $errmsg control 262 } 263 } else { 264 # multi-line format detected ("-"), get all the lines 265 # until the real return code 266 267 set buffer $bufline 268 269 while { [string equal $multi_line "-"] } { 270 set number [gets $sock bufline] 271 if { $number > 0 } { 272 append buffer \n "$bufline" 273 regexp -- "(^\[0-9\]+)( |-)?(.*)$" $bufline all rc multi_line 274 # multi_line is not set if the bufline does not match the regexp, 275 # I.e. this keeps the '-' which started this around until the 276 # closing line does match and sets it to space. 277 } 278 } 279 280 # Export the accumulated response. [Bug 1191607]. 281 set msgtext $buffer 282 } 283 } elseif { [eof $ftp(CtrlSock)] } { 284 # remote server has closed control connection. kill 285 # control socket, unset State to disable all following 286 # commands. Killing the socket is done before 287 # 'WaitComplete' to prevent it from recursively entering 288 # this code, overflowing the stack (socket still existing, 289 # still readable, still eof). [SF Tcllib Bug 15822535]. 290 291 set rc 421 292 catch {close $ftp(CtrlSock)} 293 catch {unset ftp(CtrlSock)} 294 catch {unset ftp(state.data)} 295 if { $VERBOSE } { 296 DisplayMsg $s "C: 421 Service not available, closing control connection." control 297 } 298 if {![string equal $ftp(State) "quit_sent"]} { 299 set ftp(Error) "Service not available!" 300 } 301 CloseDataConn $s 302 WaitComplete $s 0 303 Command $ftp(Command) terminated 304 catch {unset ftp(State)} 305 return 306 } else { 307 # Fix SF bug #466746: Incomplete line, do nothing. 308 return 309 } 310 } 311 312 if { $DEBUG } { 313 DisplayMsg $s "-> rc=\"$rc\"\n-> msgtext=\"$msgtext\"\n-> state=\"$ftp(State)\"" 314 } 315 316 # In asynchronous mode, should we move on to the next state? 317 set nextState 0 318 319 # system status replay 320 if { [string equal $rc "211"] } { 321 return 322 } 323 324 # use only the first digit 325 regexp -- "^\[0-9\]?" $rc rc 326 327 switch -exact -- $ftp(State) { 328 user { 329 switch -exact -- $rc { 330 2 { 331 PutsCtrlSock $s "USER $ftp(User)" 332 set ftp(State) passwd 333 Command $ftp(Command) user 334 } 335 default { 336 set errmsg "Error connecting! $msgtext" 337 set complete_with 0 338 Command $ftp(Command) error $errmsg 339 } 340 } 341 } 342 passwd { 343 switch -exact -- $rc { 344 2 { 345 set complete_with 1 346 Command $ftp(Command) password 347 } 348 3 { 349 PutsCtrlSock $s "PASS $ftp(Passwd)" 350 set ftp(State) connect 351 Command $ftp(Command) password 352 } 353 default { 354 set errmsg "Error connecting! $msgtext" 355 set complete_with 0 356 Command $ftp(Command) error $msgtext 357 } 358 } 359 } 360 connect { 361 switch -exact -- $rc { 362 2 { 363 # The type is set after this, and we want to report 364 # that the connection is complete once the type is done 365 set nextState 1 366 if {[info exists ftp(NextState)] && ![llength $ftp(NextState)]} { 367 Command $ftp(Command) connect $s 368 } else { 369 set complete_with 1 370 } 371 } 372 default { 373 set errmsg "Error connecting! $msgtext" 374 set complete_with 0 375 Command $ftp(Command) error $msgtext 376 } 377 } 378 } 379 connect_last { 380 Command $ftp(Command) connect $s 381 set complete_with 1 382 } 383 quit { 384 PutsCtrlSock $s "QUIT" 385 set ftp(State) quit_sent 386 } 387 quit_sent { 388 switch -exact -- $rc { 389 2 { 390 set complete_with 1 391 set nextState 1 392 Command $ftp(Command) quit 393 } 394 default { 395 set errmsg "Error disconnecting! $msgtext" 396 set complete_with 0 397 Command $ftp(Command) error $msgtext 398 } 399 } 400 } 401 quote { 402 PutsCtrlSock $s $ftp(Cmd) 403 set ftp(State) quote_sent 404 } 405 quote_sent { 406 set complete_with 1 407 set ftp(Quote) $buffer 408 set nextState 1 409 Command $ftp(Command) quote $buffer 410 } 411 type { 412 if { [string equal $ftp(Type) "ascii"] } { 413 PutsCtrlSock $s "TYPE A" 414 } elseif { [string equal $ftp(Type) "binary"] } { 415 PutsCtrlSock $s "TYPE I" 416 } else { 417 PutsCtrlSock $s "TYPE L" 418 } 419 set ftp(State) type_sent 420 } 421 type_sent { 422 switch -exact -- $rc { 423 2 { 424 set complete_with 1 425 set nextState 1 426 Command $ftp(Command) type $ftp(Type) 427 } 428 default { 429 set errmsg "Error setting type \"$ftp(Type)\"!" 430 set complete_with 0 431 Command $ftp(Command) error "error setting type \"$ftp(Type)\"" 432 } 433 } 434 } 435 type_change { 436 set ftp(Type) $ftp(type:changeto) 437 set ftp(State) type 438 StateHandler $s 439 } 440 nlist_active { 441 if { [OpenActiveConn $s] } { 442 PutsCtrlSock $s "PORT $ftp(LocalAddr),$ftp(DataPort)" 443 set ftp(State) nlist_open 444 } else { 445 set errmsg "Error setting port!" 446 } 447 } 448 nlist_passive { 449 PutsCtrlSock $s "PASV" 450 set ftp(State) nlist_open 451 } 452 nlist_open { 453 switch -exact -- $rc { 454 1 {} 455 2 { 456 if { [string equal $ftp(Mode) "passive"] } { 457 if { ![OpenPassiveConn $s $buffer] } { 458 set errmsg "Error setting PASSIVE mode!" 459 set complete_with 0 460 Command $ftp(Command) error "error setting passive mode" 461 } 462 } 463 PutsCtrlSock $s "NLST$ftp(Dir)" 464 set ftp(State) list_sent 465 } 466 default { 467 if { [string equal $ftp(Mode) "passive"] } { 468 set errmsg "Error setting PASSIVE mode!" 469 } else { 470 set errmsg "Error setting port!" 471 } 472 set complete_with 0 473 Command $ftp(Command) error $errmsg 474 } 475 } 476 } 477 list_active { 478 if { [OpenActiveConn $s] } { 479 PutsCtrlSock $s "PORT $ftp(LocalAddr),$ftp(DataPort)" 480 set ftp(State) list_open 481 } else { 482 set errmsg "Error setting port!" 483 Command $ftp(Command) error $errmsg 484 } 485 } 486 list_passive { 487 PutsCtrlSock $s "PASV" 488 set ftp(State) list_open 489 } 490 list_open { 491 switch -exact -- $rc { 492 1 {} 493 2 { 494 if { [string equal $ftp(Mode) "passive"] } { 495 if { ![OpenPassiveConn $s $buffer] } { 496 set errmsg "Error setting PASSIVE mode!" 497 set complete_with 0 498 Command $ftp(Command) error $errmsg 499 } 500 } 501 PutsCtrlSock $s "LIST$ftp(Dir)" 502 set ftp(State) list_sent 503 } 504 default { 505 if { [string equal $ftp(Mode) "passive"] } { 506 set errmsg "Error setting PASSIVE mode!" 507 } else { 508 set errmsg "Error setting port!" 509 } 510 set complete_with 0 511 Command $ftp(Command) error $errmsg 512 } 513 } 514 } 515 list_sent { 516 switch -exact -- $rc { 517 1 - 518 2 { 519 set ftp(State) list_close 520 } 521 default { 522 if { [string equal $ftp(Mode) "passive"] } { 523 catch {unset ftp(state.data)} 524 } 525 set errmsg "Error getting directory listing!" 526 set complete_with 0 527 Command $ftp(Command) error $errmsg 528 } 529 } 530 } 531 list_close { 532 switch -exact -- $rc { 533 1 {} 534 2 { 535 set nextState 1 536 if {[info exists ftp(NextState)] && ![llength $ftp(NextState)]} { 537 Command $ftp(Command) list [ListPostProcess $ftp(List)] 538 } else { 539 set complete_with 1 540 } 541 } 542 default { 543 set errmsg "Error receiving list!" 544 set complete_with 0 545 Command $ftp(Command) error $errmsg 546 } 547 } 548 } 549 list_last { 550 Command $ftp(Command) list [ListPostProcess $ftp(List)] 551 set complete_with 1 552 } 553 size { 554 PutsCtrlSock $s "SIZE $ftp(File)" 555 set ftp(State) size_sent 556 } 557 size_sent { 558 switch -exact -- $rc { 559 2 { 560 regexp -- "^\[0-9\]+ (.*)$" $buffer all ftp(FileSize) 561 set complete_with 1 562 set nextState 1 563 Command $ftp(Command) size $ftp(File) $ftp(FileSize) 564 } 565 default { 566 set errmsg "Error getting file size!" 567 set complete_with 0 568 Command $ftp(Command) error $errmsg 569 } 570 } 571 } 572 modtime { 573 if {$ftp(DateTime) != ""} { 574 PutsCtrlSock $s "MDTM $ftp(DateTime) $ftp(File)" 575 } else { ;# No DateTime Specified 576 PutsCtrlSock $s "MDTM $ftp(File)" 577 } 578 set ftp(State) modtime_sent 579 } 580 modtime_sent { 581 switch -exact -- $rc { 582 2 { 583 regexp -- "^\[0-9\]+ (.*)$" $buffer all ftp(DateTime) 584 set complete_with 1 585 set nextState 1 586 Command $ftp(Command) modtime $ftp(File) [ModTimePostProcess $ftp(DateTime)] 587 } 588 default { 589 if {$ftp(DateTime) != ""} { 590 set errmsg "Error setting modification time! No server MDTM support?" 591 } else { 592 set errmsg "Error getting modification time!" 593 } 594 set complete_with 0 595 Command $ftp(Command) error $errmsg 596 } 597 } 598 } 599 pwd { 600 PutsCtrlSock $s "PWD" 601 set ftp(State) pwd_sent 602 } 603 pwd_sent { 604 switch -exact -- $rc { 605 2 { 606 regexp -- "^.*\"(.*)\"" $buffer temp ftp(Dir) 607 set complete_with 1 608 set nextState 1 609 Command $ftp(Command) pwd $ftp(Dir) 610 } 611 default { 612 set errmsg "Error getting working dir!" 613 set complete_with 0 614 Command $ftp(Command) error $errmsg 615 } 616 } 617 } 618 cd { 619 PutsCtrlSock $s "CWD$ftp(Dir)" 620 set ftp(State) cd_sent 621 } 622 cd_sent { 623 switch -exact -- $rc { 624 1 {} 625 2 { 626 set complete_with 1 627 set nextState 1 628 Command $ftp(Command) cd $ftp(Dir) 629 } 630 default { 631 set errmsg "Error changing directory to \"$ftp(Dir)\"" 632 set complete_with 0 633 Command $ftp(Command) error $errmsg 634 } 635 } 636 } 637 mkdir { 638 PutsCtrlSock $s "MKD $ftp(Dir)" 639 set ftp(State) mkdir_sent 640 } 641 mkdir_sent { 642 switch -exact -- $rc { 643 2 { 644 set complete_with 1 645 set nextState 1 646 Command $ftp(Command) mkdir $ftp(Dir) 647 } 648 default { 649 set errmsg "Error making dir \"$ftp(Dir)\"!" 650 set complete_with 0 651 Command $ftp(Command) error $errmsg 652 } 653 } 654 } 655 rmdir { 656 PutsCtrlSock $s "RMD $ftp(Dir)" 657 set ftp(State) rmdir_sent 658 } 659 rmdir_sent { 660 switch -exact -- $rc { 661 2 { 662 set complete_with 1 663 set nextState 1 664 Command $ftp(Command) rmdir $ftp(Dir) 665 } 666 default { 667 set errmsg "Error removing directory!" 668 set complete_with 0 669 Command $ftp(Command) error $errmsg 670 } 671 } 672 } 673 delete { 674 PutsCtrlSock $s "DELE $ftp(File)" 675 set ftp(State) delete_sent 676 } 677 delete_sent { 678 switch -exact -- $rc { 679 2 { 680 set complete_with 1 681 set nextState 1 682 Command $ftp(Command) delete $ftp(File) 683 } 684 default { 685 set errmsg "Error deleting file \"$ftp(File)\"!" 686 set complete_with 0 687 Command $ftp(Command) error $errmsg 688 } 689 } 690 } 691 rename { 692 PutsCtrlSock $s "RNFR $ftp(RenameFrom)" 693 set ftp(State) rename_to 694 } 695 rename_to { 696 switch -exact -- $rc { 697 3 { 698 PutsCtrlSock $s "RNTO $ftp(RenameTo)" 699 set ftp(State) rename_sent 700 } 701 default { 702 set errmsg "Error renaming file \"$ftp(RenameFrom)\"!" 703 set complete_with 0 704 Command $ftp(Command) error $errmsg 705 } 706 } 707 } 708 rename_sent { 709 switch -exact -- $rc { 710 2 { 711 set complete_with 1 712 set nextState 1 713 Command $ftp(Command) rename $ftp(RenameFrom) $ftp(RenameTo) 714 } 715 default { 716 set errmsg "Error renaming file \"$ftp(RenameFrom)\"!" 717 set complete_with 0 718 Command $ftp(Command) error $errmsg 719 } 720 } 721 } 722 put_active { 723 if { [OpenActiveConn $s] } { 724 PutsCtrlSock $s "PORT $ftp(LocalAddr),$ftp(DataPort)" 725 set ftp(State) put_open 726 } else { 727 set errmsg "Error setting port!" 728 Command $ftp(Command) error $errmsg 729 } 730 } 731 put_passive { 732 PutsCtrlSock $s "PASV" 733 set ftp(State) put_open 734 } 735 put_open { 736 switch -exact -- $rc { 737 1 - 738 2 { 739 if { [string equal $ftp(Mode) "passive"] } { 740 if { ![OpenPassiveConn $s $buffer] } { 741 set errmsg "Error setting PASSIVE mode!" 742 set complete_with 0 743 Command $ftp(Command) error $errmsg 744 } 745 } 746 PutsCtrlSock $s "STOR $ftp(RemoteFilename)" 747 set ftp(State) put_sent 748 } 749 default { 750 if { [string equal $ftp(Mode) "passive"] } { 751 set errmsg "Error setting PASSIVE mode!" 752 } else { 753 set errmsg "Error setting port!" 754 } 755 set complete_with 0 756 Command $ftp(Command) error $errmsg 757 } 758 } 759 } 760 put_sent { 761 switch -exact -- $rc { 762 1 - 763 2 { 764 set ftp(State) put_close 765 } 766 default { 767 if { [string equal $ftp(Mode) "passive"] } { 768 # close already opened DataConnection 769 catch {unset ftp(state.data)} 770 } 771 set errmsg "Error opening connection!" 772 set complete_with 0 773 Command $ftp(Command) error $errmsg 774 } 775 } 776 } 777 put_close { 778 switch -exact -- $rc { 779 1 { 780 # Keep going 781 return 782 } 783 2 { 784 set complete_with 1 785 set nextState 1 786 Command $ftp(Command) put $ftp(RemoteFilename) 787 } 788 default { 789 DisplayMsg $s "rc = $rc msgtext = \"$msgtext\"" 790 set errmsg "Error storing file \"$ftp(RemoteFilename)\" due to \"$msgtext\"" 791 set complete_with 0 792 Command $ftp(Command) error $errmsg 793 } 794 } 795 } 796 append_active { 797 if { [OpenActiveConn $s] } { 798 PutsCtrlSock $s "PORT $ftp(LocalAddr),$ftp(DataPort)" 799 set ftp(State) append_open 800 } else { 801 set errmsg "Error setting port!" 802 Command $ftp(Command) error $errmsg 803 } 804 } 805 append_passive { 806 PutsCtrlSock $s "PASV" 807 set ftp(State) append_open 808 } 809 append_open { 810 switch -exact -- $rc { 811 1 - 812 2 { 813 if { [string equal $ftp(Mode) "passive"] } { 814 if { ![OpenPassiveConn $s $buffer] } { 815 set errmsg "Error setting PASSIVE mode!" 816 set complete_with 0 817 Command $ftp(Command) error $errmsg 818 } 819 } 820 PutsCtrlSock $s "APPE $ftp(RemoteFilename)" 821 set ftp(State) append_sent 822 } 823 default { 824 if { [string equal $ftp(Mode) "passive"] } { 825 set errmsg "Error setting PASSIVE mode!" 826 } else { 827 set errmsg "Error setting port!" 828 } 829 set complete_with 0 830 Command $ftp(Command) error $errmsg 831 } 832 } 833 } 834 append_sent { 835 switch -exact -- $rc { 836 1 { 837 set ftp(State) append_close 838 } 839 default { 840 if { [string equal $ftp(Mode) "passive"] } { 841 # close already opened DataConnection 842 catch {unset ftp(state.data)} 843 } 844 set errmsg "Error opening connection!" 845 set complete_with 0 846 Command $ftp(Command) error $errmsg 847 } 848 } 849 } 850 append_close { 851 switch -exact -- $rc { 852 2 { 853 set complete_with 1 854 set nextState 1 855 Command $ftp(Command) append $ftp(RemoteFilename) 856 } 857 default { 858 set errmsg "Error storing file \"$ftp(RemoteFilename)\"!" 859 set complete_with 0 860 Command $ftp(Command) error $errmsg 861 } 862 } 863 } 864 reget_active { 865 if { [OpenActiveConn $s] } { 866 PutsCtrlSock $s "PORT $ftp(LocalAddr),$ftp(DataPort)" 867 set ftp(State) reget_restart 868 } else { 869 set errmsg "Error setting port!" 870 Command $ftp(Command) error $errmsg 871 } 872 } 873 reget_passive { 874 PutsCtrlSock $s "PASV" 875 set ftp(State) reget_restart 876 } 877 reget_restart { 878 switch -exact -- $rc { 879 2 { 880 if { [string equal $ftp(Mode) "passive"] } { 881 if { ![OpenPassiveConn $s $buffer] } { 882 set errmsg "Error setting PASSIVE mode!" 883 set complete_with 0 884 Command $ftp(Command) error $errmsg 885 } 886 } 887 if { $ftp(FileSize) != 0 } { 888 PutsCtrlSock $s "REST $ftp(FileSize)" 889 set ftp(State) reget_open 890 } else { 891 PutsCtrlSock $s "RETR $ftp(RemoteFilename)" 892 set ftp(State) reget_sent 893 } 894 } 895 default { 896 set errmsg "Error restarting filetransfer of \"$ftp(RemoteFilename)\"!" 897 set complete_with 0 898 Command $ftp(Command) error $errmsg 899 } 900 } 901 } 902 reget_open { 903 switch -exact -- $rc { 904 2 - 905 3 { 906 PutsCtrlSock $s "RETR $ftp(RemoteFilename)" 907 set ftp(State) reget_sent 908 } 909 default { 910 if { [string equal $ftp(Mode) "passive"] } { 911 set errmsg "Error setting PASSIVE mode!" 912 } else { 913 set errmsg "Error setting port!" 914 } 915 set complete_with 0 916 Command $ftp(Command) error $errmsg 917 } 918 } 919 } 920 reget_sent { 921 switch -exact -- $rc { 922 1 { 923 set ftp(State) reget_close 924 } 925 default { 926 if { [string equal $ftp(Mode) "passive"] } { 927 # close already opened DataConnection 928 catch {unset ftp(state.data)} 929 } 930 set errmsg "Error retrieving file \"$ftp(RemoteFilename)\"!" 931 set complete_with 0 932 Command $ftp(Command) error $errmsg 933 } 934 } 935 } 936 reget_close { 937 switch -exact -- $rc { 938 2 { 939 set complete_with 1 940 set nextState 1 941 Command $ftp(Command) get $ftp(RemoteFilename):$ftp(From):$ftp(To) 942 unset ftp(From) ftp(To) 943 } 944 default { 945 set errmsg "Error retrieving file \"$ftp(RemoteFilename)\"!" 946 set complete_with 0 947 Command $ftp(Command) error $errmsg 948 } 949 } 950 } 951 get_active { 952 if { [OpenActiveConn $s] } { 953 PutsCtrlSock $s "PORT $ftp(LocalAddr),$ftp(DataPort)" 954 set ftp(State) get_open 955 } else { 956 set errmsg "Error setting port!" 957 Command $ftp(Command) error $errmsg 958 } 959 } 960 get_passive { 961 PutsCtrlSock $s "PASV" 962 set ftp(State) get_open 963 } 964 get_open { 965 switch -exact -- $rc { 966 1 - 967 2 - 968 3 { 969 if { [string equal $ftp(Mode) "passive"] } { 970 if { ![OpenPassiveConn $s $buffer] } { 971 set errmsg "Error setting PASSIVE mode!" 972 set complete_with 0 973 Command $ftp(Command) error $errmsg 974 } 975 } 976 PutsCtrlSock $s "RETR $ftp(RemoteFilename)" 977 set ftp(State) get_sent 978 } 979 default { 980 if { [string equal $ftp(Mode) "passive"] } { 981 set errmsg "Error setting PASSIVE mode!" 982 } else { 983 set errmsg "Error setting port!" 984 } 985 set complete_with 0 986 Command $ftp(Command) error $errmsg 987 } 988 } 989 } 990 get_sent { 991 switch -exact -- $rc { 992 1 { 993 set ftp(State) get_close 994 } 995 default { 996 if { [string equal $ftp(Mode) "passive"] } { 997 # close already opened DataConnection 998 catch {unset ftp(state.data)} 999 } 1000 set errmsg "Error retrieving file \"$ftp(RemoteFilename)\"!" 1001 set complete_with 0 1002 Command $ftp(Command) error $errmsg 1003 } 1004 } 1005 } 1006 get_close { 1007 switch -exact -- $rc { 1008 2 { 1009 set complete_with 1 1010 set nextState 1 1011 if {$ftp(inline)} { 1012 upvar #0 $ftp(get:varname) returnData 1013 set returnData $ftp(GetData) 1014 Command $ftp(Command) get $ftp(GetData) 1015 } else { 1016 Command $ftp(Command) get $ftp(RemoteFilename) 1017 } 1018 } 1019 default { 1020 set errmsg "Error retrieving file \"$ftp(RemoteFilename)\"!" 1021 set complete_with 0 1022 Command $ftp(Command) error $errmsg 1023 } 1024 } 1025 } 1026 default { 1027 error "Unknown state \"$ftp(State)\"" 1028 } 1029 } 1030 1031 # finish waiting 1032 if { [info exists complete_with] } { 1033 WaitComplete $s $complete_with 1034 } 1035 1036 # display control channel message 1037 if { [info exists buffer] } { 1038 if { $VERBOSE } { 1039 foreach line [split $buffer \n] { 1040 DisplayMsg $s "C: $line" control 1041 } 1042 } 1043 } 1044 1045 # Rather than throwing an error in the event loop, set the ftp(Error) 1046 # variable to hold the message so that it can later be thrown after the 1047 # the StateHandler has completed. 1048 1049 if { [info exists errmsg] } { 1050 set ftp(Error) $errmsg 1051 } 1052 1053 # If operating asynchronously, commence next state 1054 if {$nextState && [info exists ftp(NextState)] && [llength $ftp(NextState)]} { 1055 # Pop the head of the NextState queue 1056 set ftp(State) [lindex $ftp(NextState) 0] 1057 set ftp(NextState) [lreplace $ftp(NextState) 0 0] 1058 StateHandler $s 1059 } 1060 1061 # enable fileevent on control socket again 1062 #fileevent $ftp(CtrlSock) readable [list ::ftp::StateHandler $ftp(CtrlSock)] 1063 1064} 1065 1066############################################################################# 1067# 1068# Type -- 1069# 1070# REPRESENTATION TYPE - Sets the file transfer type to ascii or binary. 1071# (exported) 1072# 1073# Arguments: 1074# type - specifies the representation type (ascii|binary) 1075# 1076# Returns: 1077# type - returns the current type or {} if an error occurs 1078 1079proc ::ftp::Type {s {type ""}} { 1080 upvar ::ftp::ftp$s ftp 1081 1082 if { ![info exists ftp(State)] } { 1083 if { ![string is digit -strict $s] } { 1084 DisplayMsg $s "Bad connection name \"$s\"" error 1085 } else { 1086 DisplayMsg $s "Not connected!" error 1087 } 1088 return {} 1089 } 1090 1091 # return current type 1092 if { $type == "" } { 1093 return $ftp(Type) 1094 } 1095 1096 # save current type 1097 set old_type $ftp(Type) 1098 1099 set ftp(Type) $type 1100 set ftp(State) type 1101 StateHandler $s 1102 1103 # wait for synchronization 1104 set rc [WaitOrTimeout $s] 1105 if { $rc } { 1106 return $ftp(Type) 1107 } else { 1108 # restore old type 1109 set ftp(Type) $old_type 1110 return {} 1111 } 1112} 1113 1114############################################################################# 1115# 1116# NList -- 1117# 1118# NAME LIST - This command causes a directory listing to be sent from 1119# server to user site. 1120# (exported) 1121# 1122# Arguments: 1123# dir - The $dir should specify a directory or other system 1124# specific file group descriptor; a null argument 1125# implies the current directory. 1126# 1127# Arguments: 1128# dir - directory to list 1129# 1130# Returns: 1131# sorted list of files or {} if listing fails 1132 1133proc ::ftp::NList {s { dir ""}} { 1134 upvar ::ftp::ftp$s ftp 1135 1136 if { ![info exists ftp(State)] } { 1137 if { ![string is digit -strict $s] } { 1138 DisplayMsg $s "Bad connection name \"$s\"" error 1139 } else { 1140 DisplayMsg $s "Not connected!" error 1141 } 1142 return {} 1143 } 1144 1145 set ftp(List) {} 1146 if { $dir == "" } { 1147 set ftp(Dir) "" 1148 } else { 1149 set ftp(Dir) " $dir" 1150 } 1151 1152 # save current type and force ascii mode 1153 set old_type $ftp(Type) 1154 if { $ftp(Type) != "ascii" } { 1155 if {[string length $ftp(Command)]} { 1156 set ftp(NextState) [list nlist_$ftp(Mode) type_change list_last] 1157 set ftp(type:changeto) $old_type 1158 Type $s ascii 1159 return {} 1160 } 1161 Type $s ascii 1162 } 1163 1164 set ftp(State) nlist_$ftp(Mode) 1165 StateHandler $s 1166 1167 # wait for synchronization 1168 set rc [WaitOrTimeout $s] 1169 1170 # restore old type 1171 if { [Type $s] != $old_type } { 1172 Type $s $old_type 1173 } 1174 1175 unset ftp(Dir) 1176 if { $rc } { 1177 return [lsort [split [string trim $ftp(List) \n] \n]] 1178 } else { 1179 CloseDataConn $s 1180 return {} 1181 } 1182} 1183 1184############################################################################# 1185# 1186# List -- 1187# 1188# LIST - This command causes a list to be sent from the server 1189# to user site. 1190# (exported) 1191# 1192# Arguments: 1193# dir - If the $dir specifies a directory or other group of 1194# files, the server should transfer a list of files in 1195# the specified directory. If the $dir specifies a file 1196# then the server should send current information on the 1197# file. A null argument implies the user's current 1198# working or default directory. 1199# 1200# Returns: 1201# list of files or {} if listing fails 1202 1203proc ::ftp::List {s {dir ""}} { 1204 1205 upvar ::ftp::ftp$s ftp 1206 1207 if { ![info exists ftp(State)] } { 1208 if { ![string is digit -strict $s] } { 1209 DisplayMsg $s "Bad connection name \"$s\"" error 1210 } else { 1211 DisplayMsg $s "Not connected!" error 1212 } 1213 return {} 1214 } 1215 1216 set ftp(List) {} 1217 if { $dir == "" } { 1218 set ftp(Dir) "" 1219 } else { 1220 set ftp(Dir) " $dir" 1221 } 1222 1223 # save current type and force ascii mode 1224 1225 set old_type $ftp(Type) 1226 if { ![string equal "$ftp(Type)" "ascii"] } { 1227 if {[string length $ftp(Command)]} { 1228 set ftp(NextState) [list list_$ftp(Mode) type_change list_last] 1229 set ftp(type:changeto) $old_type 1230 Type $s ascii 1231 return {} 1232 } 1233 Type $s ascii 1234 } 1235 1236 set ftp(State) list_$ftp(Mode) 1237 StateHandler $s 1238 1239 # wait for synchronization 1240 1241 set rc [WaitOrTimeout $s] 1242 1243 # restore old type 1244 1245 if { ![string equal "[Type $s]" "$old_type"] } { 1246 Type $s $old_type 1247 } 1248 1249 unset ftp(Dir) 1250 if { $rc } { 1251 return [ListPostProcess $ftp(List)] 1252 } else { 1253 CloseDataConn $s 1254 return {} 1255 } 1256} 1257 1258proc ::ftp::ListPostProcess l { 1259 1260 # clear "total"-line 1261 1262 set l [split $l "\n"] 1263 set index [lsearch -regexp $l "^total"] 1264 if { $index != "-1" } { 1265 set l [lreplace $l $index $index] 1266 } 1267 1268 # clear blank line 1269 1270 set index [lsearch -regexp $l "^$"] 1271 if { $index != "-1" } { 1272 set l [lreplace $l $index $index] 1273 } 1274 1275 return $l 1276} 1277 1278############################################################################# 1279# 1280# FileSize -- 1281# 1282# REMOTE FILE SIZE - This command gets the file size of the 1283# file on the remote machine. 1284# ATTENTION! Doesn't work properly in ascii mode! 1285# (exported) 1286# 1287# Arguments: 1288# filename - specifies the remote file name 1289# 1290# Returns: 1291# size - files size in bytes or {} in error cases 1292 1293proc ::ftp::FileSize {s {filename ""}} { 1294 upvar ::ftp::ftp$s ftp 1295 1296 if { ![info exists ftp(State)] } { 1297 if { ![string is digit -strict $s] } { 1298 DisplayMsg $s "Bad connection name \"$s\"" error 1299 } else { 1300 DisplayMsg $s "Not connected!" error 1301 } 1302 return {} 1303 } 1304 1305 if { $filename == "" } { 1306 return {} 1307 } 1308 1309 set ftp(File) $filename 1310 set ftp(FileSize) 0 1311 1312 set ftp(State) size 1313 StateHandler $s 1314 1315 # wait for synchronization 1316 set rc [WaitOrTimeout $s] 1317 1318 if {![string length $ftp(Command)]} { 1319 unset ftp(File) 1320 } 1321 1322 if { $rc } { 1323 return $ftp(FileSize) 1324 } else { 1325 return {} 1326 } 1327} 1328 1329 1330############################################################################# 1331# 1332# ModTime -- 1333# 1334# MODIFICATION TIME - This command gets the last modification time of the 1335# file on the remote machine. 1336# (exported) 1337# 1338# Arguments: 1339# filename - specifies the remote file name 1340# datetime - optional new timestamp for file 1341# 1342# Returns: 1343# clock - files date and time as a system-depentend integer 1344# value in seconds (see tcls clock command) or {} in 1345# error cases 1346# if MDTM not supported on server, returns original timestamp 1347 1348proc ::ftp::ModTime {s {filename ""} {datetime ""}} { 1349 upvar ::ftp::ftp$s ftp 1350 1351 if { ![info exists ftp(State)] } { 1352 if { ![string is digit -strict $s] } { 1353 DisplayMsg $s "Bad connection name \"$s\"" error 1354 } else { 1355 DisplayMsg $s "Not connected!" error 1356 } 1357 return {} 1358 } 1359 1360 if { $filename == "" } { 1361 return {} 1362 } 1363 1364 set ftp(File) $filename 1365 1366 if {$datetime != ""} { 1367 set datetime [clock format $datetime -format "%Y%m%d%H%M%S"] 1368 } 1369 set ftp(DateTime) $datetime 1370 1371 set ftp(State) modtime 1372 StateHandler $s 1373 1374 # wait for synchronization 1375 set rc [WaitOrTimeout $s] 1376 1377 if {![string length $ftp(Command)]} { 1378 unset ftp(File) 1379 } 1380 if { ![string length $ftp(Command)] && $rc } { 1381 return [ModTimePostProcess $ftp(DateTime)] 1382 } else { 1383 return {} 1384 } 1385} 1386 1387proc ::ftp::ModTimePostProcess {clock} { 1388 foreach {year month day hour min sec} {1 1 1 1 1 1} break 1389 1390 # Bug #478478. Special code to detect ftp servers with a Y2K patch 1391 # gone bad and delivering, hmmm, non-standard date information. 1392 1393 if {[string length $clock] == 15} { 1394 scan $clock "%2s%3s%2s%2s%2s%2s%2s" cent year month day hour min sec 1395 set year [expr {($cent * 100) + $year}] 1396 log::log warning "data | W: server with non-standard time, bad Y2K patch." 1397 } else { 1398 scan $clock "%4s%2s%2s%2s%2s%2s" year month day hour min sec 1399 } 1400 1401 set clock [clock scan "$month/$day/$year $hour:$min:$sec" -gmt 1] 1402 return $clock 1403} 1404 1405############################################################################# 1406# 1407# Pwd -- 1408# 1409# PRINT WORKING DIRECTORY - Causes the name of the current working directory. 1410# (exported) 1411# 1412# Arguments: 1413# None. 1414# 1415# Returns: 1416# current directory name 1417 1418proc ::ftp::Pwd {s } { 1419 upvar ::ftp::ftp$s ftp 1420 1421 if { ![info exists ftp(State)] } { 1422 if { ![string is digit -strict $s] } { 1423 DisplayMsg $s "Bad connection name \"$s\"" error 1424 } else { 1425 DisplayMsg $s "Not connected!" error 1426 } 1427 return {} 1428 } 1429 1430 set ftp(Dir) {} 1431 1432 set ftp(State) pwd 1433 StateHandler $s 1434 1435 # wait for synchronization 1436 set rc [WaitOrTimeout $s] 1437 1438 if { $rc } { 1439 return $ftp(Dir) 1440 } else { 1441 return {} 1442 } 1443} 1444 1445############################################################################# 1446# 1447# Cd -- 1448# 1449# CHANGE DIRECTORY - Sets the working directory on the server host. 1450# (exported) 1451# 1452# Arguments: 1453# dir - pathname specifying a directory 1454# 1455# Returns: 1456# 0 - ERROR 1457# 1 - OK 1458 1459proc ::ftp::Cd {s {dir ""}} { 1460 upvar ::ftp::ftp$s ftp 1461 1462 if { ![info exists ftp(State)] } { 1463 if { ![string is digit -strict $s] } { 1464 DisplayMsg $s "Bad connection name \"$s\"" error 1465 } else { 1466 DisplayMsg $s "Not connected!" error 1467 } 1468 return 0 1469 } 1470 1471 if { $dir == "" } { 1472 set ftp(Dir) "" 1473 } else { 1474 set ftp(Dir) " $dir" 1475 } 1476 1477 set ftp(State) cd 1478 StateHandler $s 1479 1480 # wait for synchronization 1481 set rc [WaitOrTimeout $s] 1482 1483 if {![string length $ftp(Command)]} { 1484 unset ftp(Dir) 1485 } 1486 1487 if { $rc } { 1488 return 1 1489 } else { 1490 return 0 1491 } 1492} 1493 1494############################################################################# 1495# 1496# MkDir -- 1497# 1498# MAKE DIRECTORY - This command causes the directory specified in the $dir 1499# to be created as a directory (if the $dir is absolute) or as a subdirectory 1500# of the current working directory (if the $dir is relative). 1501# (exported) 1502# 1503# Arguments: 1504# dir - new directory name 1505# 1506# Returns: 1507# 0 - ERROR 1508# 1 - OK 1509 1510proc ::ftp::MkDir {s dir} { 1511 upvar ::ftp::ftp$s ftp 1512 1513 if { ![info exists ftp(State)] } { 1514 DisplayMsg $s "Not connected!" error 1515 return 0 1516 } 1517 1518 set ftp(Dir) $dir 1519 1520 set ftp(State) mkdir 1521 StateHandler $s 1522 1523 # wait for synchronization 1524 set rc [WaitOrTimeout $s] 1525 1526 if {![string length $ftp(Command)]} { 1527 unset ftp(Dir) 1528 } 1529 1530 if { $rc } { 1531 return 1 1532 } else { 1533 return 0 1534 } 1535} 1536 1537############################################################################# 1538# 1539# RmDir -- 1540# 1541# REMOVE DIRECTORY - This command causes the directory specified in $dir to 1542# be removed as a directory (if the $dir is absolute) or as a 1543# subdirectory of the current working directory (if the $dir is relative). 1544# (exported) 1545# 1546# Arguments: 1547# dir - directory name 1548# 1549# Returns: 1550# 0 - ERROR 1551# 1 - OK 1552 1553proc ::ftp::RmDir {s dir} { 1554 upvar ::ftp::ftp$s ftp 1555 1556 if { ![info exists ftp(State)] } { 1557 DisplayMsg $s "Not connected!" error 1558 return 0 1559 } 1560 1561 set ftp(Dir) $dir 1562 1563 set ftp(State) rmdir 1564 StateHandler $s 1565 1566 # wait for synchronization 1567 set rc [WaitOrTimeout $s] 1568 1569 if {![string length $ftp(Command)]} { 1570 unset ftp(Dir) 1571 } 1572 1573 if { $rc } { 1574 return 1 1575 } else { 1576 return 0 1577 } 1578} 1579 1580############################################################################# 1581# 1582# Delete -- 1583# 1584# DELETE - This command causes the file specified in $file to be deleted at 1585# the server site. 1586# (exported) 1587# 1588# Arguments: 1589# file - file name 1590# 1591# Returns: 1592# 0 - ERROR 1593# 1 - OK 1594 1595proc ::ftp::Delete {s file} { 1596 upvar ::ftp::ftp$s ftp 1597 1598 if { ![info exists ftp(State)] } { 1599 DisplayMsg $s "Not connected!" error 1600 return 0 1601 } 1602 1603 set ftp(File) $file 1604 1605 set ftp(State) delete 1606 StateHandler $s 1607 1608 # wait for synchronization 1609 set rc [WaitOrTimeout $s] 1610 1611 if {![string length $ftp(Command)]} { 1612 unset ftp(File) 1613 } 1614 1615 if { $rc } { 1616 return 1 1617 } else { 1618 return 0 1619 } 1620} 1621 1622############################################################################# 1623# 1624# Rename -- 1625# 1626# RENAME FROM TO - This command causes the file specified in $from to be 1627# renamed at the server site. 1628# (exported) 1629# 1630# Arguments: 1631# from - specifies the old file name of the file which 1632# is to be renamed 1633# to - specifies the new file name of the file 1634# specified in the $from agument 1635# Returns: 1636# 0 - ERROR 1637# 1 - OK 1638 1639proc ::ftp::Rename {s from to} { 1640 upvar ::ftp::ftp$s ftp 1641 1642 if { ![info exists ftp(State)] } { 1643 DisplayMsg $s "Not connected!" error 1644 return 0 1645 } 1646 1647 set ftp(RenameFrom) $from 1648 set ftp(RenameTo) $to 1649 1650 set ftp(State) rename 1651 1652 StateHandler $s 1653 1654 # wait for synchronization 1655 set rc [WaitOrTimeout $s] 1656 1657 if {![string length $ftp(Command)]} { 1658 unset ftp(RenameFrom) 1659 unset ftp(RenameTo) 1660 } 1661 1662 if { $rc } { 1663 return 1 1664 } else { 1665 return 0 1666 } 1667} 1668 1669############################################################################# 1670# 1671# ElapsedTime -- 1672# 1673# Gets the elapsed time for file transfer 1674# 1675# Arguments: 1676# stop_time - ending time 1677 1678proc ::ftp::ElapsedTime {s stop_time} { 1679 variable VERBOSE 1680 upvar ::ftp::ftp$s ftp 1681 1682 set elapsed [expr {$stop_time - $ftp(Start_Time)}] 1683 if { $elapsed == 0 } { 1684 set elapsed 1 1685 } 1686 set persec [expr {$ftp(Total) / $elapsed}] 1687 if { $VERBOSE } { 1688 DisplayMsg $s "$ftp(Total) bytes sent in $elapsed seconds ($persec Bytes/s)" 1689 } 1690 return 1691} 1692 1693############################################################################# 1694# 1695# PUT -- 1696# 1697# STORE DATA - Causes the server to accept the data transferred via the data 1698# connection and to store the data as a file at the server site. If the file 1699# exists at the server site, then its contents shall be replaced by the data 1700# being transferred. A new file is created at the server site if the file 1701# does not already exist. 1702# (exported) 1703# 1704# Arguments: 1705# source - local file name 1706# dest - remote file name, if unspecified, ftp assigns 1707# the local file name. 1708# Returns: 1709# 0 - file not stored 1710# 1 - OK 1711 1712proc ::ftp::Put {s args} { 1713 upvar ::ftp::ftp$s ftp 1714 1715 if { ![info exists ftp(State)] } { 1716 DisplayMsg $s "Not connected!" error 1717 return 0 1718 } 1719 if {([llength $args] < 1) || ([llength $args] > 4)} { 1720 DisplayMsg $s \ 1721 "wrong # args: should be \"ftp::Put handle (-data \"data\" | -channel chan | localFilename) remoteFilename\"" error 1722 return 0 1723 } 1724 1725 set ftp(inline) 0 1726 set flags 1 1727 set source "" 1728 set dest "" 1729 foreach arg $args { 1730 if {[string equal $arg "--"]} { 1731 set flags 0 1732 } elseif {($flags) && ([string equal $arg "-data"])} { 1733 set ftp(inline) 1 1734 set ftp(filebuffer) "" 1735 } elseif {($flags) && ([string equal $arg "-channel"])} { 1736 set ftp(inline) 2 1737 } elseif {$source == ""} { 1738 set source $arg 1739 } elseif {$dest == ""} { 1740 set dest $arg 1741 } else { 1742 DisplayMsg $s "wrong # args: should be \"ftp::Put handle (-data \"data\" | -channel chan | localFilename) remoteFilename\"" error 1743 return 0 1744 } 1745 } 1746 1747 if {($source == "")} { 1748 DisplayMsg $s "Must specify a valid data source to Put" error 1749 return 0 1750 } 1751 1752 set ftp(RemoteFilename) $dest 1753 1754 if {$ftp(inline) == 1} { 1755 set ftp(PutData) $source 1756 if { $dest == "" } { 1757 set dest ftp.tmp 1758 } 1759 set ftp(RemoteFilename) $dest 1760 } else { 1761 if {$ftp(inline) == 0} { 1762 # File transfer 1763 1764 set ftp(PutData) "" 1765 if { ![file exists $source] } { 1766 DisplayMsg $s "File \"$source\" not exist" error 1767 return 0 1768 } 1769 if { $dest == "" } { 1770 set dest [file tail $source] 1771 } 1772 set ftp(LocalFilename) $source 1773 set ftp(SourceCI) [open $ftp(LocalFilename) r] 1774 } else { 1775 # Channel transfer. We fake the rest of the system into 1776 # believing that a file transfer is happening. This makes 1777 # the handling easier. 1778 1779 set ftp(SourceCI) $source 1780 set ftp(inline) 0 1781 } 1782 set ftp(RemoteFilename) $dest 1783 1784 # TODO: read from source file asynchronously 1785 if { [string equal $ftp(Type) "ascii"] } { 1786 fconfigure $ftp(SourceCI) -buffering line -blocking 1 1787 } else { 1788 fconfigure $ftp(SourceCI) -buffering line -translation binary -blocking 1 1789 } 1790 } 1791 1792 set ftp(State) put_$ftp(Mode) 1793 StateHandler $s 1794 1795 # wait for synchronization 1796 set rc [WaitOrTimeout $s] 1797 if { $rc } { 1798 if {![string length $ftp(Command)]} { 1799 ElapsedTime $s [clock seconds] 1800 } 1801 return 1 1802 } else { 1803 CloseDataConn $s 1804 return 0 1805 } 1806} 1807 1808############################################################################# 1809# 1810# APPEND -- 1811# 1812# APPEND DATA - Causes the server to accept the data transferred via the data 1813# connection and to store the data as a file at the server site. If the file 1814# exists at the server site, then the data shall be appended to that file; 1815# otherwise the file specified in the pathname shall be created at the 1816# server site. 1817# (exported) 1818# 1819# Arguments: 1820# source - local file name 1821# dest - remote file name, if unspecified, ftp assigns 1822# the local file name. 1823# Returns: 1824# 0 - file not stored 1825# 1 - OK 1826 1827proc ::ftp::Append {s args} { 1828 upvar ::ftp::ftp$s ftp 1829 1830 if { ![info exists ftp(State)] } { 1831 DisplayMsg $s "Not connected!" error 1832 return 0 1833 } 1834 1835 if {([llength $args] < 1) || ([llength $args] > 4)} { 1836 DisplayMsg $s "wrong # args: should be \"ftp::Append handle (-data \"data\" | -channel chan | localFilename) remoteFilename\"" error 1837 return 0 1838 } 1839 1840 set ftp(inline) 0 1841 set flags 1 1842 set source "" 1843 set dest "" 1844 foreach arg $args { 1845 if {[string equal $arg "--"]} { 1846 set flags 0 1847 } elseif {($flags) && ([string equal $arg "-data"])} { 1848 set ftp(inline) 1 1849 set ftp(filebuffer) "" 1850 } elseif {($flags) && ([string equal $arg "-channel"])} { 1851 set ftp(inline) 2 1852 } elseif {$source == ""} { 1853 set source $arg 1854 } elseif {$dest == ""} { 1855 set dest $arg 1856 } else { 1857 DisplayMsg $s "wrong # args: should be \"ftp::Append handle (-data \"data\" | -channel chan | localFilename) remoteFilename\"" error 1858 return 0 1859 } 1860 } 1861 1862 if {($source == "")} { 1863 DisplayMsg $s "Must specify a valid data source to Append" error 1864 return 0 1865 } 1866 1867 set ftp(RemoteFilename) $dest 1868 1869 if {$ftp(inline) == 1} { 1870 set ftp(PutData) $source 1871 if { $dest == "" } { 1872 set dest ftp.tmp 1873 } 1874 set ftp(RemoteFilename) $dest 1875 } else { 1876 if {$ftp(inline) == 0} { 1877 # File transfer 1878 1879 set ftp(PutData) "" 1880 if { ![file exists $source] } { 1881 DisplayMsg $s "File \"$source\" not exist" error 1882 return 0 1883 } 1884 1885 if { $dest == "" } { 1886 set dest [file tail $source] 1887 } 1888 1889 set ftp(LocalFilename) $source 1890 set ftp(SourceCI) [open $ftp(LocalFilename) r] 1891 } else { 1892 # Channel transfer. We fake the rest of the system into 1893 # believing that a file transfer is happening. This makes 1894 # the handling easier. 1895 1896 set ftp(SourceCI) $source 1897 set ftp(inline) 0 1898 } 1899 set ftp(RemoteFilename) $dest 1900 1901 if { [string equal $ftp(Type) "ascii"] } { 1902 fconfigure $ftp(SourceCI) -buffering line -blocking 1 1903 } else { 1904 fconfigure $ftp(SourceCI) -buffering line -translation binary \ 1905 -blocking 1 1906 } 1907 } 1908 1909 set ftp(State) append_$ftp(Mode) 1910 StateHandler $s 1911 1912 # wait for synchronization 1913 set rc [WaitOrTimeout $s] 1914 if { $rc } { 1915 if {![string length $ftp(Command)]} { 1916 ElapsedTime $s [clock seconds] 1917 } 1918 return 1 1919 } else { 1920 CloseDataConn $s 1921 return 0 1922 } 1923} 1924 1925 1926############################################################################# 1927# 1928# Get -- 1929# 1930# RETRIEVE DATA - Causes the server to transfer a copy of the specified file 1931# to the local site at the other end of the data connection. 1932# (exported) 1933# 1934# Arguments: 1935# source - remote file name 1936# dest - local file name, if unspecified, ftp assigns 1937# the remote file name. 1938# Returns: 1939# 0 - file not retrieved 1940# 1 - OK 1941 1942proc ::ftp::Get {s args} { 1943 upvar ::ftp::ftp$s ftp 1944 1945 if { ![info exists ftp(State)] } { 1946 DisplayMsg $s "Not connected!" error 1947 return 0 1948 } 1949 1950 if {([llength $args] < 1) || ([llength $args] > 4)} { 1951 DisplayMsg $s "wrong # args: should be \"ftp::Get handle remoteFile ?(-variable varName | -channel chan | localFilename)?\"" error 1952 return 0 1953 } 1954 1955 set ftp(inline) 0 1956 set flags 1 1957 set source "" 1958 set dest "" 1959 set varname "**NONE**" 1960 foreach arg $args { 1961 if {[string equal $arg "--"]} { 1962 set flags 0 1963 } elseif {($flags) && ([string equal $arg "-variable"])} { 1964 set ftp(inline) 1 1965 set ftp(filebuffer) "" 1966 } elseif {($flags) && ([string equal $arg "-channel"])} { 1967 set ftp(inline) 2 1968 } elseif {($ftp(inline) == 1) && ([string equal $varname "**NONE**"])} { 1969 set varname $arg 1970 set ftp(get:varname) $varname 1971 } elseif {($ftp(inline) == 2) && ([string equal $varname "**NONE**"])} { 1972 set ftp(get:channel) $arg 1973 } elseif {$source == ""} { 1974 set source $arg 1975 } elseif {$dest == ""} { 1976 set dest $arg 1977 } else { 1978 DisplayMsg $s "wrong # args: should be \"ftp::Get handle remoteFile 1979?(-variable varName | -channel chan | localFilename)?\"" error 1980 return 0 1981 } 1982 } 1983 1984 if {($ftp(inline) != 0) && ($dest != "")} { 1985 DisplayMsg $s "Cannot return data in a variable or channel, and place it in destination file." error 1986 return 0 1987 } 1988 1989 if {$source == ""} { 1990 DisplayMsg $s "Must specify a valid data source to Get" error 1991 return 0 1992 } 1993 1994 if {$ftp(inline) == 0} { 1995 if { $dest == "" } { 1996 set dest $source 1997 } else { 1998 if {[file isdirectory $dest]} { 1999 set dest [file join $dest [file tail $source]] 2000 } 2001 } 2002 if {![file exists [file dirname $dest]]} { 2003 return -code error "ftp::Get, directory \"[file dirname $dest]\" for destination \"$dest\" does not exist" 2004 } 2005 set ftp(LocalFilename) $dest 2006 } 2007 2008 set ftp(RemoteFilename) $source 2009 2010 if {$ftp(inline) == 2} { 2011 set ftp(inline) 0 2012 } 2013 set ftp(State) get_$ftp(Mode) 2014 StateHandler $s 2015 2016 # wait for synchronization 2017 set rc [WaitOrTimeout $s] 2018 2019 # It is important to unset 'get:channel' in all cases or it will 2020 # interfere with any following ftp command (as its existence 2021 # suppresses the closing of the destination channel identifier 2022 # (DestCI). We cannot do it earlier than just before the 'return' 2023 # or code depending on it for the current command may not execute 2024 # correctly. 2025 2026 if { $rc } { 2027 if {![string length $ftp(Command)]} { 2028 ElapsedTime $s [clock seconds] 2029 if {$ftp(inline)} { 2030 catch {unset ftp(get:channel)} 2031 upvar $varname returnData 2032 set returnData $ftp(GetData) 2033 } 2034 } 2035 # catch {unset ftp(get:channel)} 2036 # SF Bug 1708350. DISABLED. In async mode (Open -command) the 2037 # unset here causes HandleData to blow up, see marker <@>. In 2038 # essence in async mode HandleData can be entered multiple 2039 # times, and unsetting get:channel here causes it to think 2040 # that the data goes into a local file, not a channel, but the 2041 # state does not contain local file information, so an error 2042 # is thrown. Removing the catch here seems to fix it without 2043 # adverse effects elsewhere. Maybe. We hope. 2044 return 1 2045 } else { 2046 if {$ftp(inline)} { 2047 catch {unset ftp(get:channel)} 2048 return "" 2049 } 2050 CloseDataConn $s 2051 catch {unset ftp(get:channel)} 2052 return 0 2053 } 2054} 2055 2056############################################################################# 2057# 2058# Reget -- 2059# 2060# RESTART RETRIEVING DATA - Causes the server to transfer a copy of the specified file 2061# to the local site at the other end of the data connection like get but skips over 2062# the file to the specified data checkpoint. 2063# (exported) 2064# 2065# Arguments: 2066# source - remote file name 2067# dest - local file name, if unspecified, ftp assigns 2068# the remote file name. 2069# Returns: 2070# 0 - file not retrieved 2071# 1 - OK 2072 2073proc ::ftp::Reget {s source {dest ""} {from_bytes 0} {till_bytes -1}} { 2074 upvar ::ftp::ftp$s ftp 2075 2076 if { ![info exists ftp(State)] } { 2077 DisplayMsg $s "Not connected!" error 2078 return 0 2079 } 2080 2081 if { $dest == "" } { 2082 set dest $source 2083 } 2084 if {![file exists [file dirname $dest]]} { 2085 return -code error \ 2086 "ftp::Reget, directory \"[file dirname $dest]\" for destination \"$dest\" does not exist" 2087 } 2088 2089 set ftp(RemoteFilename) $source 2090 set ftp(LocalFilename) $dest 2091 set ftp(From) $from_bytes 2092 2093 2094 # Assumes that the local file has a starting offset of $from_bytes 2095 # The following calculation ensures that the download starts from the 2096 # correct offset 2097 2098 if { [file exists $ftp(LocalFilename)] } { 2099 set ftp(FileSize) [ expr {[file size $ftp(LocalFilename)] + $from_bytes }] 2100 2101 if { $till_bytes != -1 } { 2102 set ftp(To) $till_bytes 2103 set ftp(Bytes_to_go) [ expr {$till_bytes - $ftp(FileSize)} ] 2104 2105 if { $ftp(Bytes_to_go) <= 0 } {return 0} 2106 2107 } else { 2108 # till_bytes not set 2109 set ftp(To) end 2110 } 2111 2112 } else { 2113 # local file does not exist 2114 set ftp(FileSize) $from_bytes 2115 2116 if { $till_bytes != -1 } { 2117 set ftp(Bytes_to_go) [ expr {$till_bytes - $from_bytes }] 2118 set ftp(To) $till_bytes 2119 } else { 2120 #till_bytes not set 2121 set ftp(To) end 2122 } 2123 } 2124 2125 set ftp(State) reget_$ftp(Mode) 2126 StateHandler $s 2127 2128 # wait for synchronization 2129 set rc [WaitOrTimeout $s] 2130 if { $rc } { 2131 if {![string length $ftp(Command)]} { 2132 ElapsedTime $s [clock seconds] 2133 } 2134 return 1 2135 } else { 2136 CloseDataConn $s 2137 return 0 2138 } 2139} 2140 2141############################################################################# 2142# 2143# Newer -- 2144# 2145# GET NEWER DATA - Get the file only if the modification time of the remote 2146# file is more recent that the file on the current system. If the file does 2147# not exist on the current system, the remote file is considered newer. 2148# Otherwise, this command is identical to get. 2149# (exported) 2150# 2151# Arguments: 2152# source - remote file name 2153# dest - local file name, if unspecified, ftp assigns 2154# the remote file name. 2155# 2156# Returns: 2157# 0 - file not retrieved 2158# 1 - OK 2159 2160proc ::ftp::Newer {s source {dest ""}} { 2161 upvar ::ftp::ftp$s ftp 2162 2163 if { ![info exists ftp(State)] } { 2164 DisplayMsg $s "Not connected!" error 2165 return 0 2166 } 2167 2168 if {[string length $ftp(Command)]} { 2169 return -code error "unable to retrieve file asynchronously (not implemented yet)" 2170 } 2171 2172 if { $dest == "" } { 2173 set dest $source 2174 } 2175 if {![file exists [file dirname $dest]]} { 2176 return -code error "ftp::Newer, directory \"[file dirname $dest]\" for destination \"$dest\" does not exist" 2177 } 2178 2179 set ftp(RemoteFilename) $source 2180 set ftp(LocalFilename) $dest 2181 2182 # get remote modification time 2183 set rmt [ModTime $s $ftp(RemoteFilename)] 2184 if { $rmt == "-1" } { 2185 return 0 2186 } 2187 2188 # get local modification time 2189 if { [file exists $ftp(LocalFilename)] } { 2190 set lmt [file mtime $ftp(LocalFilename)] 2191 } else { 2192 set lmt 0 2193 } 2194 2195 # remote file is older than local file 2196 if { $rmt < $lmt } { 2197 return 0 2198 } 2199 2200 # remote file is newer than local file or local file doesn't exist 2201 # get it 2202 set rc [Get $s $ftp(RemoteFilename) $ftp(LocalFilename)] 2203 return $rc 2204 2205} 2206 2207############################################################################# 2208# 2209# Quote -- 2210# 2211# The arguments specified are sent, verbatim, to the remote ftp server. 2212# 2213# Arguments: 2214# arg1 arg2 ... 2215# 2216# Returns: 2217# string sent back by the remote ftp server or null string if any error 2218# 2219 2220proc ::ftp::Quote {s args} { 2221 upvar ::ftp::ftp$s ftp 2222 2223 if { ![info exists ftp(State)] } { 2224 DisplayMsg $s "Not connected!" error 2225 return 0 2226 } 2227 2228 set ftp(Cmd) $args 2229 set ftp(Quote) {} 2230 2231 set ftp(State) quote 2232 StateHandler $s 2233 2234 # wait for synchronization 2235 set rc [WaitOrTimeout $s] 2236 2237 unset ftp(Cmd) 2238 2239 if { $rc } { 2240 return $ftp(Quote) 2241 } else { 2242 return {} 2243 } 2244} 2245 2246 2247############################################################################# 2248# 2249# Abort -- 2250# 2251# ABORT - Tells the server to abort the previous ftp service command and 2252# any associated transfer of data. The control connection is not to be 2253# closed by the server, but the data connection must be closed. 2254# 2255# NOTE: This procedure doesn't work properly. Thus the ftp::Abort command 2256# is no longer available! 2257# 2258# Arguments: 2259# None. 2260# 2261# Returns: 2262# 0 - ERROR 2263# 1 - OK 2264# 2265# proc Abort {} { 2266# 2267# } 2268 2269############################################################################# 2270# 2271# Close -- 2272# 2273# Terminates a ftp session and if file transfer is not in progress, the server 2274# closes the control connection. If file transfer is in progress, the 2275# connection will remain open for result response and the server will then 2276# close it. 2277# (exported) 2278# 2279# Arguments: 2280# None. 2281# 2282# Returns: 2283# 0 - ERROR 2284# 1 - OK 2285 2286proc ::ftp::Close {s } { 2287 variable connections 2288 upvar ::ftp::ftp$s ftp 2289 2290 if { ![info exists ftp(State)] } { 2291 DisplayMsg $s "Not connected!" error 2292 return 0 2293 } 2294 2295 if {[info exists \ 2296 connections($ftp(User),$ftp(Passwd),$ftp(RemoteHost),afterid)]} { 2297 unset connections($ftp(User),$ftp(Passwd),$ftp(RemoteHost),afterid) 2298 unset connections($ftp(User),$ftp(Passwd),$ftp(RemoteHost)) 2299 } 2300 2301 set ftp(State) quit 2302 StateHandler $s 2303 2304 # wait for synchronization 2305 WaitOrTimeout $s 2306 2307 catch {close $ftp(CtrlSock)} 2308 catch {unset ftp} 2309 return 1 2310} 2311 2312proc ::ftp::LazyClose {s } { 2313 variable connections 2314 upvar ::ftp::ftp$s ftp 2315 2316 if { ![info exists ftp(State)] } { 2317 DisplayMsg $s "Not connected!" error 2318 return 0 2319 } 2320 2321 if {[info exists connections($ftp(User),$ftp(Passwd),$ftp(RemoteHost))]} { 2322 set connections($ftp(User),$ftp(Passwd),$ftp(RemoteHost),afterid) \ 2323 [after 5000 [list ftp::Close $s]] 2324 } 2325 return 1 2326} 2327 2328############################################################################# 2329# 2330# Open -- 2331# 2332# Starts the ftp session and sets up a ftp control connection. 2333# (exported) 2334# 2335# Arguments: 2336# server - The ftp server hostname. 2337# user - A string identifying the user. The user identification 2338# is that which is required by the server for access to 2339# its file system. 2340# passwd - A string specifying the user's password. 2341# options - -blocksize size writes "size" bytes at once 2342# (default 4096) 2343# -timeout seconds if non-zero, sets up timeout to 2344# occur after specified number of 2345# seconds (default 120) 2346# -progress proc procedure name that handles callbacks 2347# (no default) 2348# -output proc procedure name that handles output 2349# (no default) 2350# -mode mode switch active or passive file transfer 2351# (default active) 2352# -port number alternative port (default 21) 2353# -command proc callback for completion notification 2354# (no default) 2355# 2356# Returns: 2357# 0 - Not logged in 2358# 1 - User logged in 2359 2360proc ::ftp::Open {server user passwd args} { 2361 variable DEBUG 2362 variable VERBOSE 2363 variable serial 2364 variable connections 2365 2366 set s $serial 2367 incr serial 2368 upvar ::ftp::ftp$s ftp 2369# if { [info exists ftp(State)] } { 2370# DisplayMsg $s "Mmh, another attempt to open a new connection? There is already a hot wire!" error 2371# return 0 2372# } 2373 2374 # default NO DEBUG 2375 if { ![info exists DEBUG] } { 2376 set DEBUG 0 2377 } 2378 2379 # default NO VERBOSE 2380 if { ![info exists VERBOSE] } { 2381 set VERBOSE 0 2382 } 2383 2384 if { $DEBUG } { 2385 DisplayMsg $s "Starting new connection with: " 2386 } 2387 2388 set ftp(inline) 0 2389 set ftp(User) $user 2390 set ftp(Passwd) $passwd 2391 set ftp(RemoteHost) $server 2392 set ftp(LocalHost) [info hostname] 2393 set ftp(DataPort) 0 2394 set ftp(Type) {} 2395 set ftp(Error) "" 2396 set ftp(Progress) {} 2397 set ftp(Command) {} 2398 set ftp(Output) {} 2399 set ftp(Blocksize) 4096 2400 set ftp(Timeout) 600 2401 set ftp(Mode) active 2402 set ftp(Port) 21 2403 2404 set ftp(State) user 2405 2406 # set state var 2407 set ftp(state.control) "" 2408 2409 # Get and set possible options 2410 set options {-blocksize -timeout -mode -port -progress -output -command} 2411 foreach {option value} $args { 2412 if { [lsearch -exact $options $option] != "-1" } { 2413 if { $DEBUG } { 2414 DisplayMsg $s " $option = $value" 2415 } 2416 regexp -- {^-(.?)(.*)$} $option all first rest 2417 set option "[string toupper $first]$rest" 2418 set ftp($option) $value 2419 } 2420 } 2421 if { $DEBUG && ([llength $args] == 0) } { 2422 DisplayMsg $s " no option" 2423 } 2424 2425 if {[info exists \ 2426 connections($ftp(User),$ftp(Passwd),$ftp(RemoteHost),afterid)]} { 2427 after cancel $connections($ftp(User),$ftp(Passwd),$ftp(RemoteHost),afterid) 2428 Command $ftp(Command) connect $connections($ftp(User),$ftp(Passwd),$ftp(RemoteHost)) 2429 return $connections($ftp(User),$ftp(Passwd),$ftp(RemoteHost)) 2430 } 2431 2432 2433 # No call of StateHandler is required at this time. 2434 # StateHandler at first time is called automatically 2435 # by a fileevent for the control channel. 2436 2437 # Try to open a control connection 2438 if { ![OpenControlConn $s [expr {[string length $ftp(Command)] > 0}]] } { 2439 return -1 2440 } 2441 2442 # waits for synchronization 2443 # 0 ... Not logged in 2444 # 1 ... User logged in 2445 if {[string length $ftp(Command)]} { 2446 # Don't wait - asynchronous operation 2447 set ftp(NextState) {type connect_last} 2448 set connections($ftp(User),$ftp(Passwd),$ftp(RemoteHost)) $s 2449 return $s 2450 } elseif { [WaitOrTimeout $s] } { 2451 # default type is binary 2452 Type $s binary 2453 set connections($ftp(User),$ftp(Passwd),$ftp(RemoteHost)) $s 2454 Command $ftp(Command) connect $s 2455 return $s 2456 } else { 2457 # close connection if not logged in 2458 Close $s 2459 return -1 2460 } 2461} 2462 2463############################################################################# 2464# 2465# CopyNext -- 2466# 2467# recursive background copy procedure for ascii/binary file I/O 2468# 2469# Arguments: 2470# bytes - indicates how many bytes were written on $ftp(DestCI) 2471 2472proc ::ftp::CopyNext {s bytes {error {}}} { 2473 upvar ::ftp::ftp$s ftp 2474 variable DEBUG 2475 variable VERBOSE 2476 2477 # summary bytes 2478 2479 incr ftp(Total) $bytes 2480 2481 # update bytes_to_go and blocksize 2482 2483 if { [info exists ftp(Bytes_to_go)] } { 2484 set ftp(Bytes_to_go) [expr {$ftp(Bytes_to_go) - $bytes}] 2485 2486 if { $ftp(Blocksize) <= $ftp(Bytes_to_go) } { 2487 set blocksize $ftp(Blocksize) 2488 } else { 2489 set blocksize $ftp(Bytes_to_go) 2490 } 2491 } else { 2492 set blocksize $ftp(Blocksize) 2493 } 2494 2495 # callback for progress bar procedure 2496 2497 if { ([info exists ftp(Progress)]) && \ 2498 [string length $ftp(Progress)] && \ 2499 ([info commands [lindex $ftp(Progress) 0]] != "") } { 2500 eval $ftp(Progress) $ftp(Total) 2501 } 2502 2503 # setup new timeout handler 2504 2505 catch {after cancel $ftp(Wait)} 2506 set ftp(Wait) [after [expr {$ftp(Timeout) * 1000}] [namespace current]::Timeout $s] 2507 2508 if { $DEBUG } { 2509 DisplayMsg $s "-> $ftp(Total) bytes $ftp(SourceCI) -> $ftp(DestCI)" 2510 } 2511 2512 if { $error != "" } { 2513 # Protect the destination channel from destruction if it came 2514 # from the caller. Closing it is not our responsibility in that case. 2515 2516 if {![info exists ftp(get:channel)]} { 2517 catch {close $ftp(DestCI)} 2518 } 2519 catch {close $ftp(SourceCI)} 2520 catch {unset ftp(state.data)} 2521 DisplayMsg $s $error error 2522 2523 } elseif { ([eof $ftp(SourceCI)] || ($blocksize <= 0)) } { 2524 # Protect the destination channel from destruction if it came 2525 # from the caller. Closing it is not our responsibility in that case. 2526 2527 if {![info exists ftp(get:channel)]} { 2528 close $ftp(DestCI) 2529 } 2530 close $ftp(SourceCI) 2531 catch {unset ftp(state.data)} 2532 if { $VERBOSE } { 2533 DisplayMsg $s "D: Port closed" data 2534 } 2535 2536 } else { 2537 fcopy $ftp(SourceCI) $ftp(DestCI) \ 2538 -command [list [namespace current]::CopyNext $s] \ 2539 -size $blocksize 2540 } 2541 return 2542} 2543 2544############################################################################# 2545# 2546# HandleData -- 2547# 2548# Handles ascii/binary data transfer for Put and Get 2549# 2550# Arguments: 2551# sock - socket name (data channel) 2552 2553proc ::ftp::HandleData {s sock} { 2554 upvar ::ftp::ftp$s ftp 2555 2556 # Turn off any fileevent handlers 2557 2558 fileevent $sock writable {} 2559 fileevent $sock readable {} 2560 2561 # create local file for ftp::Get 2562 2563 if { [string match "get*" $ftp(State)] && (!$ftp(inline))} { 2564 2565 # A channel was specified by the caller. Use that instead of a 2566 # file. 2567 2568 # SF Bug 1708350 <@> 2569 if {[info exists ftp(get:channel)]} { 2570 set ftp(DestCI) $ftp(get:channel) 2571 set rc 0 2572 } else { 2573 set rc [catch {set ftp(DestCI) [open $ftp(LocalFilename) w]} msg] 2574 } 2575 if { $rc != 0 } { 2576 DisplayMsg $s "$msg" error 2577 return 0 2578 } 2579 # TODO: Use non-blocking I/O 2580 if { [string equal $ftp(Type) "ascii"] } { 2581 fconfigure $ftp(DestCI) -buffering line -blocking 1 2582 } else { 2583 fconfigure $ftp(DestCI) -buffering line -translation binary -blocking 1 2584 } 2585 } 2586 2587 # append local file for ftp::Reget 2588 2589 if { [string match "reget*" $ftp(State)] } { 2590 set rc [catch {set ftp(DestCI) [open $ftp(LocalFilename) a]} msg] 2591 if { $rc != 0 } { 2592 DisplayMsg $s "$msg" error 2593 return 0 2594 } 2595 # TODO: Use non-blocking I/O 2596 if { [string equal $ftp(Type) "ascii"] } { 2597 fconfigure $ftp(DestCI) -buffering line -blocking 1 2598 } else { 2599 fconfigure $ftp(DestCI) -buffering line -translation binary -blocking 1 2600 } 2601 } 2602 2603 2604 set ftp(Total) 0 2605 set ftp(Start_Time) [clock seconds] 2606 2607 # calculate blocksize 2608 2609 if { [ info exists ftp(Bytes_to_go) ] } { 2610 2611 if { $ftp(Blocksize) <= $ftp(Bytes_to_go) } { 2612 set Blocksize $ftp(Blocksize) 2613 } else { 2614 set Blocksize $ftp(Bytes_to_go) 2615 } 2616 2617 } else { 2618 set Blocksize $ftp(Blocksize) 2619 } 2620 2621 # perform fcopy 2622 fcopy $ftp(SourceCI) $ftp(DestCI) \ 2623 -command [list [namespace current]::CopyNext $s ] \ 2624 -size $Blocksize 2625 return 1 2626} 2627 2628############################################################################# 2629# 2630# HandleList -- 2631# 2632# Handles ascii data transfer for list commands 2633# 2634# Arguments: 2635# sock - socket name (data channel) 2636 2637proc ::ftp::HandleList {s sock} { 2638 upvar ::ftp::ftp$s ftp 2639 variable VERBOSE 2640 2641 if { ![eof $sock] } { 2642 set buffer [read $sock] 2643 if { $buffer != "" } { 2644 set ftp(List) [append ftp(List) $buffer] 2645 } 2646 } else { 2647 close $sock 2648 catch {unset ftp(state.data)} 2649 if { $VERBOSE } { 2650 DisplayMsg $s "D: Port closed" data 2651 } 2652 } 2653 return 2654} 2655 2656############################################################################# 2657# 2658# HandleVar -- 2659# 2660# Handles data transfer for get/put commands that use buffers instead 2661# of files. 2662# 2663# Arguments: 2664# sock - socket name (data channel) 2665 2666proc ::ftp::HandleVar {s sock} { 2667 upvar ::ftp::ftp$s ftp 2668 variable VERBOSE 2669 2670 if {$ftp(Start_Time) == -1} { 2671 set ftp(Start_Time) [clock seconds] 2672 } 2673 2674 if { ![eof $sock] } { 2675 set buffer [read $sock] 2676 if { $buffer != "" } { 2677 append ftp(GetData) $buffer 2678 incr ftp(Total) [string length $buffer] 2679 } 2680 } else { 2681 close $sock 2682 catch {unset ftp(state.data)} 2683 if { $VERBOSE } { 2684 DisplayMsg $s "D: Port closed" data 2685 } 2686 } 2687 return 2688} 2689 2690############################################################################# 2691# 2692# HandleOutput -- 2693# 2694# Handles data transfer for get/put commands that use buffers instead 2695# of files. 2696# 2697# Arguments: 2698# sock - socket name (data channel) 2699 2700proc ::ftp::HandleOutput {s sock} { 2701 upvar ::ftp::ftp$s ftp 2702 variable VERBOSE 2703 2704 if {$ftp(Start_Time) == -1} { 2705 set ftp(Start_Time) [clock seconds] 2706 } 2707 2708 if { $ftp(Total) < [string length $ftp(PutData)] } { 2709 set substr [string range $ftp(PutData) $ftp(Total) \ 2710 [expr {$ftp(Total) + $ftp(Blocksize)}]] 2711 if {[catch {puts -nonewline $sock "$substr"} result]} { 2712 close $sock 2713 catch {unset ftp(state.data)} 2714 if { $VERBOSE } { 2715 DisplayMsg $s "D: Port closed" data 2716 } 2717 } else { 2718 incr ftp(Total) [string length $substr] 2719 } 2720 } else { 2721 fileevent $sock writable {} 2722 close $sock 2723 catch {unset ftp(state.data)} 2724 if { $VERBOSE } { 2725 DisplayMsg $s "D: Port closed" data 2726 } 2727 } 2728 return 2729} 2730 2731############################################################################ 2732# 2733# CloseDataConn -- 2734# 2735# Closes all sockets and files used by the data conection 2736# 2737# Arguments: 2738# None. 2739# 2740# Returns: 2741# None. 2742# 2743proc ::ftp::CloseDataConn {s } { 2744 upvar ::ftp::ftp$s ftp 2745 2746 # Protect the destination channel from destruction if it came 2747 # from the caller. Closing it is not our responsibility. 2748 2749 if {[info exists ftp(get:channel)]} { 2750 catch {unset ftp(get:channel)} 2751 catch {unset ftp(DestCI)} 2752 } 2753 2754 catch {after cancel $ftp(Wait)} 2755 catch {fileevent $ftp(DataSock) readable {}} 2756 catch {close $ftp(DataSock); unset ftp(DataSock)} 2757 catch {close $ftp(DestCI); unset ftp(DestCI)} 2758 catch {close $ftp(SourceCI); unset ftp(SourceCI)} 2759 catch {close $ftp(DummySock); unset ftp(DummySock)} 2760 return 2761} 2762 2763############################################################################# 2764# 2765# InitDataConn -- 2766# 2767# Configures new data channel for connection to ftp server 2768# ATTENTION! The new data channel "sock" is not the same as the 2769# server channel, it's a dummy. 2770# 2771# Arguments: 2772# sock - the name of the new channel 2773# addr - the address, in network address notation, 2774# of the client's host, 2775# port - the client's port number 2776 2777proc ::ftp::InitDataConn {s sock addr port} { 2778 upvar ::ftp::ftp$s ftp 2779 variable VERBOSE 2780 2781 # If the new channel is accepted, the dummy channel will be closed 2782 2783 catch {close $ftp(DummySock); unset ftp(DummySock)} 2784 2785 set ftp(state.data) 0 2786 2787 # Configure translation and blocking modes 2788 2789 set blocking 1 2790 if {[string length $ftp(Command)]} { 2791 set blocking 0 2792 } 2793 2794 if { [string equal $ftp(Type) "ascii"] } { 2795 fconfigure $sock -buffering line -blocking $blocking 2796 } else { 2797 fconfigure $sock -buffering line -translation binary -blocking $blocking 2798 } 2799 2800 # assign fileevent handlers, source and destination CI (Channel Identifier) 2801 2802 # NB: this really does need to be -regexp [PT] 18Mar03 2803 switch -regexp -- $ftp(State) { 2804 list { 2805 fileevent $sock readable [list [namespace current]::HandleList $s $sock] 2806 set ftp(SourceCI) $sock 2807 } 2808 get { 2809 if {$ftp(inline)} { 2810 set ftp(GetData) "" 2811 set ftp(Start_Time) -1 2812 set ftp(Total) 0 2813 fileevent $sock readable [list [namespace current]::HandleVar $s $sock] 2814 } else { 2815 fileevent $sock readable [list [namespace current]::HandleData $s $sock] 2816 set ftp(SourceCI) $sock 2817 } 2818 } 2819 append - 2820 put { 2821 if {$ftp(inline)} { 2822 set ftp(Start_Time) -1 2823 set ftp(Total) 0 2824 fileevent $sock writable [list [namespace current]::HandleOutput $s $sock] 2825 } else { 2826 fileevent $sock writable [list [namespace current]::HandleData $s $sock] 2827 set ftp(DestCI) $sock 2828 } 2829 } 2830 default { 2831 error "Unknown state \"$ftp(State)\"" 2832 } 2833 } 2834 2835 if { $VERBOSE } { 2836 DisplayMsg $s "D: Connection from $addr:$port" data 2837 } 2838 return 2839} 2840 2841############################################################################# 2842# 2843# OpenActiveConn -- 2844# 2845# Opens a ftp data connection 2846# 2847# Arguments: 2848# None. 2849# 2850# Returns: 2851# 0 - no connection 2852# 1 - connection established 2853 2854proc ::ftp::OpenActiveConn {s } { 2855 upvar ::ftp::ftp$s ftp 2856 variable VERBOSE 2857 2858 # Port address 0 is a dummy used to give the server the responsibility 2859 # of getting free new port addresses for every data transfer. 2860 2861 set rc [catch {set ftp(DummySock) [socket -server [list [namespace current]::InitDataConn $s] 0]} msg] 2862 if { $rc != 0 } { 2863 DisplayMsg $s "$msg" error 2864 return 0 2865 } 2866 2867 # get a new local port address for data transfer and convert it to a format 2868 # which is useable by the PORT command 2869 2870 set p [lindex [fconfigure $ftp(DummySock) -sockname] 2] 2871 if { $VERBOSE } { 2872 DisplayMsg $s "D: Port is $p" data 2873 } 2874 set ftp(DataPort) "[expr {$p / 256}],[expr {$p % 256}]" 2875 2876 return 1 2877} 2878 2879############################################################################# 2880# 2881# OpenPassiveConn -- 2882# 2883# Opens a ftp data connection 2884# 2885# Arguments: 2886# buffer - returned line from server control connection 2887# 2888# Returns: 2889# 0 - no connection 2890# 1 - connection established 2891 2892proc ::ftp::OpenPassiveConn {s buffer} { 2893 upvar ::ftp::ftp$s ftp 2894 2895 if { [regexp -- {([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+)} $buffer all a1 a2 a3 a4 p1 p2] } { 2896 set ftp(LocalAddr) "$a1.$a2.$a3.$a4" 2897 set ftp(DataPort) "[expr {$p1 * 256 + $p2}]" 2898 2899 # establish data connection for passive mode 2900 2901 set rc [catch {set ftp(DataSock) [socket $ftp(LocalAddr) $ftp(DataPort)]} msg] 2902 if { $rc != 0 } { 2903 DisplayMsg $s "$msg" error 2904 return 0 2905 } 2906 2907 InitDataConn $s $ftp(DataSock) $ftp(LocalAddr) $ftp(DataPort) 2908 return 1 2909 } else { 2910 return 0 2911 } 2912} 2913 2914############################################################################# 2915# 2916# OpenControlConn -- 2917# 2918# Opens a ftp control connection 2919# 2920# Arguments: 2921# s connection id 2922# block blocking or non-blocking mode 2923# 2924# Returns: 2925# 0 - no connection 2926# 1 - connection established 2927 2928proc ::ftp::OpenControlConn {s {block 1}} { 2929 upvar ::ftp::ftp$s ftp 2930 variable DEBUG 2931 variable VERBOSE 2932 2933 # open a control channel 2934 2935 set rc [catch {set ftp(CtrlSock) [socket $ftp(RemoteHost) $ftp(Port)]} msg] 2936 if { $rc != 0 } { 2937 if { $VERBOSE } { 2938 DisplayMsg $s "C: No connection to server!" error 2939 } 2940 if { $DEBUG } { 2941 DisplayMsg $s "[list $msg]" error 2942 } 2943 unset ftp(State) 2944 return 0 2945 } 2946 2947 # configure control channel 2948 2949 fconfigure $ftp(CtrlSock) -buffering line -blocking $block -translation {auto crlf} 2950 fileevent $ftp(CtrlSock) readable [list [namespace current]::StateHandler $s $ftp(CtrlSock)] 2951 2952 # prepare local ip address for PORT command (convert pointed format 2953 # to comma format) 2954 2955 set ftp(LocalAddr) [lindex [fconfigure $ftp(CtrlSock) -sockname] 0] 2956 set ftp(LocalAddr) [string map {. ,} $ftp(LocalAddr)] 2957 2958 # report ready message 2959 2960 set peer [fconfigure $ftp(CtrlSock) -peername] 2961 if { $VERBOSE } { 2962 DisplayMsg $s "C: Connection from [lindex $peer 0]:[lindex $peer 2]" control 2963 } 2964 2965 return 1 2966} 2967 2968# ::ftp::Command -- 2969# 2970# Wrapper for evaluated user-supplied command callback 2971# 2972# Arguments: 2973# cb callback script 2974# msg what happened 2975# args additional info 2976# 2977# Results: 2978# Depends on callback script 2979 2980proc ::ftp::Command {cb msg args} { 2981 if {[string length $cb]} { 2982 uplevel #0 $cb [list $msg] $args 2983 } 2984} 2985 2986# ================================================================== 2987# ?????? Hmm, how to do multithreaded for tkcon? 2988# added TkCon support 2989# TkCon is (c) 1995-2001 Jeffrey Hobbs, http://tkcon.sourceforge.net/ 2990# started with: tkcon -load ftp 2991if { [string equal [uplevel "#0" {info commands tkcon}] "tkcon"] } { 2992 2993 # new ftp::List proc makes the output more readable 2994 proc ::ftp::__ftp_ls {args} { 2995 foreach i [eval ::ftp::List_org $args] { 2996 puts $i 2997 } 2998 } 2999 3000 # rename the original ftp::List procedure 3001 rename ::ftp::List ::ftp::List_org 3002 3003 alias ::ftp::List ::ftp::__ftp_ls 3004 alias bye catch {::ftp::Close; exit} 3005 3006 set ::ftp::VERBOSE 1 3007 set ::ftp::DEBUG 0 3008} 3009 3010# ================================================================== 3011# At last, everything is fine, we can provide the package. 3012 3013package provide ftp [lindex {Revision: 2.4.9} 1] 3014