From f69ad60784350c3fbb8375514b7f41b94eb81ba3 Mon Sep 17 00:00:00 2001 From: Pat Thoyts Date: Thu, 26 Nov 2009 23:36:18 +0000 Subject: [PATCH 1/1] sockspy version 2.0 Imported the earliers 2.0 version from cvs into a starkit vfs tree. Signed-off-by: Pat Thoyts --- bin/sockspy.tcl | 511 ++++++++++++++++++++++ lib/style/as.tcl | 129 ++++++ lib/style/lobster.tcl | 64 +++ lib/style/pkgIndex.tcl | 13 + lib/style/style.tcl | 31 ++ lib/uri/pkgIndex.tcl | 6 + lib/uri/uri.tcl | 932 +++++++++++++++++++++++++++++++++++++++++ lib/uri/urn-scheme.tcl | 109 +++++ main.tcl | 4 + 9 files changed, 1799 insertions(+) create mode 100644 bin/sockspy.tcl create mode 100644 lib/style/as.tcl create mode 100644 lib/style/lobster.tcl create mode 100644 lib/style/pkgIndex.tcl create mode 100644 lib/style/style.tcl create mode 100644 lib/uri/pkgIndex.tcl create mode 100644 lib/uri/uri.tcl create mode 100644 lib/uri/urn-scheme.tcl create mode 100644 main.tcl diff --git a/bin/sockspy.tcl b/bin/sockspy.tcl new file mode 100644 index 0000000..cf99430 --- /dev/null +++ b/bin/sockspy.tcl @@ -0,0 +1,511 @@ +#!/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 [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 +} diff --git a/lib/style/as.tcl b/lib/style/as.tcl new file mode 100644 index 0000000..e537aa7 --- /dev/null +++ b/lib/style/as.tcl @@ -0,0 +1,129 @@ +# as_style.tcl -- +# +# This file implements package as::style. +# +# Copyright (c) 2003 ActiveState Corporation, a division of Sophos +# + +package provide style::as 1.1 + +namespace eval style::as { + if { [tk windowingsystem] == "x11" } { + set highlightbg "#316AC5" ; # SystemHighlight + set highlightfg "white" ; # SystemHighlightText + set bg "white" ; # SystemWindow + set fg "black" ; # SystemWindowText + + ## Fonts + ## + set size -12 + set family Helvetica + set fsize -12 + set ffamily Courier + + + font create ASfont -size $size -family $family + font create ASfontBold -size $size -family $family -weight bold + font create ASfontFixed -size $fsize -family $ffamily + for {set i -2} {$i <= 4} {incr i} { + set isize [expr {$size + ($i * (($size > 0) ? 1 : -1))}] + set ifsize [expr {$fsize + ($i * (($fsize > 0) ? 1 : -1))}] + font create ASfont$i -size $isize -family $family + font create ASfontBold$i -size $isize -family $family -weight bold + font create ASfontFixed$i -size $ifsize -family $ffamily + } + + option add *Text.font ASfontFixed widgetDefault + option add *Button.font ASfont widgetDefault + option add *Canvas.font ASfont widgetDefault + option add *Checkbutton.font ASfont widgetDefault + option add *Entry.font ASfont widgetDefault + option add *Label.font ASfont widgetDefault + option add *Labelframe.font ASfont widgetDefault + option add *Listbox.font ASfont widgetDefault + option add *Menu.font ASfont widgetDefault + option add *Menubutton.font ASfont widgetDefault + option add *Message.font ASfont widgetDefault + option add *Radiobutton.font ASfont widgetDefault + option add *Spinbox.font ASfont widgetDefault + + option add *Table.font ASfont widgetDefault + option add *TreeCtrl*font ASfont widgetDefault + ## Misc + ## + option add *ScrolledWindow.ipad 0 widgetDefault + + ## Listbox + ## + option add *Listbox.background $bg widgetDefault + option add *Listbox.foreground $fg widgetDefault + option add *Listbox.selectBorderWidth 0 widgetDefault + option add *Listbox.selectForeground $highlightfg widgetDefault + option add *Listbox.selectBackground $highlightbg widgetDefault + option add *Listbox.activeStyle dotbox widgetDefault + + ## Button + ## + option add *Button.padX 1 widgetDefault + option add *Button.padY 2 widgetDefault + + ## Entry + ## + option add *Entry.background $bg widgetDefault + option add *Entry.foreground $fg widgetDefault + option add *Entry.selectBorderWidth 0 widgetDefault + option add *Entry.selectForeground $highlightfg widgetDefault + option add *Entry.selectBackground $highlightbg widgetDefault + + ## Spinbox + ## + option add *Spinbox.background $bg widgetDefault + option add *Spinbox.foreground $fg widgetDefault + option add *Spinbox.selectBorderWidth 0 widgetDefault + option add *Spinbox.selectForeground $highlightfg widgetDefault + option add *Spinbox.selectBackground $highlightbg widgetDefault + + ## Text + ## + option add *Text.background $bg widgetDefault + option add *Text.foreground $fg widgetDefault + option add *Text.selectBorderWidth 0 widgetDefault + option add *Text.selectForeground $highlightfg widgetDefault + option add *Text.selectBackground $highlightbg widgetDefault + + ## Menu + ## + option add *Menu.activeBackground $highlightbg widgetDefault + option add *Menu.activeForeground $highlightfg widgetDefault + option add *Menu.activeBorderWidth 0 widgetDefault + option add *Menu.highlightThickness 0 widgetDefault + option add *Menu.borderWidth 1 widgetDefault + + ## Menubutton + ## + option add *Menubutton.activeBackground $highlightbg widgetDefault + option add *Menubutton.activeForeground $highlightfg widgetDefault + option add *Menubutton.activeBorderWidth 0 widgetDefault + option add *Menubutton.highlightThickness 0 widgetDefault + option add *Menubutton.borderWidth 0 widgetDefault + option add *Menubutton*padX 4 widgetDefault + option add *Menubutton*padY 2 widgetDefault + + ## Scrollbar + ## + option add *Scrollbar.width 12 widgetDefault + option add *Scrollbar.troughColor #bdb6ad widgetDefault + option add *Scrollbar.borderWidth 1 widgetDefault + option add *Scrollbar.highlightThickness 0 widgetDefault + + ## PanedWindow + + ## + option add *Panedwindow.borderWidth 0 widgetDefault + option add *Panedwindow.sashwidth 3 widgetDefault + option add *Panedwindow.showhandle 0 widgetDefault + option add *Panedwindow.sashpad 0 widgetDefault + option add *Panedwindow.sashrelief flat widgetDefault + option add *Panedwindow.relief flat widgetDefault + } +}; # end of namespace style::as diff --git a/lib/style/lobster.tcl b/lib/style/lobster.tcl new file mode 100644 index 0000000..aaa1490 --- /dev/null +++ b/lib/style/lobster.tcl @@ -0,0 +1,64 @@ +# lobster.tcl -- + +# The code formerly known as "gtklook" on the Tcl'ers +# wiki. Most of this code was originally written by Jeremy Collins. + +# $Id: lobster.tcl,v 1.3 2004/03/25 16:22:08 davidw Exp $ + +package provide style::lobster 0.1 + +namespace eval styles::lobster { + if { [tk windowingsystem] == "x11" } { + set size -12 + set family Helvetica + font create LobsterFont -size $size -family $family + + option add *borderWidth 1 widgetDefault + option add *activeBorderWidth 1 widgetDefault + option add *selectBorderWidth 1 widgetDefault + option add *font LobsterFont widgetDefault + + option add *padX 2 widgetDefault + option add *padY 4 widgetDefault + + option add *Listbox.background white widgetDefault + option add *Listbox.selectBorderWidth 0 widgetDefault + option add *Listbox.selectForeground white widgetDefault + option add *Listbox.selectBackground #4a6984 widgetDefault + + option add *Entry.background white widgetDefault + option add *Entry.foreground black widgetDefault + option add *Entry.selectBorderWidth 0 widgetDefault + option add *Entry.selectForeground white widgetDefault + option add *Entry.selectBackground #4a6984 widgetDefault + + option add *Text.background white widgetDefault + option add *Text.selectBorderWidth 0 widgetDefault + option add *Text.selectForeground white widgetDefault + option add *Text.selectBackground #4a6984 widgetDefault + + option add *Menu.activeBackground #4a6984 widgetDefault + option add *Menu.activeForeground white widgetDefault + option add *Menu.activeBorderWidth 0 widgetDefault + option add *Menu.highlightThickness 0 widgetDefault + option add *Menu.borderWidth 2 widgetDefault + + option add *Menubutton.activeBackground #4a6984 widgetDefault + option add *Menubutton.activeForeground white widgetDefault + option add *Menubutton.activeBorderWidth 0 widgetDefault + option add *Menubutton.highlightThickness 0 widgetDefault + option add *Menubutton.borderWidth 0 widgetDefault + + option add *Labelframe.borderWidth 2 widgetDefault + option add *Frame.borderWidth 2 widgetDefault + option add *Labelframe.padY 8 widgetDefault + option add *Labelframe.padX 12 widgetDefault + + option add *highlightThickness 0 widgetDefault + option add *troughColor #c3c3c3 widgetDefault + + option add *Scrollbar.width 12 widgetDefault + option add *Scrollbar.borderWidth 1 widgetDefault + option add *Scrollbar.highlightThickness 0 widgetDefault + } +} \ No newline at end of file diff --git a/lib/style/pkgIndex.tcl b/lib/style/pkgIndex.tcl new file mode 100644 index 0000000..0f1c979 --- /dev/null +++ b/lib/style/pkgIndex.tcl @@ -0,0 +1,13 @@ +# Tcl package index file, version 1.1 +# This file is generated by the "pkg_mkIndex" command +# and sourced either when an application starts up or +# by a "package unknown" script. It invokes the +# "package ifneeded" command to set up package-related +# information so that packages will be loaded automatically +# in response to "package require" commands. When this +# script is sourced, the variable $dir must contain the +# full path name of this file's directory. + +package ifneeded style 0.1 [list source [file join $dir style.tcl]] +package ifneeded style::as 1.1 [list source [file join $dir as.tcl]] +package ifneeded style::lobster 0.1 [list source [file join $dir lobster.tcl]] diff --git a/lib/style/style.tcl b/lib/style/style.tcl new file mode 100644 index 0000000..3d7b3bd --- /dev/null +++ b/lib/style/style.tcl @@ -0,0 +1,31 @@ +# style.tcl -- Styles for Tk. + +# $Id: style.tcl,v 1.2 2004/03/18 08:56:47 davidw Exp $ + +# Copyright 2004 David N. Welton + +package provide style 0.1 + +namespace eval style { + # Available styles + variable available [list lobster as] +} + +# style::names -- +# +# Return the names of all available styles. + +proc style::names {} { + variable available + return $available +} + +# style::use -- +# +# Untill I see a better way of doing it, this is just a wrapper +# for package require. The problem is that 'use'ing different +# styles won't undo the changes made by previous styles. + +proc style::use {newstyle} { + package require style::${newstyle} +} \ No newline at end of file diff --git a/lib/uri/pkgIndex.tcl b/lib/uri/pkgIndex.tcl new file mode 100644 index 0000000..6e39e96 --- /dev/null +++ b/lib/uri/pkgIndex.tcl @@ -0,0 +1,6 @@ +if {![package vsatisfies [package provide Tcl] 8.2]} { + # FRINK: nocheck + return +} +package ifneeded uri 1.1.3 [list source [file join $dir uri.tcl]] +package ifneeded uri::urn 1.0.1 [list source [file join $dir urn-scheme.tcl]] diff --git a/lib/uri/uri.tcl b/lib/uri/uri.tcl new file mode 100644 index 0000000..40cc649 --- /dev/null +++ b/lib/uri/uri.tcl @@ -0,0 +1,932 @@ +# 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 + 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 {} +} + + +# ::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 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] +} + +proc ::uri::SplitFtp {url} { + # @c Splits the given ftp- into its constituents. + # @a url: The url to split, without! scheme specification. + # @r List containing the constituents, suitable for 'array set'. + + # general syntax: + # //:@://...//;type= + # + # additional rules: + # + # : are optional, detectable by presence of @. + # is optional too. + # + # "//" [ [":" ] "@"] [":" ] "/" + # "/" ..."/" "/" [";type=" ] + + 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] +} + +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 +} + +proc ::uri::SplitHttps {url} { + uri::SplitHttp $url +} + +proc ::uri::SplitHttp {url} { + # @c Splits the given http- into its constituents. + # @a url: The url to split, without! scheme specification. + # @r List containing the constituents, suitable for 'array set'. + + # general syntax: + # //:/? + # + # where and are as described in Section 3.1. If : + # is omitted, the port defaults to 80. No user name or password is + # allowed. is an HTTP selector, and is a query + # string. The is optional, as is the and its + # preceding "?". If neither nor is present, the "/" + # may also be omitted. + # + # Within the and components, "/", ";", "?" are + # reserved. The "/" character may be used within HTTP to designate a + # hierarchical structure. + # + # path == "/" ..."/" "/" ["#" ] + + 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] +} + +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 +} + +proc ::uri::SplitFile {url} { + # @c Splits the given file- 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] +} + +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) + } + } +} + +proc ::uri::SplitMailto {url} { + # @c Splits the given mailto- 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] + } +} + +proc ::uri::JoinMailto args { + array set components { + user {} host {} + } + array set components $args + + return mailto:$components(user)@$components(host) +} + +proc ::uri::SplitNews {url} { + if { [string first @ $url] >= 0 } { + return [list message-id $url] + } else { + return [list newsgroup-name $url] + } +} + +proc ::uri::JoinNews args { + array set components { + message-id {} newsgroup-name {} + } + array set components $args + return news:$components(message-id)$components(newsgroup-name) +} + +proc ::uri::GetUPHP {urlvar} { + # @c Parse user, password host and port out of the url stored in + # @c variable . + # @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 + # "//" [ [":" ] "@"] [":" ] "/" + # "//" 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] +} + +proc ::uri::GetHostPort {urlvar} { + # @c Parse host and port out of the url stored in variable . + # @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] +} + +# ::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 + } +} + +# ::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]}] +} + +# ::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] + } + } +} + +# ::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 +} + +# ::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] +} + +# ::uri::canonicalize -- +# +# Canonicalize a URL +# +# Acknowledgements: +# Andreas Kupries +# +# 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 //:@://...//;type= +# +# http //:/? +# +# gopher //:/ +# %09 +# %09%09 +# +# mailto +# news +# +# nntp //:// +# telnet //:@:/ +# wais //:/ +# //:/? +# //:/// +# file /// +# prospero //:/;= +# ------------------------------------------------ +# +# (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 diff --git a/lib/uri/urn-scheme.tcl b/lib/uri/urn-scheme.tcl new file mode 100644 index 0000000..be7f780 --- /dev/null +++ b/lib/uri/urn-scheme.tcl @@ -0,0 +1,109 @@ +# urn-scheme.tcl - Copyright (C) 2001 Pat Thoyts +# +# extend the uri package to deal with URN (RFC 2141) +# see http://www.normos.org/ietf/rfc/rfc2141.txt +# +# Released under the tcllib license. +# +# $Id: urn-scheme.tcl,v 1.7 2004/01/15 06:36:14 andreas_kupries Exp $ +# ------------------------------------------------------------------------- + +package provide uri::urn 1.0.1 +package require uri 1.1.2 + +namespace eval ::uri {} +namespace eval ::uri::urn {} + +::uri::register {urn URN} { + variable NIDpart {[a-zA-Z0-9][a-zA-Z0-9-]{0,31}} + variable esc {%[0-9a-fA-F]{2}} + variable trans {a-zA-Z0-9$_.+!*'(,):=@;-} + variable NSSpart "($esc|\[$trans\])+" + variable URNpart "($NIDpart):($NSSpart)" + variable schemepart $URNpart + variable url "urn:$NIDpart:$NSSpart" +} + +# ------------------------------------------------------------------------- + +# Description: +# Called by uri::split with a url to split into its parts. +# +proc ::uri::SplitUrn {uri} { + #@c Split the given uri into then URN component parts + #@a uri: the URI to split without it's scheme part. + #@r List of the component parts suitable for 'array set' + + upvar \#0 [namespace current]::urn::URNpart pattern + array set parts {nid {} nss {}} + if {[regexp -- ^$pattern $uri -> parts(nid) parts(nss)]} { + return [array get parts] + } else { + error "invalid urn syntax: \"$uri\" could not be parsed" + } +} + + +# ------------------------------------------------------------------------- + +proc ::uri::JoinUrn args { + #@c Join the parts of a URN scheme URI + #@a list of nid value nss value + #@r a valid string representation for your URI + variable urn::NIDpart + + array set parts [list nid {} nss {}] + array set parts $args + if {! [regexp -- ^$NIDpart$ $parts(nid)]} { + error "invalid urn: nid is invalid" + } + set url "urn:$parts(nid):[urn::quote $parts(nss)]" + return $url +} + +# ------------------------------------------------------------------------- + +# Quote the disallowed characters according to the RFC for URN scheme. +# ref: RFC2141 sec2.2 +proc ::uri::urn::quote {url} { + variable trans + + set ndx 0 + set result "" + while {[regexp -indices -- "\[^$trans\]" $url r]} { + set ndx [lindex $r 0] + scan [string index $url $ndx] %c chr + set rep %[format %.2X $chr] + if {[string match $rep %00]} { + error "invalid character: character $chr is not allowed" + } + + incr ndx -1 + append result [string range $url 0 $ndx] $rep + incr ndx 2 + set url [string range $url $ndx end] + } + append result $url + return $result +} + +# ------------------------------------------------------------------------- + +# Perform the reverse of urn::quote. +proc ::uri::urn::unquote {url} { + set ndx 0 + while {[regexp -start $ndx -indices {%([0-9a-zA-Z]{2})} $url r]} { + set first [lindex $r 0] + set last [lindex $r 1] + set str [string replace [string range $url $first $last] 0 0 0x] + set c [format %c $str] + set url [string replace $url $first $last $c] + set ndx [expr {$last + 1}] + } + return $url +} + +# ------------------------------------------------------------------------- +# Local Variables: +# indent-tabs-mode: nil +# End: diff --git a/main.tcl b/main.tcl new file mode 100644 index 0000000..63c7ad3 --- /dev/null +++ b/main.tcl @@ -0,0 +1,4 @@ +package require starkit +if {[starkit::startup] ne "sourced"} { + source [file join $starkit::topdir bin sockspy.tcl] +} -- 2.23.0