package require http

global region
# あなたの地域を設定してください。
set region hirosima
###################
global browser
# あなたのWWWブラウザを設定してください。
set browser "D:\\Program Files\\Internet Explorer\\IEXPLORE.EXE"
################################################################
proc ShowChoices { parent varname choices procedure args } {
    set f [frame $parent.$choices -borderwidth 5]
    set b 0
    foreach item $args {
        radiobutton $f.$b -variable $varname \
            -text $item -value $item \
            -command $procedure
        pack $f.$b -side left
        incr b
    }
    pack $f -side top
}
global url word
set url ""
set word ""
wm title . "Get! TVGuide2"
global day whatday
ShowChoices {} day choices0 SetWhatday \
昨日 今日 明日 明後日 明々後日 4日後 5日後
global time
ShowChoices {} time choices1 SetDate 4時 7時 10時 13時 16時 19時 21時 23時 1時
global mode
ShowChoices {} mode choices2 SetUrl 見る Gコード 検索
label .choices2.l -text "Words:" -padx 0
entry .choices2.e -width 20 -relief sunken \
    -textvariable word
pack .choices2.l -side left
pack .choices2.e -side left
frame .entry
label .entry.l -text "URL:" -padx 0
entry .entry.e -width 20 -relief sunken \
    -textvariable url
pack .entry.l -side left
pack .entry.e -side left -fill x -expand true
pack .entry -side top -fill both -expand true
frame .t
set log [text .t.log -width 80 -height 10 \
    -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
.t.log config -cursor hand2
frame .guide
label .guide.l
pack .guide.l
pack .guide -side top -fill both -expand true
.guide.l config -text "\[日付の設定\] まず調べたい日のラジオボタンをクリックしてください。"
proc SetUrl {} {
    global region browser mode date url
    set url "http://www.tvguide.or.jp/$region/"
    if { $mode == "見る" } {
        append url "table/" $date "tb.htm"
        catch {exec $browser $url &}
    } elseif { $mode == "Gコード" } {
        append url "tableg/" $date "tb.htm"
        GetGcode
    } elseif { $mode == "検索" } {
        append url "table/" $date "tb.htm"
        GetTarget
    }
}
proc GetGcode {} {
    global url log
    set token [::http::geturl $url]
    $log delete 1.0 end
    upvar #0 $token state
    foreach line [split $state(body) \n] {
        regsub -all {<img src=/gif/n\.gif[^>]+>} $line { ニュース} line
        regsub -all {<img src=/gif/w\.gif[^>]+>} $line { 天気予報} line
        regsub -all {<\[^>\]+>} $line {} line
        if {[regexp {.+\([0-9]+\)} $line str]} {
            $log insert end $str\n
            $log see end
        }
    }
    .guide.l config -text ""
}
proc SetDate {} {
    global time date whatday
    set date [clock format [clock scan $whatday] -format "%m%d"]
    regexp {([0-9]+)時} $time match timenum
    set strlen [string length $timenum]
    if {$strlen == 1} {
        append date 0 $timenum
    } else {
        append date $timenum
    }
    .guide.l config -text "何をするか決めてください。"
}
proc SetWhatday {} {
    global day whatday
    if { $day == "昨日" } {
        set whatday yesterday
    } elseif { $day == "今日" } {
        set whatday today
    } elseif { $day == "明日" } {
        set whatday tomorrow
    } elseif { $day == "明後日" } {
        set whatday "today 2 day"
    } elseif { $day == "明々後日" } {
        set whatday "today 3 day"
    } elseif { $day == "4日後" } {
        set whatday "today 4 day"
    } elseif { $day == "5日後" } {
        set whatday "today 5 day"
    }
    .guide.l config -text "\[時間帯の設定\] 調べたい時間に近い時刻のラジオボタンをクリックしてください。"
}
proc GetTarget {} {
    global url log word
    if { $word == "" } {
        .guide.l config -text "\[検索\] Words:に検索用の言葉を入力して、検索用ラジオボタンをクリックしてください。"
    } else {
        set token [::http::geturl $url]
        $log delete 1.0 end
        upvar #0 $token state
        foreach line [split $state(body) \n] {
            regsub -all {<img src=/gif/n\.gif[^>]+>} $line " ニュース" line
            regsub -all {<img src=/gif/w\.gif[^>]+>} $line " 天気予報" line
            regsub -all {<A HREF=/bin/go\.to\?(http://[^>]+)>} $line {  \1  } line
            regsub -all {<[^>]+>} $line {} line
            regsub -all {←.+} $line {} line
            if {[regexp $word $line str]} {
                $log insert end $line\n
                $log see end
            }
        }
        hyperLink
        .guide.l config -text ""
    }
}
# テキストウィジェット上のテキスト処理とのバインディング
proc hyperLink {} {
    forAllMatches .t.log {http://[^ ]+} {
        .t.log tag add URL first last
    }
    .t.log tag configure URL -background Bisque3
    .t.log tag bind URL <Enter> {
        .t.log tag configure URL -background Seagreen2
    }
    .t.log tag bind URL <Leave> {
        .t.log tag configure URL -background Bisque3
    }
    .t.log tag bind URL <Double-Button-1> {
        set pc [%W index current]
        foreach p2 [%W tag ranges URL] {
            if [%W compare $pc < $p2] break
            set p1 $p2
        }
        exec $browser [%W get $p1 $p2] &
    }
}
# タグ付け用サブルーチン(John K. Ousterhout著、Tcl&Tkツールキット、ソフトバンク(1995)、 234ページより引用)
proc forAllMatches {w pattern script} {
    scan [$w index end] %d numLines
    for {set i 1} {$i < $numLines} {incr i} {
        $w mark set last $i.0
        while {[regexp -indices $pattern \
                [$w get last "last lineend"] indices]} {
            $w mark set first "last + [lindex $indices 0] chars"
            $w mark set last "last + 1 chars + [lindex $indices 1] chars"
            uplevel $script
        }
    }
}