TStcltk 発言

こんにちは、山本です。

Tclに付属しているhttpパッケージのcharsetが正常に働かない問題で、
encodingコマンドとfconfigureコマンドを拡張してIANAに登録されている
character setsの名称でエンコーディングできるようにするスクリプトを
作ってみました。
このスクリプトを実行すると、encodingコマンドにaliasというオプションが
使えるようになります。例えば、

    encoding alias ISO-2022-JP iso2022-jp
    encoding alias Shift_JIS shiftjis

とやると、エンコーディング名としてIANAのcharaset名である
ISO-2022-JPとShift_JISが使用できるようになります。

    encoding convertto Shift_JIS こんにちは
    fconfigure $channelId -encoding ISO-2022-JP

とりあえず、Tclスクリプトでコマンドを拡張しましたが、いずれ、
コアソースに手を加えてaliasオプションを付けてやりたいところです。


namespace eval ::EncodingExtension {
    variable aliases
    array set aliases {
        iso-2022-jp      iso2022-jp
        shift_jis        cp932
    }
    proc getAliases {} {
        variable aliases
        array get aliases
    }
    proc getAliasNames {} {
        variable aliases
        array names aliases
    }
    proc aliasExists encoding {
        variable aliases
        info exists aliases([string tolower $encoding])
    }
    proc getEncoding encoding {
        variable aliases
        set encoding_lowcase [string tolower $encoding]
        if [info exists aliases($encoding_lowcase)] {
            return $aliases($encoding_lowcase)
        } {
            return $encoding
        }
    }
    proc setEncoding {alias {encoding {}}} {
        variable aliases
        if [string length $encoding] {
            set aliases([string tolower $alias]) $encoding
        } {
            unset aliases([string tolower $alias])
        }
    }
    namespace eval Encoding {
        proc alias args {
            switch [llength $args] {
                0 {
                    ::EncodingExtension::getAliases
                }
                1 {
                    if [::EncodingExtension::aliasExists $args] {
                        ::EncodingExtension::getEncoding $args
                    } {
                        return
                    }
                }
                default {
                    foreach {aliasname encodingname} $args {
                        ::EncodingExtension::setEncoding $aliasname $encodingname
                    }
                }
            }
        }
        proc convertfrom args {
            switch [llength $args] {
                1 {
                    ::EncodingExtension::encoding convertfrom $args
                }
                2 {
                    foreach {encodingname data} $args {}
                    ::EncodingExtension::encoding convertfrom \
                        [::EncodingExtension::getEncoding $encodingname] $data
                }
                default {
                    error "wrong # args: should be\
                        \"encoding convertfrom ?encoding? data\""
                }
            }
        }
        proc convertto args {
            switch [llength $args] {
                1 {
                    ::EncodingExtension::encoding convertto $args
                }
                2 {
                    foreach {encodingname data} $args {}
                    ::EncodingExtension::encoding convertto \
                        [::EncodingExtension::getEncoding $encodingname] $data
                }
                default {
                    error "wrong # args: should be\
                        \"encoding convertto ?encoding? data\""
                }
            }
        }
        proc names args {
            set encodings [::EncodingExtension::encoding name]
            eval lappend encodings [::EncodingExtension::getAliasNames]
            return $encodings
        }
        proc system args {
            switch [llength $args] {
                0 {
                    ::EncodingExtension::encoding system
                }
                1 {
                    ::EncodingExtension::encoding system \
                        [::EncodingExtension::getEncoding $args]
                }
                default {
                    error "wrong # args: should be\
                        \"encoding system ?encoding?\""
                }
            }
        }
    }
}
rename encoding ::EncodingExtension::encoding
rename fconfigure ::EncodingExtension::fconfigure
proc encoding {option args} {
    if {[info commands ::EncodingExtension::Encoding::$option] == ""} {
        error "bad option \"$option\": must be\
            convertfrom, convertto, names, system, or alias"
    } else {
        eval ::EncodingExtension::Encoding::$option $args
    }
}
proc fconfigure {channelId args} {
    set argc [string length $args]
    if !$argc {
        eval EncodingExtension::fconfigure [list $channelId]
    } elseif {$argc == 1} {
        eval EncodingExtension::fconfigure [list $channelId] $args
    } else {
        set options {}
        foreach {name value} $args {
            switch -- $name {
                -encoding {
                    lappend options $name \
                        [EncodingExtension::getEncoding $value]
                }
                default {
                    lappend options $name $value
                }
            }
        }
        eval EncodingExtension::fconfigure [list $channelId] $options
    }
}

--
Koichi Yamamoto, 
http://www3.ocn.ne.jp/~yamako/