httpパッケージを使ってURLからhtmlファイルをダウンロードして保存し、ヘッダー情報と一緒にテキストウィジェット上に表示するスクリプトである。ヘッダー情報のContent-Typeかmetaタグにcharsetがセットしてあれば、文字コードをShift_JISに変換して表示する。Shift_JISかiso-2022-jpがセットされていなければ、euc-jpのつもりで表示する(^^;)Tcl/Tkメーリングリストでの山本幸一さんと須栗歩人さんのご教授がなくてはこのアイデアが実現することはなかった。ようやくアイデアを実装してみました。ありがとうございました。保存するディレクトリにhtmlファイル名が同一のものがある場合は、時刻の秒数をファイル名として、拡張子は.htmlで自動的に保存する。[5/3/2001]

euc-jpのページが文字化けしていたので修正。
- encoding system iso8859-1 で文字のencodingを抑止する
- ::http::geturl でWWWサーバにアクセスする(binaryデータで読込)
- encoding convertfrom で適切な変換をする
山本幸一さんありがとうございました。[5/26/2001]

encoding system iso8859-1
package require http

wm title . GetUrl

# Create a frame for buttons and entry.

frame .top -borderwidth 10
pack .top -side top -fill x

# Create the command buttons.

button .top.quit -text Quit -command exit
button .top.clear -text Clear -command clear
set but [button .top.run -text "Get it" -command get_url]
pack .top.quit .top.clear .top.run -side right

# Create a labeled entry for the command

label .top.l -text URL: -padx 0
entry .top.cmd -width 40 -relief sunken \
    -textvariable url
pack .top.l -side left
pack .top.cmd -side left -fill x -expand true

# Set up key binding equivalents to the buttons

bind .top.cmd <Return> get_url
bind .top.cmd <Control-c> Stop
focus .top.cmd

# Create a text widget to log the output

frame .t
set log [text .t.log -width 80 -height 40 \
    -borderwidth 2 -relief raised -setgrid true \
    -yscrollcommand {.t.scroll set}]
scrollbar .t.scroll -command {.t.log yview}
pack .t.scroll -side right -fill y
pack .t.log -side left -fill both -expand true
pack .t -side top -fill both -expand true

# Attatch a guide frame.
frame .guide
label .guide.l
pack .guide.l
pack .guide -side top -fill both -expand true
.guide.l config -text ""

# Run the program and arrange to read its input

proc get_url {} {
    global input log file url
    if { [regexp {^.+/([^/]+)$} $url file] == 0 } {
        set file "index.html"
    }
    if [catch {open $file r} fileId] {
        .guide.l config -text "Here in't $file. OK! Write."
    } else {
        close $fileId
        set file [clock seconds].html
        .guide.l config -text "Change a filename for $file."
    }
    set out [open $file w]
    .guide.l config -text "writing $file."
    set token [::http::geturl $url -progress progress \
    -headers {Pragma no-cache} -channel $out]
    close $out

    # Display the return header information
    .guide.l config -text "displaying header information."
    upvar #0 $token state
    $log insert end $state(http)\n
    foreach {key value} $state(meta) {
            $log insert end "$key: $value\n"
    }
    set mark 0
    set code ""
    if [regexp -nocase {charset=SHIFT_JIS} $state(meta)] {
        set code "Shift-JIS"
        set mark 1
    } elseif [regexp -nocase {charset=iso-2022-jp} $state(meta)] {
        set code "iso2022-jp"
        set mark 1
    } elseif [regexp -nocase {EUC-JP} $state(meta)] {
        set code "euc-jp"
        set mark 1
    } else {
        set code "euc-jp"
    }
    set in [open $file r]
    while {[gets $in line] >= 0} {
        if { $mark == 0 } {
            if [regexp -nocase {charset=SHIFT_JIS} $line] {
                set code "Shift-JIS"
                set mark 1
            } elseif [regexp -nocase {charset=iso-2022-jp} $line] {
                set code "iso2022-jp"
                set mark 1
            } elseif [regexp -nocase {charset=euc-jp} $line] {
                set code "euc-jp"
                set mark 1
            } elseif [regexp -nocase {</HEAD>} $line] {
                set mark 1
            }
        }
        $log insert end [encoding convertfrom $code $line]\n
    }
    close $in
}
proc progress {token total current} {
    puts -nonewline "."
}

# Read and log output from the program

proc Log {} {
    global input log
    if [eof $input] {
        Stop
    } else {
        gets $input line
        $log insert end $line\n
        $log see end
    }
}

# Stop the program and fix up the button

proc Stop {} {
    global input but
    catch {close $input}
    $but config -text "Get it" -command get_url
}

proc clear {} {
    global log
    $log delete 1.0 end
    .guide.l config -text ""
}