--- /dev/null
+#!/bin/sh
+# restart using wish \
+ exec wish8.0 $0 ${1+"$@"}
+
+# sockspy: copyright tom poindexter 1998
+# tpoindex@nyx.net
+# version 1.0 - december 10, 1998
+# version 2.0 - Keith Vetter keith@ebook.gemstar.com
+# reorganized GUI to be 1 pane with different colors
+# allow changing socket info
+# works both as GUI and command line interface
+#
+# spy on conversation between a tcp client and server
+#
+# usage: sockspy clientPort serverHost serverPort
+# clientPort - port to which clients connect
+# serverHost - machine where real server runs
+# serverPort - port on which real server listens
+#
+# e.g. to snoop on http connections to a web server:
+# sockspy 8080 webhost 80
+# then client web browser should use a url like:
+# http://localhost:8080/index.html
+# (or set your browser's proxy to use 8080 on the sockspy machine)
+
+array set state {
+ bbar 1
+ ascii 1
+ auto 1
+ msg ""
+ fixed {}
+ fixedbold {}
+ playback ""
+ gui 0
+ listen ""
+}
+##+##########################################################################
+#
+# createMain
+#
+# Creates the display
+#
+proc createMain {} {
+ global state tcl_platform
+
+ if {! $state(gui)} return
+
+ set state(fixed) [font create -family courier -size 10]
+ set state(fixedbold) [font create -family courier -size 10 -weight bold]
+ if {"$tcl_platform(platform)" == "windows"} {
+ doFont -1
+ }
+ wm title . "sockspy"
+ wm resizable . 1 1
+ wm protocol . WM_DELETE_WINDOW Shutdown ;# So we shut down cleanly
+
+ #
+ # Set up the menus
+ #
+ menu .m -tearoff 0
+ . configure -menu .m
+ .m add cascade -menu .m.file -label "File" -underline 0
+ .m add cascade -menu .m.view -label "View" -underline 0
+
+ menu .m.file -tearoff 0
+ .m.file add command -label "Save" -underline 0 -command saveOutput
+ .m.file add command -label "Reconnect" -underline 0 -command GetSetup
+ .m.file add separator
+ .m.file add command -label "Exit" -underline 1 -command Shutdown
+
+ menu .m.view -tearoff 0
+ .m.view add command -label " Clear" -underline 1 -command clearOutput
+ .m.view add separator
+ .m.view add checkbutton -label " ButtonBar" -variable state(bbar) \
+ -underline 1 -command ButtonBar
+ .m.view add separator
+ .m.view add command -label " + Font" -command [list doFont 1]
+ .m.view add command -label " - Font" -command [list doFont -1]
+ .m.view add separator
+ .m.view add radiobutton -label " Hex" -underline 1 \
+ -variable state(ascii) -value 0 -command redraw
+ .m.view add radiobutton -label " ASCII" -underline 1 \
+ -variable state(ascii) -value 1 -command redraw
+ .m.view add separator
+ .m.view add checkbutton -label " Autoscroll" -underline 5 \
+ -variable state(auto)
+
+ #
+ # Title and status window
+ #
+ pack [frame .bbar] -side top -fill x
+ frame .cmd -relief sunken -bd 2
+ radiobutton .cmd.hex -text Hex -variable state(ascii) \
+ -value 0 -command redraw
+ radiobutton .cmd.ascii -text ASCII -variable state(ascii) \
+ -value 1 -command redraw
+ checkbutton .cmd.auto -text Autoscroll -variable state(auto)
+ button .cmd.clear -text Clear -command clearOutput
+ button .cmd.incr -text "+ Font" -command [list doFont 1]
+ button .cmd.decr -text "- Font" -command [list doFont -1]
+ button .cmd.save -text Save -command saveOutput
+ button .cmd.kill -text Exit -command Shutdown
+ pack .cmd.kill .cmd.save .cmd.clear .cmd.decr .cmd.incr .cmd.auto \
+ .cmd.ascii .cmd.hex -side right -padx 3 -pady 3
+ pack .cmd -side top -fill x -pady 5 -in .bbar
+
+ frame .top
+ pack .top -side top -fill x -pady 2 -expand 1
+ #button .clear -text Clear -command clearOutput
+ #pack .clear -in .top -side right -padx 3
+
+ label .title -relief ridge
+ .title config -font "[.title cget -font] bold"
+ .title config -text "localhost:$::clntPort <--> $::servHost:$::servPort"
+ pack .title -in .top -side left -fill both -expand 1
+
+ label .stat -textvariable state(msg) -relief ridge -anchor w
+ pack .stat -side bottom -fill x
+
+ #
+ # Now for the output area of the display
+ #
+ text .out -width 80 -height 50 -font $state(fixed) \
+ -yscrollcommand ".scroll set" -bg white -setgrid 1
+ .out tag configure server -background cyan -borderwidth 2 -relief raised
+ .out tag configure client -background green -borderwidth 2 -relief raised
+ .out tag configure client2 -font $state(fixedbold)
+ .out tag configure meta -background red -borderwidth 2 -relief raised
+ scrollbar .scroll -orient vertical -command {.out yview}
+ pack .scroll -side right -fill y
+ pack .out -side left -fill both -expand 1
+
+ wm geometry . +10+10
+}
+##+##########################################################################
+#
+# doFont
+#
+# Changes the size of the font used for the display text
+#
+proc doFont {delta} {
+ global state
+ set size [font configure $state(fixed) -size]
+
+ incr size $delta
+ font configure $state(fixed) -size $size
+ font configure $state(fixedbold) -size $size
+}
+##+##########################################################################
+#
+# clearOutput
+#
+# Erases the content of the output window
+#
+proc clearOutput {} {
+ global state
+ if {$state(gui)} {
+ .out delete 0.0 end
+ }
+ set state(playback) ""
+}
+##+##########################################################################
+#
+# redraw
+#
+# Redraws the contents of the output window. It does this by replaying
+# the input stream.
+#
+proc redraw {} {
+ global state
+
+ set save $state(auto) ;# Disable autoscrolling
+ set state(auto) 0
+
+ set p $state(playback) ;# Save what gets displayed
+ clearOutput ;# Erase current screen
+ foreach {who data} $p { ;# Replay the input stream
+ insertData $who $data
+ }
+ set state(auto) $save
+}
+##+##########################################################################
+#
+# saveOutput
+#
+# Saves the content of the output window. It uses the playback stream as
+# its data source.
+#
+proc saveOutput {} {
+ global state
+
+ set but [tk_dialog .what "save" "save which window?" "" 2 \
+ server client both cancel]
+ if {$but == -1 || $but == 3} {
+ return
+ }
+ set file [tk_getSaveFile -parent .]
+ if {"$file" == ""} {
+ return
+ }
+ if {[catch {open $file w} fd]} {
+ tk_messageBox -message "file $file cannot be opened" -icon error \
+ -type ok
+ return
+ }
+ fconfigure $fd -translation binary
+ foreach {who data} $state(playback) {
+ if {$who == "meta"} continue
+ if {$but == 2 || ($but == 0 && $who == "server") || \
+ ($but == 1 && $who == "client")} {
+ puts $fd $data
+ }
+ }
+ close $fd
+ bell
+}
+##+##########################################################################
+#
+# printable
+#
+# Replaces all unprintable characters into dots.
+#
+proc printable {s {spaces 0}} {
+ regsub -all {[^\x20-\x7e]} $s "." n
+ if {$spaces} {
+ regsub -all { } $n "_" n
+ }
+ return $n;
+}
+##+##########################################################################
+#
+# insertData
+#
+# Inserts data into the output window. WHO tells us if it is from
+# the client, server or meta.
+#
+proc insertData {who data} {
+ global state
+ array set prefix {meta = client > server <}
+
+ lappend state(playback) $who $data ;# Save for redraw and saving
+
+ if {$state(ascii) || [string equal $who meta]} {
+ regsub -all \r $data "" data
+ foreach line [split $data \n] {
+ set line [printable $line]
+ set tag $who
+ if {$tag == "client" && [regexp -nocase {^get |post } $line]} {
+ lappend tag client2
+ }
+ if {$state(gui)} {
+ .out insert end "$line\n" $tag
+ } else {
+ puts "$prefix($who)$line"
+ }
+ }
+ } else { ;# Hex output
+ while {[string length $data]} {
+ set line [string range $data 0 15]
+ set data [string range $data [string length $line] end]
+ binary scan $line H* hex
+ regsub -all {([0-9a-f][0-9a-f])} $hex {\1 } hex
+ set line [format "%-48.48s %-16.16s\n" $hex [printable $line 1]]
+ if {$state(gui)} {
+ .out insert end $line $who
+ } else {
+ puts "$prefix(who)$line"
+ }
+ }
+ }
+ if {$state(auto) && $state(gui)} {
+ .out see end
+ }
+}
+##+##########################################################################
+#
+# INFO
+#
+# Puts up an informational message both in the output window and
+# in the status window.
+#
+proc INFO {msg} {
+ global state
+ set state(msg) $msg
+ insertData meta $msg
+}
+##+##########################################################################
+#
+# sockReadable
+#
+# Called when there is data available on the fromSocket
+#
+proc sockReadable {fromSock toSock who} {
+ global state
+ set data [read $fromSock]
+ if {[string length $data] == 0} {
+ close $fromSock
+ catch { close $toSock }
+ insertData meta "----- closed connection -----"
+ INFO "waiting for new connection..."
+ return
+ }
+ insertData $who $data
+ catch { puts -nonewline $toSock $data } ;# Forward if we have a socket
+
+ update
+}
+##+##########################################################################
+#
+# clntConnect
+#
+# Called when we get a new client connection
+#
+proc clntConnect {servHost servPort sockClnt ip port} {
+ global state
+
+ set state(sockClnt) $sockClnt
+
+ INFO "connect from [fconfigure $sockClnt -sockname] $port"
+ if {$servHost == {} || $servHost == "none"} {
+ set sockServ ""
+ } elseif {[catch {set sockServ [socket $servHost $servPort]} reason]} {
+ INFO "cannot connect: $reason"
+ tk_messageBox -icon error -type ok \
+ -message "cannot connect to $servHost $servPort: $reason"
+ exit
+ }
+
+ ;# Configure connection to the client
+ fconfigure $sockClnt -blocking 0 -buffering none -translation binary
+ fileevent $sockClnt readable \
+ [list sockReadable $sockClnt $sockServ client]
+
+ ;# Configure connection to the server
+ if {[string length $sockServ]} {
+ fconfigure $sockServ -blocking 0 -buffering none -translation binary
+ fileevent $sockServ readable \
+ [list sockReadable $sockServ $sockClnt server]
+ }
+}
+##+##########################################################################
+#
+# DoListen
+#
+# Opens the socket server to listen for connections. It first closes it if
+# it is already open.
+#
+proc DoListen {} {
+ global state clntPort servHost servPort
+
+ catch {close $state(sockClnt)} ;# Only the last open connection
+
+ ;# Close old listener if it exists
+ if {$state(listen) != ""} {
+ set n [catch {close $state(listen)} emsg]
+ if {$n} { INFO "socket close error: $emsg"}
+ set state(listen) ""
+ update ;# Need else socket below fails
+ }
+
+ set n [catch {set state(listen) \
+ [socket -server [list clntConnect $servHost $servPort] $clntPort]} \
+ emsg]
+
+ if {$n} {
+ INFO "socket open error: $emsg"
+ } else {
+ INFO "localhost:$clntPort <--> $servHost:$servPort"
+ INFO "waiting for new connection..."
+ }
+}
+##+##########################################################################
+#
+# GetSetup
+#
+# Prompts the user for client port, server host and server port
+#
+proc GetSetup {{connect 1}} {
+ global state clntPort servHost servPort ok
+ set save [list $clntPort $servHost $servPort]
+ set ok 0 ;# Assume cancelling
+
+ ;# Put in some default values
+ if {![string length $clntPort]} {set clntPort 8080}
+ if {![string length $servPort]} {set servPort 80}
+
+ if {! $state(gui)} {
+ catch {close $state(listen)}
+
+ set clntPort [Prompt "Client port" $clntPort]
+ set servHost [Prompt "Server host" $servHost]
+ set servPort [Prompt "Server port" $servPort]
+ if {$connect} DoListen
+ return
+ }
+ catch {destroy .dlg}
+
+ toplevel .dlg
+ grab set .dlg
+ wm title .dlg "Sockspy Setup"
+ wm geom .dlg +176+176
+ wm transient .dlg .
+
+ frame .dlg.top -bd 2 -relief ridge
+ pack .dlg.top -side top -pady 1m -padx .5m
+ pack [frame .dlg.top.t] -side top -pady .5m
+ pack [frame .dlg.top.b] -side bottom -pady .5m
+
+ foreach {n txt var} {1 "Client Port:" clntPort
+ 2 "Server Host:" servHost
+ 3 "Server Port:" servPort} {
+ set f .dlg.f$n
+ pack [frame $f] -side top -fill x -expand 1 -in .dlg.top
+ pack [frame $f.f] -side right -padx .5m
+ label $f.l -text $txt -anchor e
+ entry $f.e -textvariable $var
+ pack $f.e $f.l -side right
+ bind $f.e <Return> [list .dlg.okay invoke]
+ }
+
+ button .dlg.okay -text OK -command {
+ if {[string length $clntPort] && [string length $servHost] && \
+ [string length $servPort]} { set ok 1 ; destroy .dlg }
+ }
+
+ button .dlg.quit -text Cancel -command { destroy .dlg }
+ pack .dlg.okay .dlg.quit -side left -expand 1 -pady 2
+ focus .dlg.f1.e
+ .dlg.f1.e icursor end
+
+ tkwait window .dlg
+
+ if {$ok} {
+ if {$connect} DoListen
+ } else {
+ foreach {clntPort servHost servPort} $save break
+ }
+ return $ok
+}
+##+##########################################################################
+#
+# Prompt
+#
+# Non-gui way to get input from the user.
+#
+proc Prompt {prompt {default ""}} {
+ if {$default != ""} {
+ puts -nonewline "$prompt ($default): "
+ } else {
+ puts -nonewline "$prompt: "
+ }
+ flush stdout
+ set n [gets stdin line]
+
+ if {$n == 0 && $default != ""} {
+ set line $default
+ }
+ return $line
+}
+##+##########################################################################
+#
+# Shutdown
+#
+# Closes the listen port before exiting
+#
+proc Shutdown {} {
+ global state
+
+ catch {close $state(listen)}
+ exit
+}
+##+##########################################################################
+#
+# ButtonBar
+#
+# Toggles the visibility of the button bar
+#
+proc ButtonBar {} {
+ global state
+
+ if {$state(bbar)} { ;# Need to add button bar
+ pack .cmd -side top -fill x -pady 5 -in .bbar
+ } else {
+ pack forget .cmd
+ .bbar config -height 1 ;# Need this to give remove gap
+ }
+}
+
+################################################################
+################################################################
+################################################################
+
+# get args and start it up
+
+set state(gui) [info exists tk_version]
+set state(listen) ""
+
+set clntPort [lindex $argv 0]
+set servHost [lindex $argv 1]
+set servPort [lindex $argv 2]
+
+createMain
+
+if {[llength $argv] < 3} {
+ GetSetup 0
+}
+DoListen
+
+if {! $state(gui)} {
+ vwait forever ;# tclsh needs this
+}
--- /dev/null
+# uri.tcl --
+#
+# URI parsing and fetch
+#
+# Copyright (c) 2000 Zveno Pty Ltd
+# Steve Ball, http://www.zveno.com/
+# Derived from urls.tcl by Andreas Kupries
+#
+# TODO:
+# Handle www-url-encoding details
+#
+# CVS: $Id: uri.tcl,v 1.25 2004/01/25 07:29:51 andreas_kupries Exp $
+
+package require Tcl 8.2
+
+namespace eval ::uri {
+
+ namespace export split join
+ namespace export resolve isrelative
+ namespace export geturl
+ namespace export canonicalize
+ namespace export register
+
+ variable file:counter 0
+
+ # extend these variable in the coming namespaces
+ variable schemes {}
+ variable schemePattern ""
+ variable url ""
+ variable url2part
+ array set url2part {}
+
+ # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ # basic regular expressions used in URL syntax.
+
+ namespace eval basic {
+ variable loAlpha {[a-z]}
+ variable hiAlpha {[A-Z]}
+ variable digit {[0-9]}
+ variable alpha {[a-zA-Z]}
+ variable safe {[$_.+-]}
+ variable extra {[!*'(,)]}
+ # danger in next pattern, order important for []
+ variable national {[][|\}\{\^~`]}
+ variable punctuation {[<>#%"]} ;#" fake emacs hilit
+ variable reserved {[;/?:@&=]}
+ variable hex {[0-9A-Fa-f]}
+ variable alphaDigit {[A-Za-z0-9]}
+ variable alphaDigitMinus {[A-Za-z0-9-]}
+
+ # next is <national | punctuation>
+ variable unsafe {[][<>"#%\{\}|\\^~`]} ;#" emacs hilit
+ variable escape "%${hex}${hex}"
+
+ # unreserved = alpha | digit | safe | extra
+ # xchar = unreserved | reserved | escape
+
+ variable unreserved {[a-zA-Z0-9$_.+!*'(,)-]}
+ variable uChar "(${unreserved}|${escape})"
+ variable xCharN {[a-zA-Z0-9$_.+!*'(,);/?:@&=-]}
+ variable xChar "(${xCharN}|${escape})"
+ variable digits "${digit}+"
+
+ variable toplabel \
+ "(${alpha}${alphaDigitMinus}*${alphaDigit}|${alpha})"
+ variable domainlabel \
+ "(${alphaDigit}${alphaDigitMinus}*${alphaDigit}|${alphaDigit})"
+
+ variable hostname \
+ "((${domainlabel}\\.)*${toplabel})"
+ variable hostnumber \
+ "(${digits}\\.${digits}\\.${digits}\\.${digits})"
+
+ variable host "(${hostname}|${hostnumber})"
+
+ variable port $digits
+ variable hostOrPort "${host}(:${port})?"
+
+ variable usrCharN {[a-zA-Z0-9$_.+!*'(,);?&=-]}
+ variable usrChar "(${usrCharN}|${escape})"
+ variable user "${usrChar}*"
+ variable password $user
+ variable login "(${user}(:${password})?@)?${hostOrPort}"
+ } ;# basic {}
+}
+\f
+
+# ::uri::register --
+#
+# Register a scheme (and aliases) in the package. The command
+# creates a namespace below "::uri" with the same name as the
+# scheme and executes the script declaring the pattern variables
+# for this scheme in the new namespace. At last it updates the
+# uri variables keeping track of overall scheme information.
+#
+# The script has to declare at least the variable "schemepart",
+# the pattern for an url of the registered scheme after the
+# scheme declaration. Not declaring this variable is an error.
+#
+# Arguments:
+# schemeList Name of the scheme to register, plus aliases
+# script Script declaring the scheme patterns
+#
+# Results:
+# None.
+
+proc ::uri::register {schemeList script} {
+ variable schemes
+ variable schemePattern
+ variable url
+ variable url2part
+
+ # Check scheme and its aliases for existence.
+ foreach scheme $schemeList {
+ if {[lsearch -exact $schemes $scheme] >= 0} {
+ return -code error \
+ "trying to register scheme (\"$scheme\") which is already known"
+ }
+ }
+
+ # Get the main scheme
+ set scheme [lindex $schemeList 0]
+
+ if {[catch {namespace eval $scheme $script} msg]} {
+ catch {namespace delete $scheme}
+ return -code error \
+ "error while evaluating scheme script: $msg"
+ }
+
+ if {![info exists ${scheme}::schemepart]} {
+ namespace delete $scheme
+ return -code error \
+ "Variable \"schemepart\" is missing."
+ }
+
+ # Now we can extend the variables which keep track of the registered schemes.
+
+ eval lappend schemes $schemeList
+ set schemePattern "([::join $schemes |]):"
+
+ foreach s schemeList {
+ # FRINK: nocheck
+ set url2part($s) "${s}:[set ${scheme}::schemepart]"
+ # FRINK: nocheck
+ append url "(${s}:[set ${scheme}::schemepart])|"
+ }
+ set url [string trimright $url |]
+ return
+}
+
+# ::uri::split --
+#
+# Splits the given <a url> into its constituents.
+#
+# Arguments:
+# url the URL to split
+#
+# Results:
+# Tcl list containing constituents, suitable for 'array set'.
+
+proc ::uri::split {url {defaultscheme http}} {
+
+ set url [string trim $url]
+ set scheme {}
+
+ # RFC 1738: scheme = 1*[ lowalpha | digit | "+" | "-" | "." ]
+ regexp -- {^([a-z0-9+.-][a-z0-9+.-]*):} $url dummy scheme
+
+ if {$scheme == {}} {
+ set scheme $defaultscheme
+ }
+
+ # ease maintenance: dynamic dispatch, able to handle all schemes
+ # added in future!
+
+ if {[::info procs Split[string totitle $scheme]] == {}} {
+ error "unknown scheme '$scheme' in '$url'"
+ }
+
+ regsub -- "^${scheme}:" $url {} url
+
+ set parts(scheme) $scheme
+ array set parts [Split[string totitle $scheme] $url]
+
+ # should decode all encoded characters!
+
+ return [array get parts]
+}
+\f
+proc ::uri::SplitFtp {url} {
+ # @c Splits the given ftp-<a url> into its constituents.
+ # @a url: The url to split, without! scheme specification.
+ # @r List containing the constituents, suitable for 'array set'.
+
+ # general syntax:
+ # //<user>:<password>@<host>:<port>/<cwd1>/.../<cwdN>/<name>;type=<typecode>
+ #
+ # additional rules:
+ #
+ # <user>:<password> are optional, detectable by presence of @.
+ # <password> is optional too.
+ #
+ # "//" [ <user> [":" <password> ] "@"] <host> [":" <port>] "/"
+ # <cwd1> "/" ..."/" <cwdN> "/" <name> [";type=" <typecode>]
+
+ upvar \#0 [namespace current]::ftp::typepart ftptype
+
+ array set parts {user {} pwd {} host {} port {} path {} type {}}
+
+ # slash off possible type specification
+
+ if {[regexp -indices -- "${ftptype}$" $url dummy ftype]} {
+
+ set from [lindex $ftype 0]
+ set to [lindex $ftype 1]
+
+ set parts(type) [string range $url $from $to]
+
+ set from [lindex $dummy 0]
+ set url [string replace $url $from end]
+ }
+
+ # Handle user, password, host and port
+
+ if {[string match "//*" $url]} {
+ set url [string range $url 2 end]
+
+ array set parts [GetUPHP url]
+ }
+
+ set parts(path) [string trimleft $url /]
+
+ return [array get parts]
+}
+\f
+proc ::uri::JoinFtp args {
+ array set components {
+ user {} pwd {} host {} port {}
+ path {} type {}
+ }
+ array set components $args
+
+ set userPwd {}
+ if {[string length $components(user)] || [string length $components(pwd)]} {
+ set userPwd $components(user)[expr {[string length $components(pwd)] ? ":$components(pwd)" : {}}]@
+ }
+
+ set port {}
+ if {[string length $components(port)]} {
+ set port :$components(port)
+ }
+
+ set type {}
+ if {[string length $components(type)]} {
+ set type \;type=$components(type)
+ }
+
+ return ftp://${userPwd}$components(host)${port}/[string trimleft $components(path) /]$type
+}
+\f
+proc ::uri::SplitHttps {url} {
+ uri::SplitHttp $url
+}
+
+proc ::uri::SplitHttp {url} {
+ # @c Splits the given http-<a url> into its constituents.
+ # @a url: The url to split, without! scheme specification.
+ # @r List containing the constituents, suitable for 'array set'.
+
+ # general syntax:
+ # //<host>:<port>/<path>?<searchpart>
+ #
+ # where <host> and <port> are as described in Section 3.1. If :<port>
+ # is omitted, the port defaults to 80. No user name or password is
+ # allowed. <path> is an HTTP selector, and <searchpart> is a query
+ # string. The <path> is optional, as is the <searchpart> and its
+ # preceding "?". If neither <path> nor <searchpart> is present, the "/"
+ # may also be omitted.
+ #
+ # Within the <path> and <searchpart> components, "/", ";", "?" are
+ # reserved. The "/" character may be used within HTTP to designate a
+ # hierarchical structure.
+ #
+ # path == <cwd1> "/" ..."/" <cwdN> "/" <name> ["#" <fragment>]
+
+ upvar #0 [namespace current]::http::search search
+ upvar #0 [namespace current]::http::segment segment
+
+ array set parts {host {} port {} path {} query {}}
+
+ set searchPattern "\\?(${search})\$"
+ set fragmentPattern "#(${segment})\$"
+
+ # slash off possible query
+
+ if {[regexp -indices -- $searchPattern $url match query]} {
+ set from [lindex $query 0]
+ set to [lindex $query 1]
+
+ set parts(query) [string range $url $from $to]
+
+ set url [string replace $url [lindex $match 0] end]
+ }
+
+ # slash off possible fragment
+
+ if {[regexp -indices -- $fragmentPattern $url match fragment]} {
+ set from [lindex $fragment 0]
+ set to [lindex $fragment 1]
+
+ set parts(fragment) [string range $url $from $to]
+
+ set url [string replace $url [lindex $match 0] end]
+ }
+
+ if {[string match "//*" $url]} {
+ set url [string range $url 2 end]
+
+ array set parts [GetHostPort url]
+ }
+
+ set parts(path) [string trimleft $url /]
+
+ return [array get parts]
+}
+\f
+proc ::uri::JoinHttp {args} {
+ eval uri::JoinHttpInner http 80 $args
+}
+
+proc ::uri::JoinHttps {args} {
+ eval uri::JoinHttpInner https 443 $args
+}
+
+proc ::uri::JoinHttpInner {scheme defport args} {
+ array set components [list \
+ host {} port $defport path {} query {} \
+ ]
+ array set components $args
+
+ set port {}
+ if {[string length $components(port)] && $components(port) != $defport} {
+ set port :$components(port)
+ }
+
+ set query {}
+ if {[string length $components(query)]} {
+ set query ?$components(query)
+ }
+
+ regsub -- {^/} $components(path) {} components(path)
+
+ if { [info exists components(fragment)] && $components(fragment) != "" } {
+ set components(fragment) "#$components(fragment)"
+ } else {
+ set components(fragment) ""
+ }
+
+ return $scheme://$components(host)$port/$components(path)$components(fragment)$query
+}
+\f
+proc ::uri::SplitFile {url} {
+ # @c Splits the given file-<a url> into its constituents.
+ # @a url: The url to split, without! scheme specification.
+ # @r List containing the constituents, suitable for 'array set'.
+
+ upvar #0 [namespace current]::basic::hostname hostname
+ upvar #0 [namespace current]::basic::hostnumber hostnumber
+
+ if {[string match "//*" $url]} {
+ set url [string range $url 2 end]
+
+ set hostPattern "^($hostname|$hostnumber)"
+ switch -exact -- $::tcl_platform(platform) {
+ windows {
+ # Catch drive letter
+ append hostPattern :?
+ }
+ default {
+ # Proceed as usual
+ }
+ }
+
+ if {[regexp -indices -- $hostPattern $url match host]} {
+ set fh [lindex $host 0]
+ set th [lindex $host 1]
+
+ set parts(host) [string range $url $fh $th]
+
+ set matchEnd [lindex $match 1]
+ incr matchEnd
+
+ set url [string range $url $matchEnd end]
+ }
+ }
+
+ set parts(path) $url
+
+ return [array get parts]
+}
+\f
+proc ::uri::JoinFile args {
+ array set components {
+ host {} port {} path {}
+ }
+ array set components $args
+
+ switch -exact -- $::tcl_platform(platform) {
+ windows {
+ if {[string length $components(host)]} {
+ return file://$components(host):$components(path)
+ } else {
+ return file://$components(path)
+ }
+ }
+ default {
+ return file://$components(host)$components(path)
+ }
+ }
+}
+\f
+proc ::uri::SplitMailto {url} {
+ # @c Splits the given mailto-<a url> into its constituents.
+ # @a url: The url to split, without! scheme specification.
+ # @r List containing the constituents, suitable for 'array set'.
+
+ if {[string match "*@*" $url]} {
+ set url [::split $url @]
+ return [list user [lindex $url 0] host [lindex $url 1]]
+ } else {
+ return [list user $url]
+ }
+}
+\f
+proc ::uri::JoinMailto args {
+ array set components {
+ user {} host {}
+ }
+ array set components $args
+
+ return mailto:$components(user)@$components(host)
+}
+\f
+proc ::uri::SplitNews {url} {
+ if { [string first @ $url] >= 0 } {
+ return [list message-id $url]
+ } else {
+ return [list newsgroup-name $url]
+ }
+}
+\f
+proc ::uri::JoinNews args {
+ array set components {
+ message-id {} newsgroup-name {}
+ }
+ array set components $args
+ return news:$components(message-id)$components(newsgroup-name)
+}
+\f
+proc ::uri::GetUPHP {urlvar} {
+ # @c Parse user, password host and port out of the url stored in
+ # @c variable <a urlvar>.
+ # @d Side effect: The extracted information is removed from the given url.
+ # @r List containing the extracted information in a format suitable for
+ # @r 'array set'.
+ # @a urlvar: Name of the variable containing the url to parse.
+
+ upvar \#0 [namespace current]::basic::user user
+ upvar \#0 [namespace current]::basic::password password
+ upvar \#0 [namespace current]::basic::hostname hostname
+ upvar \#0 [namespace current]::basic::hostnumber hostnumber
+ upvar \#0 [namespace current]::basic::port port
+
+ upvar $urlvar url
+
+ array set parts {user {} pwd {} host {} port {}}
+
+ # syntax
+ # "//" [ <user> [":" <password> ] "@"] <host> [":" <port>] "/"
+ # "//" already cut off by caller
+
+ set upPattern "^(${user})(:(${password}))?@"
+
+ if {[regexp -indices -- $upPattern $url match theUser c d thePassword]} {
+ set fu [lindex $theUser 0]
+ set tu [lindex $theUser 1]
+
+ set fp [lindex $thePassword 0]
+ set tp [lindex $thePassword 1]
+
+ set parts(user) [string range $url $fu $tu]
+ set parts(pwd) [string range $url $fp $tp]
+
+ set matchEnd [lindex $match 1]
+ incr matchEnd
+
+ set url [string range $url $matchEnd end]
+ }
+
+ set hpPattern "^($hostname|$hostnumber)(:($port))?"
+
+ if {[regexp -indices -- $hpPattern $url match theHost c d e f g h thePort]} {
+ set fh [lindex $theHost 0]
+ set th [lindex $theHost 1]
+
+ set fp [lindex $thePort 0]
+ set tp [lindex $thePort 1]
+
+ set parts(host) [string range $url $fh $th]
+ set parts(port) [string range $url $fp $tp]
+
+ set matchEnd [lindex $match 1]
+ incr matchEnd
+
+ set url [string range $url $matchEnd end]
+ }
+
+ return [array get parts]
+}
+\f
+proc ::uri::GetHostPort {urlvar} {
+ # @c Parse host and port out of the url stored in variable <a urlvar>.
+ # @d Side effect: The extracted information is removed from the given url.
+ # @r List containing the extracted information in a format suitable for
+ # @r 'array set'.
+ # @a urlvar: Name of the variable containing the url to parse.
+
+ upvar #0 [namespace current]::basic::hostname hostname
+ upvar #0 [namespace current]::basic::hostnumber hostnumber
+ upvar #0 [namespace current]::basic::port port
+
+ upvar $urlvar url
+
+ set pattern "^(${hostname}|${hostnumber})(:(${port}))?"
+
+ if {[regexp -indices -- $pattern $url match host c d e f g h thePort]} {
+ set fromHost [lindex $host 0]
+ set toHost [lindex $host 1]
+
+ set fromPort [lindex $thePort 0]
+ set toPort [lindex $thePort 1]
+
+ set parts(host) [string range $url $fromHost $toHost]
+ set parts(port) [string range $url $fromPort $toPort]
+
+ set matchEnd [lindex $match 1]
+ incr matchEnd
+
+ set url [string range $url $matchEnd end]
+ }
+
+ return [array get parts]
+}
+\f
+# ::uri::resolve --
+#
+# Resolve an arbitrary URL, given a base URL
+#
+# Arguments:
+# base base URL (absolute)
+# url arbitrary URL
+#
+# Results:
+# Returns a URL
+
+proc ::uri::resolve {base url} {
+ if {[string length $url]} {
+ if {[isrelative $url]} {
+
+ array set baseparts [split $base]
+
+ switch -- $baseparts(scheme) {
+ http -
+ https -
+ ftp -
+ file {
+ array set relparts [split $url]
+ if { [string match /* $url] } {
+ catch { set baseparts(path) $relparts(path) }
+ } elseif { [string match */ $baseparts(path)] } {
+ set baseparts(path) "$baseparts(path)$relparts(path)"
+ } else {
+ if { [string length $relparts(path)] > 0 } {
+ set path [lreplace [::split $baseparts(path) /] end end]
+ set baseparts(path) "[::join $path /]/$relparts(path)"
+ }
+ }
+ catch { set baseparts(query) $relparts(query) }
+ catch { set baseparts(fragment) $relparts(fragment) }
+ return [eval join [array get baseparts]]
+ }
+ default {
+ return -code error "unable to resolve relative URL \"$url\""
+ }
+ }
+
+ } else {
+ return $url
+ }
+ } else {
+ return $base
+ }
+}
+\f
+# ::uri::isrelative --
+#
+# Determines whether a URL is absolute or relative
+#
+# Arguments:
+# url URL to check
+#
+# Results:
+# Returns 1 if the URL is relative, 0 otherwise
+
+proc ::uri::isrelative url {
+ return [expr {![regexp -- {^[a-z0-9+-.][a-z0-9+-.]*:} $url]}]
+}
+\f
+# ::uri::geturl --
+#
+# Fetch the data from an arbitrary URL.
+#
+# This package provides a handler for the file:
+# scheme, since this conflicts with the file command.
+#
+# Arguments:
+# url address of data resource
+# args configuration options
+#
+# Results:
+# Depends on scheme
+
+proc ::uri::geturl {url args} {
+ array set urlparts [split $url]
+
+ switch -- $urlparts(scheme) {
+ file {
+ return [eval file_geturl [list $url] $args]
+ }
+ default {
+ # 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]
+ }
+ }
+}
+\f
+# ::uri::file_geturl --
+#
+# geturl implementation for file: scheme
+#
+# TODO:
+# This is an initial, basic implementation.
+# Eventually want to support all options for geturl.
+#
+# Arguments:
+# url URL to fetch
+# args configuration options
+#
+# Results:
+# Returns data from file
+
+proc ::uri::file_geturl {url args} {
+ variable file:counter
+
+ set var [namespace current]::file[incr file:counter]
+ upvar #0 $var state
+ array set state {data {}}
+
+ array set parts [split $url]
+
+ set ch [open $parts(path)]
+ # Could determine text/binary from file extension,
+ # except on Macintosh
+ # fconfigure $ch -translation binary
+ set state(data) [read $ch]
+ close $ch
+
+ return $var
+}
+\f
+# ::uri::join --
+#
+# Format a URL
+#
+# Arguments:
+# args components, key-value format
+#
+# Results:
+# A URL
+
+proc ::uri::join args {
+ array set components $args
+
+ return [eval [list Join[string totitle $components(scheme)]] $args]
+}
+\f
+# ::uri::canonicalize --
+#
+# Canonicalize a URL
+#
+# Acknowledgements:
+# Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# Arguments:
+# uri URI (which contains a path component)
+#
+# Results:
+# The canonical form of the URI
+
+proc ::uri::canonicalize uri {
+
+ # Make uri canonical with respect to dots (path changing commands)
+ #
+ # Remove single dots (.) => pwd not changing
+ # Remove double dots (..) => gobble previous segment of path
+ #
+ # Fixes for this command:
+ #
+ # * Ignore any url which cannot be split into components by this
+ # module. Just assume that such urls do not have a path to
+ # canonicalize.
+ #
+ # * Ignore any url which could be split into components, but does
+ # not have a path component.
+ #
+ # In the text above 'ignore' means
+ # 'return the url unchanged to the caller'.
+
+ if {[catch {array set u [uri::split $uri]}]} {
+ return $uri
+ }
+ if {![info exists u(path)]} {
+ return $uri
+ }
+
+ set uri $u(path)
+
+ # Remove leading "./" "../" "/.." (and "/../")
+ regsub -all -- {^(\./)+} $uri {} uri
+ regsub -all -- {^/(\.\./)+} $uri {/} uri
+ regsub -all -- {^(\.\./)+} $uri {} uri
+
+ # Remove inner /./ and /../
+ while {[regsub -all -- {/\./} $uri {/} uri]} {}
+ while {[regsub -all -- {/[^/]+/\.\./} $uri {/} uri]} {}
+ while {[regsub -all -- {^[^/]+/\.\./} $uri {} uri]} {}
+ # Munge trailing /..
+ while {[regsub -all -- {/[^/]+/\.\.} $uri {/} uri]} {}
+ if { $uri == ".." } { set uri "/" }
+
+ set u(path) $uri
+ set uri [eval uri::join [array get u]]
+
+ return $uri
+}
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+# regular expressions covering various url schemes
+
+# Currently known URL schemes:
+#
+# (RFC 1738)
+# ------------------------------------------------
+# scheme basic syntax of scheme specific part
+# ------------------------------------------------
+# ftp //<user>:<password>@<host>:<port>/<cwd1>/.../<cwdN>/<name>;type=<typecode>
+#
+# http //<host>:<port>/<path>?<searchpart>
+#
+# gopher //<host>:<port>/<gophertype><selector>
+# <gophertype><selector>%09<search>
+# <gophertype><selector>%09<search>%09<gopher+_string>
+#
+# mailto <rfc822-addr-spec>
+# news <newsgroup-name>
+# <message-id>
+# nntp //<host>:<port>/<newsgroup-name>/<article-number>
+# telnet //<user>:<password>@<host>:<port>/
+# wais //<host>:<port>/<database>
+# //<host>:<port>/<database>?<search>
+# //<host>:<port>/<database>/<wtype>/<wpath>
+# file //<host>/<path>
+# prospero //<host>:<port>/<hsoname>;<field>=<value>
+# ------------------------------------------------
+#
+# (RFC 2111)
+# ------------------------------------------------
+# scheme basic syntax of scheme specific part
+# ------------------------------------------------
+# mid message-id
+# message-id/content-id
+# cid content-id
+# ------------------------------------------------
+
+# FTP
+uri::register ftp {
+ variable escape [set [namespace parent [namespace current]]::basic::escape]
+ variable login [set [namespace parent [namespace current]]::basic::login]
+
+ variable charN {[a-zA-Z0-9$_.+!*'(,)?:@&=-]}
+ variable char "(${charN}|${escape})"
+ variable segment "${char}*"
+ variable path "${segment}(/${segment})*"
+
+ variable type {[AaDdIi]}
+ variable typepart ";type=(${type})"
+ variable schemepart \
+ "//${login}(/${path}(${typepart})?)?"
+
+ variable url "ftp:${schemepart}"
+}
+
+# FILE
+uri::register file {
+ variable host [set [namespace parent [namespace current]]::basic::host]
+ variable path [set [namespace parent [namespace current]]::ftp::path]
+
+ variable schemepart "//(${host}|localhost)?/${path}"
+ variable url "file:${schemepart}"
+}
+
+# HTTP
+uri::register http {
+ variable escape \
+ [set [namespace parent [namespace current]]::basic::escape]
+ variable hostOrPort \
+ [set [namespace parent [namespace current]]::basic::hostOrPort]
+
+ variable charN {[a-zA-Z0-9$_.+!*'(,);:@&=-]}
+ variable char "($charN|${escape})"
+ variable segment "${char}*"
+
+ variable path "${segment}(/${segment})*"
+ variable search $segment
+ variable schemepart \
+ "//${hostOrPort}(/${path}(\\?${search})?)?"
+
+ variable url "http:${schemepart}"
+}
+
+# GOPHER
+uri::register gopher {
+ variable xChar \
+ [set [namespace parent [namespace current]]::basic::xChar]
+ variable hostOrPort \
+ [set [namespace parent [namespace current]]::basic::hostOrPort]
+ variable search \
+ [set [namespace parent [namespace current]]::http::search]
+
+ variable type $xChar
+ variable selector "$xChar*"
+ variable string $selector
+ variable schemepart \
+ "//${hostOrPort}(/(${type}(${selector}(%09${search}(%09${string})?)?)?)?)?"
+ variable url "gopher:${schemepart}"
+}
+
+# MAILTO
+uri::register mailto {
+ variable xChar [set [namespace parent [namespace current]]::basic::xChar]
+ variable host [set [namespace parent [namespace current]]::basic::host]
+
+ variable schemepart "$xChar+(@${host})?"
+ variable url "mailto:${schemepart}"
+}
+
+# NEWS
+uri::register news {
+ variable escape [set [namespace parent [namespace current]]::basic::escape]
+ variable alpha [set [namespace parent [namespace current]]::basic::alpha]
+ variable host [set [namespace parent [namespace current]]::basic::host]
+
+ variable aCharN {[a-zA-Z0-9$_.+!*'(,);/?:&=-]}
+ variable aChar "($aCharN|${escape})"
+ variable gChar {[a-zA-Z0-9$_.+-]}
+ variable newsgroup-name "${alpha}${gChar}*"
+ variable message-id "${aChar}+@${host}"
+ variable schemepart "\\*|${newsgroup-name}|${message-id}"
+ variable url "news:${schemepart}"
+}
+
+# WAIS
+uri::register wais {
+ variable uChar \
+ [set [namespace parent [namespace current]]::basic::xChar]
+ variable hostOrPort \
+ [set [namespace parent [namespace current]]::basic::hostOrPort]
+ variable search \
+ [set [namespace parent [namespace current]]::http::search]
+
+ variable db "${uChar}*"
+ variable type "${uChar}*"
+ variable path "${uChar}*"
+
+ variable database "//${hostOrPort}/${db}"
+ variable index "//${hostOrPort}/${db}\\?${search}"
+ variable doc "//${hostOrPort}/${db}/${type}/${path}"
+
+ #variable schemepart "${doc}|${index}|${database}"
+
+ variable schemepart \
+ "//${hostOrPort}/${db}((\\?${search})|(/${type}/${path}))?"
+
+ variable url "wais:${schemepart}"
+}
+
+# PROSPERO
+uri::register prospero {
+ variable escape \
+ [set [namespace parent [namespace current]]::basic::escape]
+ variable hostOrPort \
+ [set [namespace parent [namespace current]]::basic::hostOrPort]
+ variable path \
+ [set [namespace parent [namespace current]]::ftp::path]
+
+ variable charN {[a-zA-Z0-9$_.+!*'(,)?:@&-]}
+ variable char "(${charN}|$escape)"
+
+ variable fieldname "${char}*"
+ variable fieldvalue "${char}*"
+ variable fieldspec ";${fieldname}=${fieldvalue}"
+
+ variable schemepart "//${hostOrPort}/${path}(${fieldspec})*"
+ variable url "prospero:$schemepart"
+}
+
+package provide uri 1.1.3
projects / sockspy / commitdiff