#	------------------------------------------------------------
#   Copyright (c) 2018-2018
#	Q.W.Page Associates Inc.
#	www.qwpage.com
#	All rights reserved.
#	------------------------------------------------------------
::namespace eval ::qw::netutil {}

::proc ::qw::netutil::is_valid_ipv4 {String} {
	/* {
	Code borrowed from http://wiki.tcl.tk/989;
    */ }
	::if {[::regexp {^\d+\.\d+\.\d+\.\d+$} $String]
		&& [scan $String %d.%d.%d.%d a b c d] == 4
		&& 0 <= $a && $a <= 255 && 0 <= $b && $b <= 255
		&& 0 <= $c && $c <= 255 && 0 <= $d && $d <= 255} {
        # valid value is $a.$b.$c.$d (in case you want to return it).
		::return 1;
    }
    ::return 0;
}
::proc ::qw::netutil::myexternalip {sargs} {
	/* {
	# 2.32.0

    aew wanted it added to net perofrmance test.
	Also added it to help about.

    Gets my external ip address.

    Gets it from url - http://www.myexternalip.com/raw
    Uses ::http::geturl
    */ }
    ::set rwb1_debug 0;
    ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::netutil::myexternalip,1000.0";}
	::if {$rwb1_debug} {
    	::set Milli0 [::clock clicks -milliseconds];
    }
    ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::netutil::myexternalip,1000.1";}
    ::qw::try {
    ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::netutil::myexternalip,1000.3";}
		::set Token [::http::geturl http://www.myexternalip.com/raw];
    ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::netutil::myexternalip,1000.4";}
    } catch dummy {
        ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::netutil::myexternalip,exception==$dummy";}
        ::return "unknown";
    }
    ::qw::finally [::list ::http::cleanup $Token];
    ::upvar $Token State;
    ::if {$rwb1_debug} {
        ::foreach Name [::array names State] {
            ::puts "State($Name)==\"$State($Name)\"";
        }
    }
    ::set ExternalIpAddress [::string trim $State(body)];
    ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::netutil::myexternalip,1000.5";}
    ::if {$rwb1_debug} {
    	::set Milli1 [::clock clicks -milliseconds];
		::puts "rwb1_debug,::qw::netutil::myexternalip,milliseconds==[::expr {$Milli1-$Milli0}]";
    }
    ::if {$rwb1_debug} {::puts "rwb1_debug,ExternalIpAddress==$ExternalIpAddress;";}

	::if {![::qw::netutil::is_valid_ipv4 $ExternalIpAddress]} {
		::return "unknown";
    }
	::return $ExternalIpAddress;
/* {
State(sock)=="sock06234D20"
State(http)=="HTTP/1.1 200 OK"
State(querylength)=="0"
State(-queryblocksize)=="8192"
State(state)=="body"
State(charset)=="iso8859-1"
State(type)=="text/plain"
State(-binary)=="false"
State(url)=="http://www.myexternalip.com/raw"
State(-keepalive)=="0"
State(-timeout)=="0"
State(socketinfo)=="www.myexternalip.com:80"
State(queryoffset)=="0"
State(binary)=="0"
State(-strict)=="1"
State(totalsize)=="16"
State(-validate)=="0"
State(-protocol)=="1.1"
State(connection)=="close"
State(-queryprogress)==""
State(-headers)==""
State(accept-types)=="*/*"
State(-blocksize)=="8192"
State(coding)==""
State(status)=="ok"
State(body)=="206.248.190.157"
*/ }
}
::array set ::qw::netutil::channel_options_array {};
::set ::qw::netutil::channel_option_list [::list readable writable translation blocking buffering];
::proc ::qw::netutil::channel_options_save {sargs} {
    /* {
    We borrow the one channel between the NewViews workstation and server.
    So like anything we borrow, we have to return it as we found it.

    One might argue that this is not necessary because we shouldn't use the
    channel again. If we succeed in the download then we shut the server
    down, and if don't succeed, we destroy the plug and socket. However,
    code above us does try to send terminate signals and so on as it
    comes down so being polite and returning things as we found them
    pays off.
    */ }
    ::set rwb1_debug 0;
    ::if {$rwb1_debug} {::puts "rwb1_debug,channel_options_save,1000.0";}
    ::set Channel [::sargs::get $sargs .channel];
    ::if {$Channel eq ""} {
        ::if {$rwb1_debug} {::puts "rwb1_debug,channel_options_save,1000.3";}
        ::return;
    }
    ::if {[::info exists _channel_options_array($Channel-readable)]} {
        ::if {$rwb1_debug} {::puts "rwb1_debug,channel_options_save,1000.2";}
        ::return;
    }
    ::if {$rwb1_debug} {::puts "rwb1_debug,channel_options_save,1000.4";}
	::foreach Option $channel_option_list {
	    ::set ::qw::netutil::_channel_options_array($Channel-$Option) [::fileevent $Channel $Option];
	    ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::netutil::_channel_options_array($Channel-$Option)==$::qw::netutil::_channel_options_array($Channel-$Option)";}
        ::puts "rwb1_debug,::qw::netutil::_channel_options_array($Channel-writable)==$::qw::netutil::_channel_options_array($Channel-writable)";
        ::puts "rwb1_debug,::qw::netutil::_channel_options_array($Channel-translation)==$::qw::netutil::_channel_options_array($Channel-translation)";
        ::puts "rwb1_debug,::qw::netutil::_channel_options_array($Channel-blocking)==$::qw::netutil::_channel_options_array($Channel-blocking)";
        ::puts "rwb1_debug,::qw::netutil::_channel_options_array($Channel-buffering)==$::qw::netutil::_channel_options_array($Channel-buffering)";
    }
    ::if {$rwb1_debug} {::puts "rwb1_debug,channel_options_save,1000.99";}
}
::proc ::qw::netutil::channel_options_restore {sargs} {
    ::set rwb1_debug 0;
    ::if {$rwb1_debug} {::puts "rwb1_debug,channel_options_restore,1000.0";}
    ::set Channel [::sargs::get $sargs .channel];
    ::if {$Channel eq ""} {
        ::if {$rwb1_debug} {::puts "rwb1_debug,channel_options_restore,1000.2";}
        ::return;
    }
    ::if {![::info exists ::qw::netutil::_channel_options_array($Channel-readable)]} {
        ::if {$rwb1_debug} {::puts "rwb1_debug,channel_options_restore,1000.1";}
        ::return;
    }
    ::if {$rwb1_debug} {
        ::puts "rwb1_debug,::qw::netutil::_channel_options_array($Channel-readable)==$::qw::netutil::_channel_options_array($Channel-readable)";
        ::puts "rwb1_debug,::qw::netutil::_channel_options_array($Channel-writable)==$::qw::netutil::_channel_options_array($Channel-writable)";
        ::puts "rwb1_debug,::qw::netutil::_channel_options_array($Channel-translation)==$::qw::netutil::_channel_options_array($Channel-translation)";
        ::puts "rwb1_debug,::qw::netutil::_channel_options_array($Channel-blocking)==$::qw::netutil::_channel_options_array($Channel-blocking)";
        ::puts "rwb1_debug,::qw::netutil::_channel_options_array($Channel-buffering)==$::qw::netutil::_channel_options_array($Channel-buffering)";
    }
    ::fileevent $Channel readable $::qw::netutil::_channel_options_array($Channel-readable);
    ::fileevent $Channel writable $::qw::netutil::_channel_options_array($Channel-writable);
    ::fconfigure $Channel -translation $::qw::netutil::_channel_options_array($Channel-translation);
    ::fconfigure $Channel -blocking $::qw::netutil::_channel_options_array($Channel-blocking);
    ::fconfigure $Channel -buffering $::qw::netutil::_channel_options_array($Channel-buffering);

	::unset ::qw::netutil::_channel_options_array($Channel-readable);
	::unset ::qw::netutil::_channel_options_array($Channel-writable);
	::unset ::qw::netutil::_channel_options_array($Channel-translation);
	::unset ::qw::netutil::_channel_options_array($Channel-blocking);
	::unset ::qw::netutil::_channel_options_array($Channel-buffering);

    ::if {$rwb1_debug} {::puts "rwb1_debug,channel_options_restore,1000.99";}
}