Attachment "476804.diff" to
ticket [476804ffff]
added by
andreas_kupries
2001-11-17 06:36:14.
? modules/fileinput
? modules/comm/comm.n.OLD
? modules/ftp/example
? modules/ftpd/examples
Index: ChangeLog
===================================================================
RCS file: /cvsroot/tcllib/tcllib/ChangeLog,v
retrieving revision 1.83
diff -u -r1.83 ChangeLog
--- ChangeLog 2001/11/16 21:44:46 1.83
+++ ChangeLog 2001/11/16 23:34:19
@@ -4,6 +4,8 @@
* comm: Fixed bug #480227.
+ * ftp, uri: Implemented FR #476804.
+
2001-11-12 Andreas Kupries <[email protected]>
* irc: New module. Internet protocol handling. Internet Relay Chat
Index: modules/ftp/ChangeLog
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/ftp/ChangeLog,v
retrieving revision 1.18
diff -u -r1.18 ChangeLog
--- modules/ftp/ChangeLog 2001/11/08 06:26:41 1.18
+++ modules/ftp/ChangeLog 2001/11/16 23:34:19
@@ -1,3 +1,13 @@
+2001-11-16 Andreas Kupries <[email protected]>
+
+ * ftp.n: updated documentation to cover the new code below.
+
+ * ftp_geturl.tcl: New file, provides a geturl command for use by
+ uri. Declared in a separate package to avoid a cyclic dependency
+ between the ftp and uri packages. The uri package is changed to
+ try for a scheme::geturl package first and then for a scheme
+ package to get the desired functionality. Implements FR #476804.
+
2001-11-06 Andreas Kupries <[email protected]>
* ftp.tcl: Applied patch in #478478 to handle non-standard date
Index: modules/ftp/ftp.n
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/ftp/ftp.n,v
retrieving revision 1.3
diff -u -r1.3 ftp.n
--- modules/ftp/ftp.n 2001/11/07 02:48:29 1.3
+++ modules/ftp/ftp.n 2001/11/16 23:34:19
@@ -15,6 +15,8 @@
.sp
package require \fBftp ?2.2.1?\fR
.sp
+package require \fBftp::geturl ?0.1?\fR ; # for ftp::geturl command
+.sp
\fBftp::Open\fR \fIserver\fR \fIuser\fR \fIpasswd\fR ?\fIoptions\fR?\fR
.sp
\fBftp::Close\fR \fIhandle\fR\fR
@@ -55,6 +57,8 @@
.sp
\fBftp::DisplayMsg\fR \fIhandle\fR \fImsg\fR ?\fIstate\fR?\fR
.sp
+\fBftp::geturl\fR \fIurl\fR
+.sp
.BE
.SH "DESCRIPTION"
.PP
@@ -94,6 +98,26 @@
such a case they will not return a failure code as described below but
pass the thrown error to their caller.
.SH "API"
+.TP
+\fBftp::geturl \fIurl\fR
+This command lives in its own package, \fBftp::geturl\fR, and can be
+used by the generic \fBuri::geturl\fR command to retrieve the contents
+of ftp urls. Internally it uses the ftp commands described below to
+fulfill the request.
+.sp
+The contents of an ftp url are defined as follows:
+.RS
+.TP
+\fBfile\fR
+The contents of the specified file itself.
+.TP
+\fBdirectory\fR
+A listing of the contents of the directory in key value notation where
+the file name is the key and its attributes the associated value.
+.TP
+\fBlink\fR
+The attributes of the link, including the path it refers to.
+.RE
.TP
\fBftp::Open\fR \fIserver\fR \fIuser\fR \fIpasswd\fR ?\fIoptions\fR?\fR
This command is used to start a FTP session by establishing a control
Index: modules/ftp/ftp.tcl
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/ftp/ftp.tcl,v
retrieving revision 1.18
diff -u -r1.18 ftp.tcl
--- modules/ftp/ftp.tcl 2001/11/08 06:26:41 1.18
+++ modules/ftp/ftp.tcl 2001/11/16 23:34:19
@@ -34,7 +34,7 @@
# ftp::MkDir <s> <directory>
# ftp::RmDir <s> <directory>
# ftp::Quote <s> <arg1> <arg2> ...
-#
+
package require Tcl 8.2
package require log ; # tcllib/log, general logging facility.
@@ -2774,6 +2774,7 @@
}
}
+# ==================================================================
# ?????? Hmm, how to do multithreaded for tkcon?
# added TkCon support
# TkCon is (c) 1995-2001 Jeffrey Hobbs, http://tkcon.sourceforge.net/
@@ -2797,6 +2798,7 @@
set ::ftp::DEBUG 0
}
+# ==================================================================
# At last, everything is fine, we can provide the package.
-package provide ftp [lindex {Revision: 2.2.1} 1]
\ No newline at end of file
+package provide ftp [lindex {Revision: 2.2.1} 1]
Index: modules/ftp/ftp_geturl.tcl
===================================================================
RCS file: ftp_geturl.tcl
diff -N ftp_geturl.tcl
--- /dev/null Thu May 24 22:33:05 2001
+++ ftp_geturl.tcl Fri Nov 16 15:34:19 2001
@@ -0,0 +1,106 @@
+# ftp_geturl.tcl --
+#
+# Copyright (c) 2001 by Andreas Kupries <[email protected]>
+#
+# 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]
+
+ set fdc [ftp::Open $urlparts(host) anonymous [email protected]]
+ 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\""
+ }
+
+ # 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 [ftp::List $fdc ""]]
+ if {![info exists flist($ftp_file)]} {
+ 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] {
+ file {
+ ftp::Get $fdc $ftp_file -variable contents
+ }
+ dir {
+ set contents [ftp::ParseList [ftp::List $fdc $ftp_file]]
+ }
+ link {
+ set contents $flist($ftp_file)
+ }
+ }
+
+ 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.1} 1]
Index: modules/ftp/pkgIndex.tcl
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/ftp/pkgIndex.tcl,v
retrieving revision 1.5
diff -u -r1.5 pkgIndex.tcl
--- modules/ftp/pkgIndex.tcl 2001/10/17 17:27:26 1.5
+++ modules/ftp/pkgIndex.tcl 2001/11/16 23:34:19
@@ -9,4 +9,6 @@
# full path name of this file's directory.
if {![package vsatisfies [package provide Tcl] 8.2]} {return}
-package ifneeded ftp 2.2.1 [list source [file join $dir ftp.tcl]]
+
+package ifneeded ftp 2.2.1 [list source [file join $dir ftp.tcl]]
+package ifneeded ftp::geturl 0.1 [list source [file join $dir ftp_geturl.tcl]]
Index: modules/uri/ChangeLog
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/uri/ChangeLog,v
retrieving revision 1.10
diff -u -r1.10 ChangeLog
--- modules/uri/ChangeLog 2001/10/31 23:54:12 1.10
+++ modules/uri/ChangeLog 2001/11/16 23:34:19
@@ -1,3 +1,11 @@
+2001-11-16 Andreas Kupries <[email protected]>
+
+ * uri.n: Updated documentation to cover the change below.
+
+ * uri.tcl: Changed geturl dispatcher to load a scheme::geturl
+ first and the scheme package only if that fails. see the ftp and
+ ftp::geturl packages. FR #476804.
+
2001-10-31 Pat Thoyts <[email protected]>
* uri.tcl: Fixed the ftptype regexp so that the type identifier
Index: modules/uri/uri.n
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/uri/uri.n,v
retrieving revision 1.6
diff -u -r1.6 uri.n
--- modules/uri/uri.n 2001/10/31 23:54:12 1.6
+++ modules/uri/uri.n 2001/11/16 23:34:19
@@ -61,12 +61,14 @@
\fBuri::geturl\fR decodes the specified \fIurl\fR and then dispatches
the request to the package appropriate for the scheme found in the
url. The command assumes that the package to handle the given scheme
-has the same name as the scheme itself (including possible
-capitalization). It further assumes that the package provides a
-\fBgeturl\fR-command in the namespace of the same name as the package
-itself. This command is called with the given \fIurl\fR and all given
-\fIoptions\fR. Currently \fBgeturl\fR does not handle any options
-itself.
+either has the same name as the scheme itself (including possible
+capitalization) followed by \fB::geturl\fR, or, in case of this
+failing, has the same name as the scheme itself (including possible
+capitalization). It further assumes that whatever package was loaded
+provides a \fBgeturl\fR-command in the namespace of the same name as
+the package itself. This command is called with the given \fIurl\fR
+and all given \fIoptions\fR. Currently \fBgeturl\fR does not handle
+any options itself.
.PP
\fBNote:\fR \fBfile\fR-urls are an exception to the rule described
above. They are handled internally.
Index: modules/uri/uri.tcl
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/uri/uri.tcl,v
retrieving revision 1.10
diff -u -r1.10 uri.tcl
--- modules/uri/uri.tcl 2001/10/31 23:54:12 1.10
+++ modules/uri/uri.tcl 2001/11/16 23:34:19
@@ -615,10 +615,13 @@
file {
return [eval file_geturl [list $url] $args]
}
-
default {
- package require $urlparts(scheme)
-
+ # Load a geturl package for the scheme first and only if
+ # that fails the scheme package itself. This prevents
+ # cyclic dependencies between packages.
+ if {[catch {package require $urlparts(scheme)::geturl}]} {
+ package require $urlparts(scheme)
+ }
return [eval [list $urlparts(scheme)::geturl $url] $args]
}
}
