1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
|
# ftp_geturl.tcl --
#
# Copyright (c) 2001 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
#
# ftp::geturl url
package require ftp
package require uri
namespace eval ::ftp {
namespace export geturl
}
# ::ftp::geturl
#
# Command useable by uri to retrieve the contents of an ftp url.
# Returns the contents of the requested url.
proc ::ftp::geturl {url} {
# FUTURE: -validate to validate existence of url, but no download
# of contents.
array set urlparts [uri::split $url]
if {$urlparts(user) == {}} {
set urlparts(user) "anonymous"
}
if {$urlparts(pwd) == {}} {
set urlparts(pwd) "user@localhost.localdomain"
}
if {$urlparts(port) == {}} {
set urlparts(port) 21
}
set fdc [ftp::Open $urlparts(host) $urlparts(user) $urlparts(pwd) \
-port $urlparts(port)]
if {$fdc < 0} {
return -code error "Cannot reach host for url \"$url\""
}
# We have reached the host, now get on to retrieve the item.
# We are very careful in accessing the item because we don't know
# if it is a file, directory or link. So we change into the
# directory containing the item, get a list of all entries and
# then determine if the item actually exists and what type it is,
# and what actions to perform.
set ftp_dir [file dirname $urlparts(path)]
set ftp_file [file tail $urlparts(path)]
set result [ftp::Cd $fdc $ftp_dir]
if { $result == 0 } {
ftp::Close $fdc
return -code error "Cannot reach directory of url \"$url\""
}
# Fix for the tkcon List enhancements in ftp.tcl
set List ::ftp::List_org
if {[info commands $List] == {}} {
set List ::ftp::List
}
# The result of List is a list of entries in the given directory.
# Note that it is in 'ls -l format. We parse that into a more
# readable array.
#array set flist [ftp::ParseList [$List $fdc ""]]
#if {![info exists flist($ftp_file)]} {}
set flist [$List $fdc $ftp_file]
if {$flist == {}} {
ftp::Close $fdc
return -code error "Cannot reach item of url \"$url\""
}
# The item exists, what is it ?
# File : Download the contents.
# Directory: Download a listing, this is its contents.
# Link : For now we do not follow the link but return the
# meta information, i.e. the path it is pointing to.
#switch -exact -- [lindex $flist($ftp_file) 0] {}
switch -exact -- [string index [lindex $flist 0] 0] {
- {
if {[string equal $ftp_file {}]} {
set contents [ftp::NList $fdc $ftp_file]
} else {
ftp::Get $fdc $ftp_file -variable contents
}
}
d {
set contents [ftp::NList $fdc $ftp_file]
}
l {
set contents $flist
}
default {
ftp::Close $fdc
return -code error "File information \"$flist\" not recognised"
}
}
ftp::Close $fdc
return $contents
}
# Internal helper to parse a directory listing into something which
# can be better handled by tcl than raw ls -l format.
proc ::ftp::ParseList {flist} {
array set data {}
foreach item $flist {
foreach {mode dummy owner group size month day yrtime name} $item break
if {[string first : $yrtime] >=0} {
set date "$month/$day/[clock format [clock seconds] -format %Y] $yrtime"
} else {
set date "$month/$day/$yrtime 00:00"
}
set info [list owner $owner group $group size $size date $date]
switch -exact -- [string index $mode 0] {
- {set type file}
d {set type dir}
l {set type link ; lappend info link [lindex $item end]}
}
set data($name) [list $type $info]
}
array get data
}
# ==================================================================
# At last, everything is fine, we can provide the package.
package provide ftp::geturl [lindex {Revision: 0.2.2} 1]
|
