proc init {} {
    variable map
    variable alphanumeric a-zA-Z0-9
    for {set i 0} {$i <= 256} {incr i} { 
        set c [format %c $i]
        if {![string match \[$alphanumeric\] $c]} {
            set map($c) %[format %.2x $i]
        }
    }
    # These are handled specially
    array set map { " " + \n %0d%0a }
}
init

proc url-encode {string} {
    variable map
    variable alphanumeric

    # The spec says: "non-alphanumeric characters are replaced by '%HH'"
    # 1 leave alphanumerics characters alone
    # 2 Convert every other character to an array lookup
    # 3 Escape constructs that are "special" to the tcl parser
    # 4 "subst" the result, doing all the array substitutions

    regsub -all \[^$alphanumeric\] $string {$map(&)} string
    # This quotes cases like $map([) or $map($) => $map(\[) ...
    regsub -all {[][{})\\]\)} $string {\\&} string
    return [subst -nocommand $string]
}

proc url-decode str {
    # rewrite "+" back to space
    # protect \ from quoting another '\'
    set str [string map [list + { } "\\" "\\\\"] $str]

    # prepare to process all %-escapes
    regsub -all -- {%([A-Fa-f0-9][A-Fa-f0-9])} $str {\\u00\1} str

    # process \u unicode mapped chars
    return [subst -novar -nocommand $str]
}

Source code here...

proc utf8 {hex} {
    set hex [string map {% {}} $hex]
    encoding convertfrom utf-8 [binary decode hex $hex]
}

proc url-decode str {
    # rewrite "+" back to space
    # protect \ from quoting another '\'
    set str [string map [list + { } "\\" "\\\\"] $str]

    # Replace UTF-8 sequences with calls to the utf8 decode proc...
    regsub -all {(%[0-9A-Fa-f0-9]{2})+} $str {[utf8 \0]} str
    
    return [subst -novar -noback $str]
}

namespace eval url {
        variable map
        variable alphanumeric a-zA-Z0-9._~-
        namespace export encode decode
        namespace ensemble create
}
proc url::init {} {
        variable map
        variable alphanumeric a-zA-Z0-9._~-

        for {set i 0} {$i <= 256} {incr i} { 
                set c [format %c $i]
                if {![string match \[$alphanumeric\] $c]} {
                        set map($c) %[format %.2x $i]
                }
        }
        # These are handled specially
        array set map { " " + \n %0d%0a }
}
url::init
proc url::encode {str} {
        variable map
        variable alphanumeric

        # The spec says: "non-alphanumeric characters are replaced by '%HH'"
        # 1 leave alphanumerics characters alone
        # 2 Convert every other character to an array lookup
        # 3 Escape constructs that are "special" to the tcl parser
        # 4 "subst" the result, doing all the array substitutions

        regsub -all \[^$alphanumeric\] $str {$map(&)} str
        # This quotes cases like $map([) or $map($) => $map(\[) ...
        regsub -all {[][{})\\]\)} $str {\\&} str
        return [subst -nocommand $str]
}
proc url::decode {str} {
        # rewrite "+" back to space
        # protect \ from quoting another '\'
        set str [string map [list + { } "\\" "\\\\"] $str]

        # prepare to process all %-escapes
        regsub -all -- {%([A-Fa-f0-9][A-Fa-f0-9])} $str {\\u00\1} str

        # process \u unicode mapped chars
        return [subst -novar -nocommand $str]
}

proc ue_init {} {
   lappend d + { }
   for {set i 0} {$i < 256} {incr i} {
      set c [format %c $i]
      set x %[format %02x $i]
      if {![string match {[a-zA-Z0-9]} $c]} {
         lappend e $c $x
         lappend d $x $c
      }
   }
   set ::ue_map $e
   set ::ud_map $d
}
ue_init
proc ue {s} { string map $::ue_map $s }
proc ud {s} { string map $::ud_map $s }

puts [ue "wiki.tcl.tk/is fun!"]
puts [ud [ue "wiki.tcl.tk/is fun!"]]
puts [ue "a space and a \n new line :)"]
puts [ud [ue "a space and a \n new line :)"]]
puts [ud "1+1=2"]

proc expandPercent {data} {
    set pos 0
    while { -1 != [set pos [string first "%" $data $pos]]} {
        set hexNumber "0x[string range $data $pos+1 $pos+2]"
        if { 4 != [string length $hexNumber] || ! [string is integer $hexNumber] } {
            # No two hex character - eventual error treatment here
            # at the moment just leave the percent character
        } else {
            set data [string range $data 0 $pos-1][format %c $hexNumber][string range $data $pos+3 end]
        }
        incr pos
    }
    return $data
}

Ciencia Al Poder

http://example.org/path/sctipt.php?name1=value1&name2=value2

proc UrlEncode {str} {
    # The following line is needed for some unicode characters. If you get double-encoded unicode characters remove it
    set str [encoding convertto utf-8 $str]
    set szRet ""
    # Characters that will be encoded -- everything except those
    # Note that we use "+" at the end to match a range of characters if there are several that need
    # encoding next to each other, instead of going one by one. This should make the script faster ;)
    set arIdxToEncode [regexp -inline -indices -all -- {[^a-zA-Z0-9\-_.: /]+} $str]
    if {[llength $arIdxToEncode]} {
        # Next character that needs to be appended to the resutling string
        set nCurCar 0
        # $arIdxToEncode contains a list of characters that need encoding
        foreach arIdxPairs $arIdxToEncode {
            # First element: start character
            set n [lindex $arIdxPairs 0]
            set nLastCar [lindex $arIdxPairs 1]
            # Append previous text that doesn't need to be encoded
            if {$nCurCar < $n} {
                append szRet [string range $str $nCurCar [expr {$n - 1}]]
            }
            # Encode text matched
            while {$n <= $nLastCar} {
                set nCode [scan [string index $str $n] "%c"]
                #append szRet [format "%x" $nCode]
                set szHexStream [string toupper [format "%x" $nCode]]
                # We need a string of even characters. Prepend 0 if odd
                if {[expr {[string length $szHexStream] % 2}]} {
                    set szHexStream "0$szHexStream"
                }
                # Insert % every 2 characters
                for {set nStreamIdx 0} {$nStreamIdx < [string length $szHexStream]} {set nStreamIdx [expr {$nStreamIdx + 2}]} {
                    append szRet "%" [string range $szHexStream $nStreamIdx [expr {$nStreamIdx + 1}]]
                }
                incr n
                set nCurCar $n
            }
        }
        # Append the text after the last match that doesn't need to be encoded
        if {$nCurCar < [string length $str]} {
            append szRet [string range $str $nCurCar [expr {[string length $str] - 1}]]
        }
    } else {
        # No special characters found
        set szRet $str
    }
    return $szRet
}

• Home
• Recent changes
• Help
• WhoAmI/Logout
• Create new page
• Random page
• Previous page
• Next page
• 
  
• Add comments
• Edit
• History
• Edit summary
• References