Artifact
601ee8938708aafd2bcfe2a6da34645fec09aff5f8aa3233758f42e7e1cf8fee:
0000: 23 23 23 23 23 23 23 23 23 23 23 23 23 23 23 23 ################
0010: 23 23 23 23 23 23 23 23 23 23 23 23 23 23 23 23 ################
0020: 23 23 23 23 23 23 23 23 23 23 23 23 23 23 23 23 ################
0030: 23 0a 23 0a 23 20 45 78 61 6d 70 6c 65 20 33 3a #.#.# Example 3:
0040: 20 4e 6f 6e 2d 62 6c 6f 63 6b 69 6e 67 20 63 68 Non-blocking ch
0050: 61 6e 6e 65 6c 20 67 65 74 73 20 77 69 74 68 20 annel gets with
0060: 6e 6f 20 76 61 72 69 61 62 6c 65 0a 23 0a 23 23 no variable.#.##
0070: 23 23 23 23 23 23 23 23 23 23 23 23 23 23 23 23 ################
0080: 23 23 23 23 23 23 23 23 23 23 23 23 23 23 23 23 ################
0090: 23 23 23 23 23 23 23 23 23 23 23 23 23 23 23 0a ###############.
00a0: 0a 70 61 63 6b 61 67 65 20 72 65 71 75 69 72 65 .package require
00b0: 20 54 63 6c 20 38 2e 36 2d 0a 70 61 63 6b 61 67 Tcl 8.6-.packag
00c0: 65 20 72 65 71 75 69 72 65 20 74 6c 73 0a 0a 73 e require tls..s
00d0: 65 74 20 68 6f 73 74 20 22 77 77 77 2e 67 6f 6f et host "www.goo
00e0: 67 6c 65 2e 63 6f 6d 22 0a 73 65 74 20 70 6f 72 gle.com".set por
00f0: 74 20 34 34 33 0a 73 65 74 20 70 61 74 68 20 22 t 443.set path "
0100: 2f 22 0a 73 65 74 20 70 72 6f 74 6f 63 6f 6c 20 /".set protocol
0110: 22 68 74 74 70 2f 31 2e 31 22 0a 0a 23 0a 23 20 "http/1.1"..#.#
0120: 53 65 6e 64 20 48 54 54 50 20 47 65 74 20 52 65 Send HTTP Get Re
0130: 71 75 65 73 74 0a 23 0a 70 72 6f 63 20 68 74 74 quest.#.proc htt
0140: 70 5f 67 65 74 20 7b 63 68 20 68 6f 73 74 20 70 p_get {ch host p
0150: 61 74 68 20 70 72 6f 74 6f 63 6f 6c 7d 20 7b 0a ath protocol} {.
0160: 20 20 20 20 70 75 74 73 20 24 63 68 20 5b 66 6f puts $ch [fo
0170: 72 6d 61 74 20 22 47 45 54 20 25 73 20 25 73 22 rmat "GET %s %s"
0180: 20 24 70 61 74 68 20 5b 73 74 72 69 6e 67 20 74 $path [string t
0190: 6f 75 70 70 65 72 20 24 70 72 6f 74 6f 63 6f 6c oupper $protocol
01a0: 5d 5d 0a 20 20 20 20 70 75 74 73 20 24 63 68 20 ]]. puts $ch
01b0: 5b 66 6f 72 6d 61 74 20 22 55 73 65 72 2d 41 67 [format "User-Ag
01c0: 65 6e 74 3a 20 4d 6f 7a 69 6c 6c 61 2f 34 2e 30 ent: Mozilla/4.0
01d0: 20 28 63 6f 6d 70 61 74 69 62 6c 65 3b 20 25 73 (compatible; %s
01e0: 29 22 20 24 3a 3a 74 63 6c 5f 70 6c 61 74 66 6f )" $::tcl_platfo
01f0: 72 6d 28 6f 73 29 5d 0a 20 20 20 20 70 75 74 73 rm(os)]. puts
0200: 20 24 63 68 20 5b 66 6f 72 6d 61 74 20 22 48 6f $ch [format "Ho
0210: 73 74 3a 20 25 73 22 20 24 68 6f 73 74 5d 0a 20 st: %s" $host].
0220: 20 20 20 70 75 74 73 20 24 63 68 20 5b 66 6f 72 puts $ch [for
0230: 6d 61 74 20 22 43 6f 6e 6e 65 63 74 69 6f 6e 3a mat "Connection:
0240: 20 63 6c 6f 73 65 22 5d 0a 20 20 20 20 70 75 74 close"]. put
0250: 73 20 24 63 68 20 22 22 0a 20 20 20 20 66 6c 75 s $ch "". flu
0260: 73 68 20 24 63 68 0a 7d 0a 0a 23 20 53 61 76 65 sh $ch.}..# Save
0270: 20 72 65 74 75 72 6e 65 64 20 64 61 74 61 20 74 returned data t
0280: 6f 20 66 69 6c 65 0a 70 72 6f 63 20 73 61 76 65 o file.proc save
0290: 5f 66 69 6c 65 20 7b 66 69 6c 65 6e 61 6d 65 20 _file {filename
02a0: 64 61 74 61 7d 20 7b 0a 20 20 20 20 69 66 20 7b data} {. if {
02b0: 5b 63 61 74 63 68 20 7b 6f 70 65 6e 20 24 66 69 [catch {open $fi
02c0: 6c 65 6e 61 6d 65 20 77 62 7d 20 63 68 5d 7d 20 lename wb} ch]}
02d0: 7b 0a 09 72 65 74 75 72 6e 20 2d 63 6f 64 65 20 {..return -code
02e0: 65 72 72 6f 72 20 24 63 68 0a 20 20 20 20 7d 0a error $ch. }.
02f0: 20 20 20 20 66 63 6f 6e 66 69 67 75 72 65 20 24 fconfigure $
0300: 63 68 20 2d 62 75 66 66 65 72 73 69 7a 65 20 31 ch -buffersize 1
0310: 36 33 38 34 20 2d 65 6e 63 6f 64 69 6e 67 20 75 6384 -encoding u
0320: 74 66 2d 38 20 2d 74 72 61 6e 73 6c 61 74 69 6f tf-8 -translatio
0330: 6e 20 63 72 6c 66 0a 20 20 20 20 70 75 74 73 20 n crlf. puts
0340: 24 63 68 20 24 64 61 74 61 0a 20 20 20 20 63 6c $ch $data. cl
0350: 6f 73 65 20 24 63 68 0a 7d 0a 0a 0a 0a 70 72 6f ose $ch.}....pro
0360: 63 20 68 61 6e 64 6c 65 72 20 7b 63 68 7d 20 7b c handler {ch} {
0370: 0a 20 20 20 20 73 65 74 20 6c 69 6e 65 20 5b 67 . set line [g
0380: 65 74 73 20 24 63 68 5d 0a 20 20 20 20 69 66 20 ets $ch]. if
0390: 7b 5b 65 6f 66 20 24 63 68 5d 7d 20 7b 0a 09 23 {[eof $ch]} {..#
03a0: 20 45 4f 46 0a 09 63 6c 6f 73 65 20 24 63 68 0a EOF..close $ch.
03b0: 09 73 65 74 20 3a 3a 77 61 69 74 20 31 0a 09 72 .set ::wait 1..r
03c0: 65 74 75 72 6e 0a 20 20 20 20 7d 20 65 6c 73 65 eturn. } else
03d0: 69 66 20 7b 21 5b 66 62 6c 6f 63 6b 65 64 20 24 if {![fblocked $
03e0: 63 68 5d 7d 20 7b 0a 09 23 20 46 75 6c 6c 20 6f ch]} {..# Full o
03f0: 72 20 65 6d 70 74 79 20 6c 69 6e 65 0a 09 61 70 r empty line..ap
0400: 70 65 6e 64 20 3a 3a 64 61 74 61 20 24 6c 69 6e pend ::data $lin
0410: 65 20 22 5c 6e 22 0a 20 20 20 20 7d 20 65 6c 73 e "\n". } els
0420: 65 20 7b 0a 09 23 20 50 61 72 74 69 61 6c 20 6c e {..# Partial l
0430: 69 6e 65 0a 09 61 70 70 65 6e 64 20 3a 3a 64 61 ine..append ::da
0440: 74 61 20 24 6c 69 6e 65 0a 20 20 20 20 7d 0a 7d ta $line. }.}
0450: 0a 0a 70 72 6f 63 20 67 65 74 73 5f 6e 6f 6e 5f ..proc gets_non_
0460: 62 6c 6f 63 6b 69 6e 67 5f 6e 6f 5f 76 61 72 69 blocking_no_vari
0470: 61 62 6c 65 20 7b 68 6f 73 74 20 70 6f 72 74 20 able {host port
0480: 70 61 74 68 20 70 72 6f 74 6f 63 6f 6c 7d 20 7b path protocol} {
0490: 0a 20 20 20 20 73 65 74 20 3a 3a 77 61 69 74 20 . set ::wait
04a0: 30 0a 0a 20 20 20 20 23 20 4f 70 65 6e 20 73 6f 0.. # Open so
04b0: 63 6b 65 74 0a 20 20 20 20 73 65 74 20 63 68 20 cket. set ch
04c0: 5b 3a 3a 74 6c 73 3a 3a 73 6f 63 6b 65 74 20 2d [::tls::socket -
04d0: 73 65 72 76 65 72 6e 61 6d 65 20 24 68 6f 73 74 servername $host
04e0: 20 2d 72 65 71 75 65 73 74 20 31 20 2d 72 65 71 -request 1 -req
04f0: 75 69 72 65 20 31 20 2d 61 6c 70 6e 20 5b 6c 69 uire 1 -alpn [li
0500: 73 74 20 5b 73 74 72 69 6e 67 20 74 6f 6c 6f 77 st [string tolow
0510: 65 72 20 24 70 72 6f 74 6f 63 6f 6c 5d 5d 20 24 er $protocol]] $
0520: 68 6f 73 74 20 24 70 6f 72 74 5d 0a 20 20 20 20 host $port].
0530: 63 68 61 6e 20 63 6f 6e 66 69 67 75 72 65 20 24 chan configure $
0540: 63 68 20 2d 62 6c 6f 63 6b 69 6e 67 20 30 20 2d ch -blocking 0 -
0550: 62 75 66 66 65 72 69 6e 67 20 6c 69 6e 65 20 2d buffering line -
0560: 62 75 66 66 65 72 73 69 7a 65 20 31 36 33 38 34 buffersize 16384
0570: 20 2d 65 6e 63 6f 64 69 6e 67 20 75 74 66 2d 38 -encoding utf-8
0580: 20 2d 74 72 61 6e 73 6c 61 74 69 6f 6e 20 7b 61 -translation {a
0590: 75 74 6f 20 63 72 6c 66 7d 0a 20 20 20 20 66 69 uto crlf}. fi
05a0: 6c 65 65 76 65 6e 74 20 24 63 68 20 72 65 61 64 leevent $ch read
05b0: 61 62 6c 65 20 5b 6c 69 73 74 20 68 61 6e 64 6c able [list handl
05c0: 65 72 20 24 63 68 5d 0a 0a 20 20 20 20 23 20 49 er $ch].. # I
05d0: 6e 69 74 69 61 74 65 20 68 61 6e 64 73 68 61 6b nitiate handshak
05e0: 65 0a 20 20 20 20 3a 3a 74 6c 73 3a 3a 68 61 6e e. ::tls::han
05f0: 64 73 68 61 6b 65 20 24 63 68 0a 20 20 20 20 61 dshake $ch. a
0600: 66 74 65 72 20 31 30 30 30 0a 0a 20 20 20 20 23 fter 1000.. #
0610: 20 53 65 6e 64 20 67 65 74 20 72 65 71 75 65 73 Send get reques
0620: 74 0a 20 20 20 20 61 66 74 65 72 20 35 30 30 30 t. after 5000
0630: 20 5b 6c 69 73 74 20 73 65 74 20 3a 3a 77 61 69 [list set ::wai
0640: 74 20 31 5d 0a 20 20 20 20 68 74 74 70 5f 67 65 t 1]. http_ge
0650: 74 20 24 63 68 20 24 68 6f 73 74 20 24 70 61 74 t $ch $host $pat
0660: 68 20 24 70 72 6f 74 6f 63 6f 6c 0a 0a 20 20 20 h $protocol..
0670: 20 76 77 61 69 74 20 3a 3a 77 61 69 74 0a 20 20 vwait ::wait.
0680: 20 20 63 61 74 63 68 20 7b 63 6c 6f 73 65 20 24 catch {close $
0690: 63 68 7d 0a 7d 0a 0a 73 65 74 20 64 61 74 61 20 ch}.}..set data
06a0: 22 22 0a 67 65 74 73 5f 6e 6f 6e 5f 62 6c 6f 63 "".gets_non_bloc
06b0: 6b 69 6e 67 5f 6e 6f 5f 76 61 72 69 61 62 6c 65 king_no_variable
06c0: 20 24 68 6f 73 74 20 24 70 6f 72 74 20 24 70 61 $host $port $pa
06d0: 74 68 20 24 70 72 6f 74 6f 63 6f 6c 0a 73 61 76 th $protocol.sav
06e0: 65 5f 66 69 6c 65 20 22 67 65 74 73 5f 6e 6f 6e e_file "gets_non
06f0: 5f 62 6c 6f 63 6b 69 6e 67 5f 6e 6f 5f 76 61 72 _blocking_no_var
0700: 69 61 62 6c 65 2e 74 78 74 22 20 24 64 61 74 61 iable.txt" $data
0710: 0a .