#!/bin/sh
# Copyright (C) 2004, 2005, Peter da Silva     All rights reserved.
# See "LICENSE.txt" for license details.
#\
exec wish "$0" ${1+"$@"}

proc encode {text} {
    global encoding
    if {"$encoding" == "none"} {
        return $text
    }
    return [encoding convertto $encoding $text]
}

proc decode {text} {
    global encoding
    if {"$encoding" == "none"} {
        return $text
    }
    return [encoding convertfrom $encoding $text]
}

proc to_string {text} {
    set cstring ""

    foreach ch [split [encode $text] ""] {
	switch -- $ch {
	    "\b" { append cstring {\b} }
	    "\r" { append cstring {\r} }
	    "\n" { append cstring {\n} }
	    "\t" { append cstring {\t} }
	    "\f" { append cstring {\f} }
	    "\\" { append cstring $ch $ch }
	    {"}  { append cstring {\"} }
	    default {
		if [catch {scan $ch %c dec} err] {
		    alert $err
		} else {
		    if {$dec < 32} {
			append cstring [format {\%03o} $dec]
		    } elseif {$dec <= 127} {
			append cstring $ch
		    } elseif {$dec < 255} {
			append cstring [format {\x%02x} $dec]
		    } else {
			append cstring [format {\U%04x} $dec]
		    }
		}
	    }
	}
    }

    return "\"$cstring\""
}

proc from_string {cstring} {
    set text ""

    if [regexp {^"(.*)} $cstring _ cstring] {
        if ![regexp {(.*)"$} $cstring _ cstring] {
	    alert "Warning: non-terminated string"
	}
    }
    while {[string length $cstring]} {
        if [regexp {^\\(.)(.*)} $cstring _ ch cstring] {
	    switch -glob -- $ch {
		0 {
		    regexp {^([0-7][0-7]*)(.*)} $ch$cstring _ oct cstring
		    if [catch {scan $oct %o dec} err] {
			alert $err
		    } else {
			append text [format %c $dec]
		    }
		}
		[1-9] {
		    regexp {^([0-9][0-9]*)(.*)} $ch$string _ dec cstring
		    append text [format %c $dec]
	        }
	        [xX] {
		    if [catch {set ch [gethex 2 cstring]} err] {
			alert $err
		    }
		    append text $ch
		}
	        [uU] {
		    if [catch {set ch [gethex 4 cstring]} err] {
			alert $err
		    }
		    append text [encode $ch]
		}
		r { append text "\r" }
		n { append text "\n" }
		t { append text "\t" }
		b { append text "\b" }
		f { append text "\f" }
		default {
		    append text $ch
		}
	    }
	} else {
	    if [regexp {^(.)(.*)} $cstring _ ch cstring] {
		append text $ch
	    } else {
		alert "No characters in '$cstring'? How can this be?"
	    }
	}
    }
    return [decode $text]
}

proc gethex {count _string} {
    upvar 1 $_string string
    set hex ""
    set text $string
    while {$count > 0} {
	incr count -1
	if ![regexp {^([0-9a-fA-F])(.*)} $text _ digit text] {
	    return -code error "Bad hex digit '[string index $text 0]'"
	}
	append hex $digit
    }
    set string $text
    scan $hex %x dec
    return [format %c $dec]
}

proc from_printable {qp} {
    set text ""
    while {[string length $qp]} {
        if [regexp {^=([0-9a-fA-F][0-9a-fA-F])(.*)} $qp _ hex qp] {
	    scan $hex %x i
	    append text [format %c $i]
	    continue
	}
	if [regexp {^(.)(.*)} $qp _ byte qp] {
	    append text $byte
	    continue
	}
	alert "No characters in '$qp'? How can this be?"
    }
    return [decode $text]
}

proc from_url {url} {
    set text ""
    while {[string length $url]} {
        if [regexp {^%([0-9a-fA-F][0-9a-fA-F])(.*)} $url _ hex url] {
	    scan $hex %x i
	    append text [format %c $i]
	    continue
	}
	if [regexp {^(.)(.*)} $url _ byte url] {
	    append text $byte
	    continue
	}
	alert "No characters in '$qp'? How can this be?"
    }
    return [encoding convertfrom utf-8 $text]
}

proc from_entity {ent} {
    set text ""
    while {[string length $ent]} {
        if [regexp {^[&]#([0-9][0-9]*);(.*)} $ent _ dec ent] {
            append text [format %c $dec]
            continue
        }
	if [regexp {^[&]([0-9a-zA-Z][0-9a-zA-Z]*);(.*)} $ent _ name ent] {
	    if [catch {set dec [entcode $name]} err] {
		alert $err
		continue
	    }
            append text [format %c $dec]
            continue
	}
	if [regexp {^[&][&];(.*)} $ent _ ent] {
	    append text "&"
	    continue
	}
        if [regexp {^(.)(.*)} $ent _ ch ent] {
            append text $ch
	    continue
	}
	alert "No characters in '$ent'? How can this be?"
    }
    return $text
}

proc from_hex {hex} {
    set text ""
    foreach x [split $hex " "] {
	if ![string length $x] {
	    continue
	}
	if ![string is xdigit $x] {
	    alert "Not a hexadecimal number: '$x'"
	    continue
	}
        if [catch {scan $x "%x" i} err] {
            alert $err
	    continue
        }
        if [catch {append text [format %c $i]} err] {
	    alert $err
	}
    }
    return $text
}

proc from_decimal {decimal} {
    set text ""
    foreach i [split $decimal " "] {
	if ![string length $i] {
	    continue
	}
	if ![string is integer $i] {
	    alert "Not a decimal number: '$i'"
	    continue
	}
        if [catch {append text [format %c $i]} err] {
	    alert $err
	}
    }
    return $text
}

proc from_unicode {text} {
    return $text
}

proc setfont {font args} {
    global entry

    foreach name $args { 
	if [info exists entry($name)] {
	    $entry($name) configure -font [list $font]
	}
    }
}

proc setfrom {name} {
    global entry

    alert "" black
    set text [from_$name [$entry($name) get]]
    foreach {n e} [array get entry] {
        if {"$n" != "$name"} {
	    $e delet 0 end
	    $e insert end [to_$n $text]
        }
    }
}

proc to_hex {text} {
    set hex {}
    foreach ch [split $text ""] {
        scan $ch "%c" i
	if {$i < 256} {
	    lappend hex [format %02x $i]
	} else {
	    lappend hex [format %04x $i]
	}
    }
    return [join $hex " "]
}

proc to_decimal {text} {
    set decimal {}
    foreach ch [split $text ""] {
        scan $ch "%c" i
        lappend decimal $i
    }
    return [join $decimal " "]
}

proc to_entity {text} {
    set entity ""
    foreach ch [split $text ""] {
        scan $ch "%c" i
	set name [entname $i]
        if {$i >= 32 && $i <= 127 && "$name" == "#$i"} {
            append entity $ch
        } else {
            append entity "&$name;"
        }
    }
    return $entity
}

proc to_unicode {text} {
    return $text
}

proc to_printable {text} {
    set qp ""
    foreach byte [split [encode $text] ""] {
	scan $byte %c i
        if {"$byte" == "=" || $i < 32 || $i > 127} {
	    append qp [format =%02X $i]
	} else {
	    append qp $byte
	}
    }
    return $qp
}

proc to_url {text} {
    set url ""
    foreach byte [split [encoding convertto utf-8 $text] ""] {
	scan $byte %c i
        if {[string match {[%<>"]} $byte] || $i <= 32 || $i > 127} {
	    append url [format %%%02X $i]
	} else {
	    append url $byte
	}
    }
    return $url
}

proc alert {msg {color ""}} {
    global alert
    $alert configure -text $msg
    if [string length $color] {
        $alert configure -fg $color
    }
}

proc row {grid name} {
  global entry button row
  append ent $grid . $name _ent
  append go $grid . $name _go

  entry $ent -width 64 -border 1 -relief sunken
  bind $ent <Return> [list setfrom $name]
  button $go -text [string totitle $name] -command [list setfrom $name]

  set pady 2
  if ![info exists row($grid)] {
    set row($grid) 0
  }
  if {$row($grid) & 1} {
    set pady 0
  }
  incr row($grid)

  grid $go $ent -sticky ew -pady $pady
  grid configure $ent -ipadx 2 -ipady 2 -padx 5

  set entry($name) $ent
  set button($name) $go
}

proc setbutton {b t} {
    global button
    $button($b) configure -text $t
}

array set code2ent {
38 amp 62 gt 60 lt 34 quot 193 Aacute 225 aacute 194 Acirc 226 acirc 180 acute
198 AElig 230 aelig 192 Agrave 224 agrave 913 Alpha 945 alpha 197 Aring
229 aring 195 Atilde 227 atilde 196 Auml 228 auml 914 Beta 946 beta 166 brvbar
199 Ccedil 231 ccedil 184 cedil 162 cent 935 Chi 967 chi 710 circ 169 copy
164 curren 176 deg 916 Delta 948 delta 247 divide 201 Eacute 233 eacute
202 Ecirc 234 ecirc 200 Egrave 232 egrave 917 Epsilon 949 epsilon 919 Eta
951 eta 208 ETH 240 eth 203 Euml 235 euml 189 frac12 188 frac14 190 frac34
915 Gamma 947 gamma 205 Iacute 237 iacute 206 Icirc 238 icirc 161 iexcl
204 Igrave 236 igrave 921 Iota 953 iota 191 iquest 207 Iuml 239 iuml 922 Kappa
954 kappa 923 Lambda 955 lambda 171 laquo 175 macr 181 micro 183 middot 924 Mu
956 mu 160 nbsp 172 not 209 Ntilde 241 ntilde 925 Nu 957 nu 211 Oacute
243 oacute 212 Ocirc 244 ocirc 338 OElig 339 oelig 210 Ograve 242 ograve
937 Omega 969 omega 927 Omicron 959 omicron 170 ordf 186 ordm 216 Oslash
248 oslash 213 Otilde 245 otilde 214 Ouml 246 ouml 182 para 934 Phi 966 phi
928 Pi 960 pi 982 piv 177 plusmn 163 pound 936 Psi 968 psi 187 raquo 174 reg
929 Rho 961 rho 352 Scaron 353 scaron 167 sect 173 shy 931 Sigma 963 sigma
962 sigmaf 185 sup1 178 sup2 179 sup3 223 szlig 932 Tau 964 tau 920 Theta
952 theta 977 thetasym 222 THORN 254 thorn 732 tilde 215 times 218 Uacute
250 uacute 219 Ucirc 251 ucirc 217 Ugrave 249 ugrave 168 uml 978 upsih
933 Upsilon 965 upsilon 220 Uuml 252 uuml 926 Xi 958 xi 221 Yacute 253 yacute
165 yen 376 Yuml 255 yuml 918 Zeta 950 zeta 8501 alefsym 8743 and 8736 ang
8776 asymp 8222 bdquo 8226 bull 8745 cap 9827 clubs 8773 cong 8629 crarr
8746 cup 8224 dagger 8225 Dagger 8595 darr 8659 dArr 9830 diams 8709 empty
8195 emsp 8194 ensp 8801 equiv 8364 euro 8707 exist 8704 forall 8260 frasl
8805 ge 8596 harr 8660 hArr 9829 hearts 8230 hellip 8465 image 8734 infin
8747 int 8712 isin 9001 lang 8592 larr 8656 lArr 8968 lceil 8220 ldquo
8804 le 8970 lfloor 8727 lowast 9674 loz 8206 lrm 8249 lsaquo 8216 lsquo
8212 mdash 8722 minus 8711 nabla 8211 ndash 8800 ne 8715 ni 8713 notin
8836 nsub 8254 oline 8853 oplus 8744 or 8855 otimes 8706 part 8240 permil
8869 perp 8243 Prime 8242 prime 8719 prod 8733 prop 8730 radic 9002 rang
8594 rarr 8658 rArr 8969 rceil 8221 rdquo 8476 real 8971 rfloor 8207 rlm
8250 rsaquo 8217 rsquo 8218 sbquo 8901 sdot 8764 sim 9824 spades 8834 sub
8838 sube 8721 sum 8835 sup 8839 supe 8756 there4 8201 thinsp 8482 trade
8593 uarr 8657 uArr 8472 weierp 8205 zwj 8204 zwnj 63743 apple}

set converted 0
proc convertcode {} {
    global ent2code code2ent converted
    if $converted return
    foreach {c e} [array get code2ent] {
        set ent2code($e) $c
    }
    set converted 1
}

proc entname {code} {
    global code2ent
    if [info exists code2ent($code)] {
        return $code2ent($code)
    } else {
	return #$code
    }
}

proc entcode {name} {
    global ent2code converted
    if !$converted convertcode
    if [info exists ent2code($name)] {
	return $ent2code($name)
    } elseif {[regexp {^#([0-9]*$)} $name _ decimal]} {
	return $decimal
    } else {
	return -code error "Unknown entity '$name'"
    }
}

proc bigmenu {menu var cmd list} {
    set subsize 0
    set submenu 0
    set count 0
    foreach name $list {
        if {$count == 0 && ![string is alnum [string index $name 0]]} {
	    continue
        }
        incr count
        if ![info exists submenu_name] {
	    set submenu_name $menu.$submenu
	    incr submenu
	    menu $submenu_name -tearoff 0
	    set firstname $name
        }

        $submenu_name add \
	    radiobutton -label $name -variable var -value $name -command [
		list $cmd $name
	    ]

        incr subsize
        if {$subsize >= 10} {
	    $menu add \
	        cascade -menu $submenu_name -label "$firstname .. $name"
	    unset submenu_name
	    set subsize 0
        }
    }

    if [info exists submenu_name] {
        $menu add \
	    cascade -menu $submenu_name -label "$firstname .. $name"
    }
}


label .l
pack .l -side bottom -anchor w -padx 5
set alert .l

frame .g
grid columnconfigure .g 0 -weight 0
grid columnconfigure .g 1 -weight 1

pack .g -side top -padx 2 -pady 2 -expand 1 -fill x

row .g unicode
row .g hex
row .g decimal
row .g entity
row .g url
row .g printable
row .g string

wm resizable . 1 0

menu .mb -tearoff 0
menu .mb.encoding -tearoff 0
.mb add cascade -menu .mb.encoding -label Encoding

.mb.encoding add \
    radiobutton -label none -variable encoding -value none -command {
        setbutton printable Printable
    }

set encoding [encoding system]

.mb.encoding add \
    radiobutton -label system -variable encoding -value $encoding -command [
        list setbutton printable '$encoding'
    ]

.mb.encoding add separator

proc setprintable {name} {
    setbutton printable '$name'
}

bigmenu .mb.encoding encoding setprintable [lsort -dictionary [encoding names]]

menu .mb.fonts -tearoff 0
.mb add cascade -menu .mb.fonts -label Font

proc setunifont {name} {
    setfont $name unicode
}

bigmenu .mb.fonts font setunifont [lsort -dictionary [font families]]

. configure -menu .mb

catch {
  .mb.apple configure -label "Universal Unicode Converter"
}

wm title . "Universal Unicode Converter"

setprintable '$encoding'

alert "Enter a string and hit return or click on the button next to it."