1# -*- Tcl -*- $
2
3package provide xotcl::comm::ftp 2.0
4package require xotcl::comm::httpAccess
5
6package require XOTcl 2.0
7
8namespace eval ::xotcl::comm::ftp {
9    namespace import ::xotcl::*
10
11    Class Ftp -superclass NetAccess -parameter {user passwd}
12    Ftp instproc initialize args {
13	#my showCall
14	my instvar port caching user passwd loginMsg resp blocksize
15	set port 21
16	set blocksize 1024
17	set caching 0
18	set user ftp
19	set passwd cineast@
20	set loginMsg {}
21	set resp(connect)       {220 provideUser}
22	set resp(provideUser)   {331 providePasswd}
23	set resp(providePasswd) {230 loginFinished}
24	set resp(loginFinished) {227 pasv}
25	set resp(pasv)          {200 type}
26	set resp(type-list)     {150 list}
27	set resp(type-retr)     {150 retr 550 retry-retrieve}
28	set resp(transfer)      {226 transferDone}
29	next
30    }
31    Ftp instproc err {state reply} {
32	my abort "Error in $state: $reply"
33    }
34    Ftp instproc queryServer {query state} {
35	my instvar S
36	puts $S $query
37	flush $S
38	fileevent $S readable [::list [self] response $state]
39    }
40    Ftp instproc response {state} {
41	#my showCall
42	my instvar S code msg
43	set reply [gets $S]
44	#my showVars reply
45	if {[regexp {^([0-9]+)[-](.*)$} $reply _ code msg]} {
46	    fileevent $S readable [::list [self] responseMulti $state]
47	} else {
48	    regexp {^([0-9]+) (.*)$} $reply _ code msg
49	    my responseEnd $state
50	}
51    }
52    Ftp instproc responseMulti {state} {
53	# multi line response
54	my instvar S code msg
55	set m [gets $S]
56	if {[regexp "^$code " $m]} {
57	    my responseEnd $state
58	} else {
59	    # try to strip code and dash
60	    regexp "^$code-(.*)\$" $m _ m
61	    append msg \n$m
62	}
63    }
64    Ftp instproc responseEnd {state} {
65	my instvar S code msg resp
66	fileevent $S readable {}
67	#puts stderr "code=$code, msg=<$msg>"
68	foreach {c newState} $resp($state) {
69	    if {$c == $code} { return [my $newState] }
70	}
71	my err $state "expected=$resp($state), got $code $msg"
72    }
73    Ftp instproc GET {} {
74	my instvar S  host port url
75	regexp {^(.*):([0-9]+)$} $host _ host port
76	my running
77	# rb running my $url ;# ???
78	# proxy ?
79	set S [socket -async $host $port]
80	fconfigure $S -blocking false -translation {auto crlf}
81	fileevent $S readable [::list [self] response connect]
82    }
83    Ftp instproc provideUser {} {
84	my instvar user msg loginMsg
85	set loginMsg $msg
86	my queryServer "USER $user" provideUser
87    }
88    Ftp instproc providePasswd {} {
89	my instvar passwd
90	#  if {[pwdManager requirePasswd "Ftp $user\@$host" $user password]} {
91	#    my queryServer "PASS $password" providePasswd
92	#  }
93	my queryServer "PASS $passwd" providePasswd
94    }
95    Ftp instproc loginFinished {} {
96	my instvar msg loginMsg
97	append  loginMsg \n$msg
98	my queryServer "PASV" loginFinished
99    }
100    Ftp instproc pasv {} {
101	my instvar S D msg
102	set d {([0-9]+)}
103	if {[regexp "\[(]$d,$d,$d,$d,$d,$d" $msg _ 1 2 3 4 p1 p2]} {
104	    if {[catch {set D [socket -async $1.$2.$3.$4 [expr {$p1*256 + $p2}]]} err
105		]} {
106		return [my err $proc $err]
107	    }
108	    fconfigure $D -blocking no -translation binary
109	} else {
110	    return [my err $proc $msg]
111	}
112	my queryServer "TYPE I" pasv
113    }
114    Ftp instproc type {} {
115	my instvar path
116	if {$path=={}} {
117	    my queryServer "LIST" type-list
118	} elseif {[regexp /$ $path]} {
119	    my queryServer "LIST $path" type-list
120	} else {
121	    my queryServer "RETR $path" type-retr
122	}
123    }
124    Ftp instproc retry-retrieve {} {
125	my instvar path url
126	append url /
127	my queryServer "LIST $path/" type-list
128    }
129    Ftp instproc list {} {
130	my instvar S D contentType
131	set contentType text/dirlist
132	my headerDone
133	fileevent $S readable [::list [self] response transfer]
134	fileevent $D readable [::list [self] readData]
135    }
136    Ftp instproc read {} {
137	# the method read is called by the more general method readData
138	my instvar D block blocksize
139	if {[::eof $D]} {
140	    set block ""
141	    close $D
142	    unset D
143	} else {
144	    #puts stderr blocksize=$blocksize
145	    set block [::read $D $blocksize]
146	    #puts stderr read:[string length $block]bytes
147	}
148    }
149    Ftp instproc transferDone {} {
150	my instvar D S
151	if {[info exists D]} {
152	    fileevent $S readable {}
153	    set block ""
154	    close $D
155	    unset D
156	}
157	my finish
158    }
159    Ftp instproc retr {} {
160	my instvar S D msg totalsize contentType path
161	regexp {[(]([0-9]+)[ ]+[Bb]ytes} $msg _ totalsize
162	set contentType [Mime guessContentType $path]
163	my headerDone
164	if {[info exists S]} {
165	    # file dialog was not canceled
166	    fileevent $S readable [::list [self] response transfer]
167	    fileevent $D readable [::list [self] readData]
168	    fconfigure $D -translation binary
169	}
170    }
171
172    namespace export Ftp
173}
174
175namespace import ::xotcl::comm::ftp::*
176