Http package tester

package require Tk
if {![package vsatisfies [package provide Tk] 8.5]} {
    set auto_path [concat /opt/tcl/site-lib/tile0.8.2 $auto_path]
    package require tile
}
source [file join [file dirname [info script]] http.tcl]
set auto_path [concat /opt/tcl/site-lib/tls1.5.1 $auto_path]
package require tls

http::register https 443 ::tls::socket

proc Progress {tok total count} {
    .status.progress configure -value [expr {($count * 100) / $total}]
}

proc Command {tok} {
    .t insert end "$tok [http::status $tok]\n" {}
    catch {
        for {set level 0} {1} {incr level -1} {
            .t insert end "\t[info level $level]\n" {}
        }
    }
    if {[http::status $tok] eq "error"} {
        .t insert end "error: [http::error $tok]\n" {}
    }
    .t insert end "\n[http::meta $tok]\n" {}

    ::http::cleanup $tok
}

proc Fetch {url} {
    if {[catch {http::geturl $url \
                    -timeout 10000 \
                    -progress Progress \
                    -command Command} err]} {
        
        .t insert end "Caught error: $err\n" {} $::errorInfo\n {}
        catch {
            for {set level 0} {1} {incr level -1} {
                .t insert end "\t[info level $level]\n" {}
            }
        }
    }
}

proc Main {url} {
    text .t -yscrollcommand {.vs set}
    scrollbar .vs -command {.t yview}
    ttk::frame .status
    ttk::label .status.pane0
    ttk::progressbar .status.progress
    ttk::sizegrip .status.sizegrip

    grid .status.pane0 .status.progress .status.sizegrip -sticky news
    grid rowconfigure .status 0 -weight 1
    grid columnconfigure .status 0 -weight 1

    grid .t      .vs -sticky news
    grid .status -   -sticky ew
    grid rowconfigure . 0 -weight 1
    grid columnconfigure . 0 -weight 1

    bind . <Control-F2> {console show}

    after 250 [list Fetch $url]
    tkwait window .
}

if {!$tcl_interactive} {
    set r [catch [linsert $argv 0 Main] err]
    if {$r} {
        tk_messageBox -icon error -title [info script] -message $::errorInfo
    } elseif {[string length $err]>0} {
        tk_messageBox -icon info -title [info script] -message $err
    }
    exit $r
}