Tcl Source Code

Check-in [1f13ffc351]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Created branch scriptics-sc-2-0-fixed-synthetic
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | scriptics-sc-2-0-fixed | scriptics-sc-2-0-fixed-synthetic
Files: files | file ages | folders
SHA1: 1f13ffc351b613f5f891e68d4d6227894790656d
User & Date: cvs2fossil 2000-03-30 04:36:09
Context
2000-03-30
04:36
Created branch scriptics-sc-2-0-fixed-synthetic Closed-Leaf check-in: 1f13ffc351 user: cvs2fossil tags: scriptics-sc-2-0-fixed, scriptics-sc-2-0-fixed-synthetic
04:36
* generic/tclCompile.c (TclCleanupByteCode): made ByteCode cleanup more aware of TCL_BYTECODE_PREC...
check-in: 95a7cc2831 user: hobbs tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to ChangeLog.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
2000-03-29  Jeff Hobbs  <[email protected]>

	* generic/tclCompile.c (TclCleanupByteCode): made ByteCode cleanup
	more aware of TCL_BYTECODE_PRECOMPILED flagged structs (gen'd by
	tbcload), to correctly clean them up.

	* generic/tclClock.c (FormatClock): moved check for empty format
	earlier, commented 0 result return value

2000-03-29  Sandeep Tamhankar <[email protected]>

	* library/http2.1/http.tcl: Removed an unnecessary fileevent
	statement from the error processing part of the Write method.
	Also, fixed two potential memory leaks in wait and reset, in which
	the state array wasn't being unset before throwing an exception.
	Prior to this version, Brent checked in a fix to catch a
	fileevent statement that was sometimes causing a stack trace when
	geturl was called with -timeout.  I believe Brent's fix is
	necessary because TLS closes bad sockets for secure connections,
<
<
<
<
<
<
<
<
<


|















1
2
3
4
5
6
7
8
9
10








2000-03-29  Sandeep Tamhankar <[email protected]>

        * library/http2.1/http.tcl: Removed an unnecessary fileevent
	statement from the error processing part of the Write method.
	Also, fixed two potential memory leaks in wait and reset, in which
	the state array wasn't being unset before throwing an exception.
	Prior to this version, Brent checked in a fix to catch a
	fileevent statement that was sometimes causing a stack trace when
	geturl was called with -timeout.  I believe Brent's fix is
	necessary because TLS closes bad sockets for secure connections,

Changes to generic/tclClock.c.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
...
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
...
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
 *
 * Copyright 1991-1995 Karl Lehenbauer and Mark Diekhans.
 * Copyright (c) 1995 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclClock.c,v 1.9 2000/03/30 04:36:11 hobbs Exp $
 */

#include "tcl.h"
#include "tclInt.h"
#include "tclPort.h"

/*
................................................................................
    if (!calledTzset) {
        tzset();
        calledTzset = 1;
    }
    Tcl_MutexUnlock(&clockMutex);
#endif

    /*
     * If the user gave us -format "", just return now
     */
    if (*format == '\0') {
	return TCL_OK;
    }

#ifndef HAVE_TM_ZONE
    /*
     * This is a kludge for systems not having the timezone string in
     * struct tm.  No matter what was specified, they use the local
     * timezone string.
     */

................................................................................
        } else {
            Tcl_UnsetVar2(interp, "env", "TZ", TCL_GLOBAL_ONLY);
        }
        timezone = savedTimeZone;
        tzset();
    }
#endif

    if (result == 0) {
	/*
	 * A zero return is the error case (can also mean the strftime
	 * didn't get enough space to write into).  We know it doesn't
	 * mean that we wrote zero chars because the check for an empty
	 * format string is above.
	 */
	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
		"bad format string \"", format, "\"", (char *) NULL);
	return TCL_ERROR;
    }

    Tcl_SetStringObj(Tcl_GetObjResult(interp), buffer.string, -1);
    Tcl_DStringFree(&buffer);
    return TCL_OK;
}







|







 







<
<
<
<
<
<
<







 







<
|
<
<
<
<
<
<










7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
...
278
279
280
281
282
283
284







285
286
287
288
289
290
291
...
336
337
338
339
340
341
342

343






344
345
346
347
348
349
350
351
352
353
 *
 * Copyright 1991-1995 Karl Lehenbauer and Mark Diekhans.
 * Copyright (c) 1995 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclClock.c,v 1.8 2000/01/26 03:37:40 hobbs Exp $
 */

#include "tcl.h"
#include "tclInt.h"
#include "tclPort.h"

/*
................................................................................
    if (!calledTzset) {
        tzset();
        calledTzset = 1;
    }
    Tcl_MutexUnlock(&clockMutex);
#endif








#ifndef HAVE_TM_ZONE
    /*
     * This is a kludge for systems not having the timezone string in
     * struct tm.  No matter what was specified, they use the local
     * timezone string.
     */

................................................................................
        } else {
            Tcl_UnsetVar2(interp, "env", "TZ", TCL_GLOBAL_ONLY);
        }
        timezone = savedTimeZone;
        tzset();
    }
#endif

    if ((result == 0) && (*format != '\0')) {






	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
		"bad format string \"", format, "\"", (char *) NULL);
	return TCL_ERROR;
    }

    Tcl_SetStringObj(Tcl_GetObjResult(interp), buffer.string, -1);
    Tcl_DStringFree(&buffer);
    return TCL_OK;
}

Changes to generic/tclCompile.c.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
 *	sequence of instructions ("bytecodes"). 
 *
 * Copyright (c) 1996-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCompile.c,v 1.20 2000/03/30 04:36:11 hobbs Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"

/*
 * Table of all AuxData types.
................................................................................

    /*
     * A single heap object holds the ByteCode structure and its code,
     * object, command location, and auxiliary data arrays. This means we
     * only need to 1) decrement the ref counts of the LiteralEntry's in
     * its literal array, 2) call the free procs for the auxiliary data
     * items, and 3) free the ByteCode structure's heap object.
     *
     * The case for TCL_BYTECODE_PRECOMPILED (precompiled ByteCodes,
     * like those generated from tbcload) is special, as they doesn't
     * make use of the global literal table.  They instead maintain
     * private references to their literals which must be decremented.
     */

    if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
	register Tcl_Obj *objPtr;
 
	objArrayPtr = codePtr->objArrayPtr;
	for (i = 0;  i < numLitObjects;  i++) {
	    objPtr = *objArrayPtr;
	    if (objPtr) {
		Tcl_DecrRefCount(objPtr);
	    }
	    objArrayPtr++;
	}
	codePtr->numLitObjects = 0;
    } else if (interp != NULL) {
	/*
	 * If the interp has already been freed, then Tcl will have already 
	 * forcefully released all the literals used by ByteCodes compiled
	 * with respect to that interp.
	 */
	 
	objArrayPtr = codePtr->objArrayPtr;






|







 







|
<
<
<
<
<

<
<
<
<
<
<
<
<
<
<
<
<
|







6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
549
550
551
552
553
554
555
556





557












558
559
560
561
562
563
564
565
 *	sequence of instructions ("bytecodes"). 
 *
 * Copyright (c) 1996-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCompile.c,v 1.19 1999/12/12 02:26:41 hobbs Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"

/*
 * Table of all AuxData types.
................................................................................

    /*
     * A single heap object holds the ByteCode structure and its code,
     * object, command location, and auxiliary data arrays. This means we
     * only need to 1) decrement the ref counts of the LiteralEntry's in
     * its literal array, 2) call the free procs for the auxiliary data
     * items, and 3) free the ByteCode structure's heap object.
     */


















    if (interp != NULL) {
	/*
	 * If the interp has already been freed, then Tcl will have already 
	 * forcefully released all the literals used by ByteCodes compiled
	 * with respect to that interp.
	 */
	 
	objArrayPtr = codePtr->objArrayPtr;

Changes to library/http/http.tcl.

5
6
7
8
9
10
11
12
13







14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
...
220
221
222
223
224
225
226


227
228
229
230
231
232
233
...
248
249
250
251
252
253
254

255


256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
...
311
312
313
314
315
316
317

318
319
320
321
322

323
324
325
326
327
328
329
330
331
332
333
334
335
336





337
338
339
340
341
342
343
...
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
...
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
...
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395



396
397
398
399
400
401
402
403
404
405
406
407






408
409
410







411
412
413
414
415
416

417
418
419
420
421
422
423
424
425
426
427
428
429
430
...
440
441
442
443
444
445
446









447
448
449
450
451
452
453
...
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485

486
487
488



489
490
491

492
493
494
495
496
497
498
...
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517

518





519
520
521
522
523
524
525
526
527
528
529
530
531


532

533
534
535
536
537
538
539


540
541
542
543
544
545
546

547


548










549
550
551
552
553
554
555
...
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
...
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
#	the Safesock security policy.  These procedures use a 
#	callback interface to avoid using vwait, which is not 
#	defined in the safe base.
#
# See the file "license.terms" for information on usage and
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: http.tcl,v 1.28 2000/03/29 20:19:59 sandeep Exp $








package provide http 2.3	;# This uses Tcl namespaces

namespace eval http {
    variable http
    array set http {
	-accept */*
	-proxyhost {}
	-proxyport {}
	-useragent {Tcl http client package 2.2}
	-proxyfilter http::ProxyRequired
    }

    variable formMap
    variable alphanumeric a-zA-Z0-9
    variable c
    variable i 0
................................................................................
	-timeout 	0
	-type           application/x-www-form-urlencoded
	-queryprogress	{}
	state		header
	meta		{}
	currentsize	0
	totalsize	0


        type            text/html
        body            {}
	status		""
	http            ""
    }
    set options {-blocksize -channel -command -handler -headers \
	    -progress -query -queryblocksize -querychannel -queryprogress\
................................................................................
	} else {
	    unset $token
	    return -code error "Unknown option $flag, can be: $usage"
	}
    }

    # Make sure -query and -querychannel aren't both specified

    if {[info exists state(-query)] && [info exists state(-querychannel)]} {


	unset $token
	return -code error "Can't combine -query and -querychannel options!"
    }

    # Set a variable with whether or not we have a querychannel, because
    # we need to do special logic later if it does exist, and we don't
    # want to do a lot of [info exists...]
    set isQueryChannel [info exists state(-querychannel)]
    set isQuery [info exists state(-query)]

    if {![regexp -nocase {^(([^:]*)://)?([^/:]+)(:([0-9]+))?(/.*)?$} $url \
	    x prefix proto host y port srvurl]} {
	unset $token
	error "Unsupported URL: $url"
    }
    if {[string length $proto] == 0} {
................................................................................
    if {[info exists phost] && [string length $phost]} {
	set srvurl $url
	set conStat [catch {eval $defcmd $async {$phost $pport}} s]
    } else {
	set conStat [catch {eval $defcmd $async {$host $port}} s]
    }
    if {$conStat} {

	# something went wrong while trying to establish the connection
	# The proper response is probably to give the caller a token
	# containing error info, but that would break backwards compatibility.
	# So, let's follow tradition and throw an exception (after unsetting
	# the array).

	unset $token
	error $s
	#Finish $token $s
	#return $token
    }
    set state(sock) $s

    # Wait for the connection to complete

    if {$state(-timeout) > 0} {
	fileevent $s writable [list http::Connect $token]
	http::wait $token
	catch {fileevent $s writable {}}
	if {![string equal $state(status) "connect"]} {





	    return $token
	}
	set state(status) ""
    }

    # Send data in cr-lf format, but accept any line terminators

................................................................................
    fconfigure $s -translation {auto crlf} -buffersize $state(-blocksize)

    # The following is disallowed in safe interpreters, but the socket
    # is already in non-blocking mode in that case.

    catch {fconfigure $s -blocking off}
    set how GET
    set state(querylength) 0
    if {$isQuery} {
	set state(querylength) [string length $state(-query)]
	if {$state(querylength) > 0} {
	    set how POST
	    set contDone 0
	} else {
	    # there's no query data
................................................................................
	}
    } elseif {$state(-validate)} {
	set how HEAD
    } elseif {$isQueryChannel} {
	set how POST
	# The query channel must be blocking for the async Write to
	# work properly.
	fconfigure $state(-querychannel) -blocking 1
	set contDone 0
    }

    if {[catch {
	puts $s "$how $srvurl HTTP/1.0"
	puts $s "Accept: $http(-accept)"
	puts $s "Host: $host"
................................................................................
		set contDone 1
		set state(querylength) $value
	    }
	    if {[string length $key]} {
		puts $s "$key: $value"
	    }
	}
	if {$isQueryChannel && $state(querylength)==0} {
	    # Try to determine size of data in channel
	    if {[catch {seek $state(-querychannel) 0 end}]} {
		Finish $token "Unable to determine size of querychannel data"
		return $token
	    }
	    set state(querylength) [tell $state(-querychannel)]
	    seek $state(-querychannel) 0



	}
		
	if {$isQuery || $isQueryChannel} {
	    puts $s "Content-Type: $state(-type)"
	    if {!$contDone} {
		puts $s "Content-Length: $state(querylength)"
	    }
	    puts $s ""
	    fconfigure $s -translation {auto binary}
	    fileevent $s writable [list http::Write $token]
	} else {
	    puts $s ""






	    flush $s
	    fileevent $s readable [list http::Event $token]
	}







    } err]} {
	# The socket probably was never connected, or the connection
	# dropped later.

	reset $token ioerror
	return $token

    }

    if {! [info exists state(-command)]} {
	# geturl does EVERYTHING asynchronously, so if the user
	# calls it synchronously, we just do a wait here.
	wait $token
    }
    return $token
}

# Data access functions:
# Data - the URL data
# Status - the transaction status: ok, reset, eof, timeout
# Code - the HTTP transaction code, e.g., 200
................................................................................
    upvar 0 $token state
    return $state(status)
}
proc http::code {token} {
    variable $token
    upvar 0 $token state
    return $state(http)









}
proc http::size {token} {
    variable $token
    upvar 0 $token state
    return $state(currentsize)
}

................................................................................
    if {[info exist state]} {
	unset state
    }
}

# http::Connect
#
#	Wait for an asynchronous connection to complete
#
# Arguments
#	token	The token returned from http::geturl
#
# Side Effects
#	Sets the status of the connection, which unblocks
# 	the waiting geturl call

 proc http::Connect {token} {
    variable $token
    upvar 0 $token state

    if {[eof $state(sock)] || \
	[string length [fconfigure $state(sock) -error]]} {
	set state(status) ioerror



    } else {
	set state(status) connect
    }

 }

# http::Write
#
#	Write POST query data to the socket
#
# Arguments
................................................................................
#	Write the socket and handle callbacks.

proc http::Write {token} {
    variable $token
    upvar 0 $token state
    set s $state(sock)
    
    if {![info exist state(queryoffset)]} {
	set state(queryoffset) 0
    }
    # Output a block.  Tcl will buffer this if the socket blocks
    
    if {[catch {
	
	# Catch I/O errors on dead sockets


	if {[info exists state(-query)]} {





	    set outStr [string range $state(-query) $state(queryoffset) \
		    [expr {$state(queryoffset) + $state(-queryblocksize) - 1}]]
	    incr state(queryoffset) $state(-queryblocksize)
	} else {
	    # querychannel
	    set outStr [read $state(-querychannel) $state(-queryblocksize)]
	    incr state(queryoffset) $state(-queryblocksize)
	}
	puts -nonewline $s $outStr
	
	if {$state(querylength)>0 && \
		$state(queryoffset) >= $state(querylength)} {
	    set state(queryoffset) $state(querylength)


	}


	if {[string length $state(-queryprogress)]} {
	    eval $state(-queryprogress) [list $token $state(querylength)\
		    $state(queryoffset)]
	}
	
	if {($state(querylength)>0 && \


		$state(queryoffset) >= $state(querylength)) || \
		([info exists state(-querychannel)] && \
		    [eof $state(-querychannel)])} {
	    fileevent $s writable {}
	    flush $s
	    fileevent $s readable [list http::Event $token]
	}

    } err]} {


	Finish $token $err










    }
}

# http::Event
#
#	Handle input on the socket
#
................................................................................
#	Read the socket and handle callbacks.

 proc http::Event {token} {
    variable $token
    upvar 0 $token state
    set s $state(sock)

     if {[::eof $s]} {
	Eof $token
	return
    }
    if {[string equal $state(state) "header"]} {
	if {[catch {gets $s line} n]} {
	    Finish $token $n
	} elseif {$n == 0} {
................................................................................
    incr state(currentsize) $count
    if {[info exists state(-progress)]} {
	eval $state(-progress) {$token $state(totalsize) $state(currentsize)}
    }
    # At this point the token may have been reset
    if {[string length $error]} {
	Finish $token $error
    } elseif {[catch {::eof $s} iseof] || $iseof} {
	Eof $token
    } else {
	CopyStart $s $token
    }
}

# http::Eof






|

>
>
>
>
>
>
>
|







|







 







>
>







 







>
|
>
>




|
<
<
<
<







 







>

<
<
<
<
>
|
<
|
|








<
|
>
>
>
>
>







 







<







 







|







 







|

|
<
<
|
|
|
>
>
>












>
>
>
>
>
>
|
|
|
>
>
>
>
>
>
>

|
|

|
|
>


<
<
<
<
<







 







>
>
>
>
>
>
>
>
>







 







|











>
|
|
|
>
>
>



>







 







<
<
<






>

>
>
>
>
>
|


<
<
<
<
<
<
<
<
|
|
>
>
|
>
|
<
|
<
|
<
<
>
>
|
<
|
<
|
|
|
>

>
>
|
>
>
>
>
>
>
>
>
>
>







 







|







 







|







5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
...
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
...
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272




273
274
275
276
277
278
279
...
319
320
321
322
323
324
325
326
327




328
329

330
331
332
333
334
335
336
337
338
339

340
341
342
343
344
345
346
347
348
349
350
351
352
...
353
354
355
356
357
358
359

360
361
362
363
364
365
366
...
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
...
389
390
391
392
393
394
395
396
397
398


399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441





442
443
444
445
446
447
448
...
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
...
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
...
534
535
536
537
538
539
540



541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556








557
558
559
560
561
562
563

564

565


566
567
568

569

570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
...
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
...
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
#	the Safesock security policy.  These procedures use a 
#	callback interface to avoid using vwait, which is not 
#	defined in the safe base.
#
# See the file "license.terms" for information on usage and
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: http.tcl,v 1.30 2000/04/09 23:56:13 welch Exp $

# Rough version history:
# 1.0	Old http_get interface
# 2.0	http:: namespace and http::geturl
# 2.1	Added callbacks to handle arriving data, and timeouts
# 2.2	Added ability to fetch into a channel
# 2.3	Added SSL support, and ability to post from a channel

package provide http 2.3

namespace eval http {
    variable http
    array set http {
	-accept */*
	-proxyhost {}
	-proxyport {}
	-useragent {Tcl http client package 2.3}
	-proxyfilter http::ProxyRequired
    }

    variable formMap
    variable alphanumeric a-zA-Z0-9
    variable c
    variable i 0
................................................................................
	-timeout 	0
	-type           application/x-www-form-urlencoded
	-queryprogress	{}
	state		header
	meta		{}
	currentsize	0
	totalsize	0
	querylength	0
	queryoffset	0
        type            text/html
        body            {}
	status		""
	http            ""
    }
    set options {-blocksize -channel -command -handler -headers \
	    -progress -query -queryblocksize -querychannel -queryprogress\
................................................................................
	} else {
	    unset $token
	    return -code error "Unknown option $flag, can be: $usage"
	}
    }

    # Make sure -query and -querychannel aren't both specified

    set isQueryChannel [info exists state(-querychannel)]
    set isQuery [info exists state(-query)]
    if {$isQuery && $isQueryChannel} {
	unset $token
	return -code error "Can't combine -query and -querychannel options!"
    }

    # Validate URL, determine the server host and port, and check proxy case





    if {![regexp -nocase {^(([^:]*)://)?([^/:]+)(:([0-9]+))?(/.*)?$} $url \
	    x prefix proto host y port srvurl]} {
	unset $token
	error "Unsupported URL: $url"
    }
    if {[string length $proto] == 0} {
................................................................................
    if {[info exists phost] && [string length $phost]} {
	set srvurl $url
	set conStat [catch {eval $defcmd $async {$phost $pport}} s]
    } else {
	set conStat [catch {eval $defcmd $async {$host $port}} s]
    }
    if {$conStat} {

	# something went wrong while trying to establish the connection





	Finish $token

	cleanup $token
	return -code error $s
    }
    set state(sock) $s

    # Wait for the connection to complete

    if {$state(-timeout) > 0} {
	fileevent $s writable [list http::Connect $token]
	http::wait $token

	if {$state(status) != "connect"} {
	    
	    # Likely to be connection timeout.  If there was a connection
	    # error, (e.g., bad port), then http::wait will have 
	    # raised an error already

	    return $token
	}
	set state(status) ""
    }

    # Send data in cr-lf format, but accept any line terminators

................................................................................
    fconfigure $s -translation {auto crlf} -buffersize $state(-blocksize)

    # The following is disallowed in safe interpreters, but the socket
    # is already in non-blocking mode in that case.

    catch {fconfigure $s -blocking off}
    set how GET

    if {$isQuery} {
	set state(querylength) [string length $state(-query)]
	if {$state(querylength) > 0} {
	    set how POST
	    set contDone 0
	} else {
	    # there's no query data
................................................................................
	}
    } elseif {$state(-validate)} {
	set how HEAD
    } elseif {$isQueryChannel} {
	set how POST
	# The query channel must be blocking for the async Write to
	# work properly.
	fconfigure $state(-querychannel) -blocking 1 -translation binary
	set contDone 0
    }

    if {[catch {
	puts $s "$how $srvurl HTTP/1.0"
	puts $s "Accept: $http(-accept)"
	puts $s "Host: $host"
................................................................................
		set contDone 1
		set state(querylength) $value
	    }
	    if {[string length $key]} {
		puts $s "$key: $value"
	    }
	}
	if {$isQueryChannel && $state(querylength) == 0} {
	    # Try to determine size of data in channel
	    # If we cannot seek, the surrounding catch will trap us



	    set start [tell $state(-querychannel)]
	    seek $state(-querychannel) 0 end
	    set state(querylength) \
		    [expr {[tell $state(-querychannel)] - $start}]
	    seek $state(-querychannel) $start
	}
		
	if {$isQuery || $isQueryChannel} {
	    puts $s "Content-Type: $state(-type)"
	    if {!$contDone} {
		puts $s "Content-Length: $state(querylength)"
	    }
	    puts $s ""
	    fconfigure $s -translation {auto binary}
	    fileevent $s writable [list http::Write $token]
	} else {
	    puts $s ""
	}
	# Set up the read file event here in either case.  This seems to
	# help in the case where the server replies but does not
	# read the query post data, and the server is on the same
	# machine so the loopback interface is being used.

	flush $s
	fileevent $s readable [list http::Event $token]

	if {! [info exists state(-command)]} {

	    # geturl does EVERYTHING asynchronously, so if the user
	    # calls it synchronously, we just do a wait here.

	    wait $token
	}
    } err]} {
	# The socket probably was never connected,
	# or the connection dropped later.

	Finish $token $err
	cleanup $token
	return -code error $err
    }






    return $token
}

# Data access functions:
# Data - the URL data
# Status - the transaction status: ok, reset, eof, timeout
# Code - the HTTP transaction code, e.g., 200
................................................................................
    upvar 0 $token state
    return $state(status)
}
proc http::code {token} {
    variable $token
    upvar 0 $token state
    return $state(http)
}
proc http::ncode {token} {
    variable $token
    upvar 0 $token state
    if {[regexp {[0-9]+} $state(http) numeric_code]} {
	return $numeric_code
    } else {
	return $state(http)
    }
}
proc http::size {token} {
    variable $token
    upvar 0 $token state
    return $state(currentsize)
}

................................................................................
    if {[info exist state]} {
	unset state
    }
}

# http::Connect
#
#	This callback is made when an asyncronous connection completes.
#
# Arguments
#	token	The token returned from http::geturl
#
# Side Effects
#	Sets the status of the connection, which unblocks
# 	the waiting geturl call

 proc http::Connect {token} {
    variable $token
    upvar 0 $token state
    global errorInfo errorCode
    if {[eof $state(sock)] ||
	    [string length [fconfigure $state(sock) -error]]} {
	set state(status) error
	set state(error) [list \
		"connect failed [fconfigure $state(sock) -error]" \
		$errorInfo $errorCode]
    } else {
	set state(status) connect
    }
    fileevent $state(sock) writable {}
 }

# http::Write
#
#	Write POST query data to the socket
#
# Arguments
................................................................................
#	Write the socket and handle callbacks.

proc http::Write {token} {
    variable $token
    upvar 0 $token state
    set s $state(sock)
    



    # Output a block.  Tcl will buffer this if the socket blocks
    
    if {[catch {
	
	# Catch I/O errors on dead sockets

	set done 0
	if {[info exists state(-query)]} {
	    
	    # Chop up large query strings so queryprogress callback
	    # can give smooth feedback

	    puts -nonewline $s \
		    [string range $state(-query) $state(queryoffset) \
		    [expr {$state(queryoffset) + $state(-queryblocksize) - 1}]]
	    incr state(queryoffset) $state(-queryblocksize)








	    if {$state(queryoffset) >= $state(querylength)} {
		set state(queryoffset) $state(querylength)
		flush $s
		fileevent $s writable {}
	    }
	} else {
	    

	    # Copy blocks from the query channel




	    set outStr [read $state(-querychannel) $state(-queryblocksize)]
	    puts -nonewline $s $outStr
	    incr state(queryoffset) [string length $outStr]

	    if {[eof $state(-querychannel)]} {

		flush $s
		fileevent $s writable {}
	    }
	}
    } err]} {
	# Do not call Finish here, but instead let the read half of
	# the socket process whatever server reply there is to get.
	# Simply turn off this write process

	set state(posterror) $err
	fileevent $s writable {}
    }

    # Callback to the client after we've completely handled everything

    if {[string length $state(-queryprogress)]} {
	eval $state(-queryprogress) [list $token $state(querylength)\
		$state(queryoffset)]
    }
}

# http::Event
#
#	Handle input on the socket
#
................................................................................
#	Read the socket and handle callbacks.

 proc http::Event {token} {
    variable $token
    upvar 0 $token state
    set s $state(sock)

     if {[eof $s]} {
	Eof $token
	return
    }
    if {[string equal $state(state) "header"]} {
	if {[catch {gets $s line} n]} {
	    Finish $token $n
	} elseif {$n == 0} {
................................................................................
    incr state(currentsize) $count
    if {[info exists state(-progress)]} {
	eval $state(-progress) {$token $state(totalsize) $state(currentsize)}
    }
    # At this point the token may have been reset
    if {[string length $error]} {
	Finish $token $error
    } elseif {[catch {eof $s} iseof] || $iseof} {
	Eof $token
    } else {
	CopyStart $s $token
    }
}

# http::Eof

Changes to library/http2.1/http.tcl.

5
6
7
8
9
10
11
12
13







14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
...
220
221
222
223
224
225
226


227
228
229
230
231
232
233
...
248
249
250
251
252
253
254

255


256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
...
311
312
313
314
315
316
317

318
319
320
321
322

323
324
325
326
327
328
329
330
331
332
333
334
335
336





337
338
339
340
341
342
343
...
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
...
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
...
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395



396
397
398
399
400
401
402
403
404
405
406
407






408
409
410







411
412
413
414
415
416

417
418
419
420
421
422
423
424
425
426
427
428
429
430
...
440
441
442
443
444
445
446









447
448
449
450
451
452
453
...
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485

486
487
488



489
490
491

492
493
494
495
496
497
498
...
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517

518





519
520
521
522
523
524
525
526
527
528
529
530
531


532

533
534
535
536
537
538
539


540
541
542
543
544
545
546

547


548










549
550
551
552
553
554
555
...
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
...
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
#	the Safesock security policy.  These procedures use a 
#	callback interface to avoid using vwait, which is not 
#	defined in the safe base.
#
# See the file "license.terms" for information on usage and
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: http.tcl,v 1.28 2000/03/29 20:19:59 sandeep Exp $








package provide http 2.3	;# This uses Tcl namespaces

namespace eval http {
    variable http
    array set http {
	-accept */*
	-proxyhost {}
	-proxyport {}
	-useragent {Tcl http client package 2.2}
	-proxyfilter http::ProxyRequired
    }

    variable formMap
    variable alphanumeric a-zA-Z0-9
    variable c
    variable i 0
................................................................................
	-timeout 	0
	-type           application/x-www-form-urlencoded
	-queryprogress	{}
	state		header
	meta		{}
	currentsize	0
	totalsize	0


        type            text/html
        body            {}
	status		""
	http            ""
    }
    set options {-blocksize -channel -command -handler -headers \
	    -progress -query -queryblocksize -querychannel -queryprogress\
................................................................................
	} else {
	    unset $token
	    return -code error "Unknown option $flag, can be: $usage"
	}
    }

    # Make sure -query and -querychannel aren't both specified

    if {[info exists state(-query)] && [info exists state(-querychannel)]} {


	unset $token
	return -code error "Can't combine -query and -querychannel options!"
    }

    # Set a variable with whether or not we have a querychannel, because
    # we need to do special logic later if it does exist, and we don't
    # want to do a lot of [info exists...]
    set isQueryChannel [info exists state(-querychannel)]
    set isQuery [info exists state(-query)]

    if {![regexp -nocase {^(([^:]*)://)?([^/:]+)(:([0-9]+))?(/.*)?$} $url \
	    x prefix proto host y port srvurl]} {
	unset $token
	error "Unsupported URL: $url"
    }
    if {[string length $proto] == 0} {
................................................................................
    if {[info exists phost] && [string length $phost]} {
	set srvurl $url
	set conStat [catch {eval $defcmd $async {$phost $pport}} s]
    } else {
	set conStat [catch {eval $defcmd $async {$host $port}} s]
    }
    if {$conStat} {

	# something went wrong while trying to establish the connection
	# The proper response is probably to give the caller a token
	# containing error info, but that would break backwards compatibility.
	# So, let's follow tradition and throw an exception (after unsetting
	# the array).

	unset $token
	error $s
	#Finish $token $s
	#return $token
    }
    set state(sock) $s

    # Wait for the connection to complete

    if {$state(-timeout) > 0} {
	fileevent $s writable [list http::Connect $token]
	http::wait $token
	catch {fileevent $s writable {}}
	if {![string equal $state(status) "connect"]} {





	    return $token
	}
	set state(status) ""
    }

    # Send data in cr-lf format, but accept any line terminators

................................................................................
    fconfigure $s -translation {auto crlf} -buffersize $state(-blocksize)

    # The following is disallowed in safe interpreters, but the socket
    # is already in non-blocking mode in that case.

    catch {fconfigure $s -blocking off}
    set how GET
    set state(querylength) 0
    if {$isQuery} {
	set state(querylength) [string length $state(-query)]
	if {$state(querylength) > 0} {
	    set how POST
	    set contDone 0
	} else {
	    # there's no query data
................................................................................
	}
    } elseif {$state(-validate)} {
	set how HEAD
    } elseif {$isQueryChannel} {
	set how POST
	# The query channel must be blocking for the async Write to
	# work properly.
	fconfigure $state(-querychannel) -blocking 1
	set contDone 0
    }

    if {[catch {
	puts $s "$how $srvurl HTTP/1.0"
	puts $s "Accept: $http(-accept)"
	puts $s "Host: $host"
................................................................................
		set contDone 1
		set state(querylength) $value
	    }
	    if {[string length $key]} {
		puts $s "$key: $value"
	    }
	}
	if {$isQueryChannel && $state(querylength)==0} {
	    # Try to determine size of data in channel
	    if {[catch {seek $state(-querychannel) 0 end}]} {
		Finish $token "Unable to determine size of querychannel data"
		return $token
	    }
	    set state(querylength) [tell $state(-querychannel)]
	    seek $state(-querychannel) 0



	}
		
	if {$isQuery || $isQueryChannel} {
	    puts $s "Content-Type: $state(-type)"
	    if {!$contDone} {
		puts $s "Content-Length: $state(querylength)"
	    }
	    puts $s ""
	    fconfigure $s -translation {auto binary}
	    fileevent $s writable [list http::Write $token]
	} else {
	    puts $s ""






	    flush $s
	    fileevent $s readable [list http::Event $token]
	}







    } err]} {
	# The socket probably was never connected, or the connection
	# dropped later.

	reset $token ioerror
	return $token

    }

    if {! [info exists state(-command)]} {
	# geturl does EVERYTHING asynchronously, so if the user
	# calls it synchronously, we just do a wait here.
	wait $token
    }
    return $token
}

# Data access functions:
# Data - the URL data
# Status - the transaction status: ok, reset, eof, timeout
# Code - the HTTP transaction code, e.g., 200
................................................................................
    upvar 0 $token state
    return $state(status)
}
proc http::code {token} {
    variable $token
    upvar 0 $token state
    return $state(http)









}
proc http::size {token} {
    variable $token
    upvar 0 $token state
    return $state(currentsize)
}

................................................................................
    if {[info exist state]} {
	unset state
    }
}

# http::Connect
#
#	Wait for an asynchronous connection to complete
#
# Arguments
#	token	The token returned from http::geturl
#
# Side Effects
#	Sets the status of the connection, which unblocks
# 	the waiting geturl call

 proc http::Connect {token} {
    variable $token
    upvar 0 $token state

    if {[eof $state(sock)] || \
	[string length [fconfigure $state(sock) -error]]} {
	set state(status) ioerror



    } else {
	set state(status) connect
    }

 }

# http::Write
#
#	Write POST query data to the socket
#
# Arguments
................................................................................
#	Write the socket and handle callbacks.

proc http::Write {token} {
    variable $token
    upvar 0 $token state
    set s $state(sock)
    
    if {![info exist state(queryoffset)]} {
	set state(queryoffset) 0
    }
    # Output a block.  Tcl will buffer this if the socket blocks
    
    if {[catch {
	
	# Catch I/O errors on dead sockets


	if {[info exists state(-query)]} {





	    set outStr [string range $state(-query) $state(queryoffset) \
		    [expr {$state(queryoffset) + $state(-queryblocksize) - 1}]]
	    incr state(queryoffset) $state(-queryblocksize)
	} else {
	    # querychannel
	    set outStr [read $state(-querychannel) $state(-queryblocksize)]
	    incr state(queryoffset) $state(-queryblocksize)
	}
	puts -nonewline $s $outStr
	
	if {$state(querylength)>0 && \
		$state(queryoffset) >= $state(querylength)} {
	    set state(queryoffset) $state(querylength)


	}


	if {[string length $state(-queryprogress)]} {
	    eval $state(-queryprogress) [list $token $state(querylength)\
		    $state(queryoffset)]
	}
	
	if {($state(querylength)>0 && \


		$state(queryoffset) >= $state(querylength)) || \
		([info exists state(-querychannel)] && \
		    [eof $state(-querychannel)])} {
	    fileevent $s writable {}
	    flush $s
	    fileevent $s readable [list http::Event $token]
	}

    } err]} {


	Finish $token $err










    }
}

# http::Event
#
#	Handle input on the socket
#
................................................................................
#	Read the socket and handle callbacks.

 proc http::Event {token} {
    variable $token
    upvar 0 $token state
    set s $state(sock)

     if {[::eof $s]} {
	Eof $token
	return
    }
    if {[string equal $state(state) "header"]} {
	if {[catch {gets $s line} n]} {
	    Finish $token $n
	} elseif {$n == 0} {
................................................................................
    incr state(currentsize) $count
    if {[info exists state(-progress)]} {
	eval $state(-progress) {$token $state(totalsize) $state(currentsize)}
    }
    # At this point the token may have been reset
    if {[string length $error]} {
	Finish $token $error
    } elseif {[catch {::eof $s} iseof] || $iseof} {
	Eof $token
    } else {
	CopyStart $s $token
    }
}

# http::Eof






|

>
>
>
>
>
>
>
|







|







 







>
>







 







>
|
>
>




|
<
<
<
<







 







>

<
<
<
<
>
|
<
|
|








<
|
>
>
>
>
>







 







<







 







|







 







|

|
<
<
|
|
|
>
>
>












>
>
>
>
>
>
|
|
|
>
>
>
>
>
>
>

|
|

|
|
>


<
<
<
<
<







 







>
>
>
>
>
>
>
>
>







 







|











>
|
|
|
>
>
>



>







 







<
<
<






>

>
>
>
>
>
|


<
<
<
<
<
<
<
<
|
|
>
>
|
>
|
<
|
<
|
<
<
>
>
|
<
|
<
|
|
|
>

>
>
|
>
>
>
>
>
>
>
>
>
>







 







|







 







|







5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
...
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
...
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272




273
274
275
276
277
278
279
...
319
320
321
322
323
324
325
326
327




328
329

330
331
332
333
334
335
336
337
338
339

340
341
342
343
344
345
346
347
348
349
350
351
352
...
353
354
355
356
357
358
359

360
361
362
363
364
365
366
...
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
...
389
390
391
392
393
394
395
396
397
398


399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441





442
443
444
445
446
447
448
...
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
...
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
...
534
535
536
537
538
539
540



541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556








557
558
559
560
561
562
563

564

565


566
567
568

569

570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
...
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
...
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
#	the Safesock security policy.  These procedures use a 
#	callback interface to avoid using vwait, which is not 
#	defined in the safe base.
#
# See the file "license.terms" for information on usage and
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: http.tcl,v 1.30 2000/04/09 23:56:13 welch Exp $

# Rough version history:
# 1.0	Old http_get interface
# 2.0	http:: namespace and http::geturl
# 2.1	Added callbacks to handle arriving data, and timeouts
# 2.2	Added ability to fetch into a channel
# 2.3	Added SSL support, and ability to post from a channel

package provide http 2.3

namespace eval http {
    variable http
    array set http {
	-accept */*
	-proxyhost {}
	-proxyport {}
	-useragent {Tcl http client package 2.3}
	-proxyfilter http::ProxyRequired
    }

    variable formMap
    variable alphanumeric a-zA-Z0-9
    variable c
    variable i 0
................................................................................
	-timeout 	0
	-type           application/x-www-form-urlencoded
	-queryprogress	{}
	state		header
	meta		{}
	currentsize	0
	totalsize	0
	querylength	0
	queryoffset	0
        type            text/html
        body            {}
	status		""
	http            ""
    }
    set options {-blocksize -channel -command -handler -headers \
	    -progress -query -queryblocksize -querychannel -queryprogress\
................................................................................
	} else {
	    unset $token
	    return -code error "Unknown option $flag, can be: $usage"
	}
    }

    # Make sure -query and -querychannel aren't both specified

    set isQueryChannel [info exists state(-querychannel)]
    set isQuery [info exists state(-query)]
    if {$isQuery && $isQueryChannel} {
	unset $token
	return -code error "Can't combine -query and -querychannel options!"
    }

    # Validate URL, determine the server host and port, and check proxy case





    if {![regexp -nocase {^(([^:]*)://)?([^/:]+)(:([0-9]+))?(/.*)?$} $url \
	    x prefix proto host y port srvurl]} {
	unset $token
	error "Unsupported URL: $url"
    }
    if {[string length $proto] == 0} {
................................................................................
    if {[info exists phost] && [string length $phost]} {
	set srvurl $url
	set conStat [catch {eval $defcmd $async {$phost $pport}} s]
    } else {
	set conStat [catch {eval $defcmd $async {$host $port}} s]
    }
    if {$conStat} {

	# something went wrong while trying to establish the connection





	Finish $token

	cleanup $token
	return -code error $s
    }
    set state(sock) $s

    # Wait for the connection to complete

    if {$state(-timeout) > 0} {
	fileevent $s writable [list http::Connect $token]
	http::wait $token

	if {$state(status) != "connect"} {
	    
	    # Likely to be connection timeout.  If there was a connection
	    # error, (e.g., bad port), then http::wait will have 
	    # raised an error already

	    return $token
	}
	set state(status) ""
    }

    # Send data in cr-lf format, but accept any line terminators

................................................................................
    fconfigure $s -translation {auto crlf} -buffersize $state(-blocksize)

    # The following is disallowed in safe interpreters, but the socket
    # is already in non-blocking mode in that case.

    catch {fconfigure $s -blocking off}
    set how GET

    if {$isQuery} {
	set state(querylength) [string length $state(-query)]
	if {$state(querylength) > 0} {
	    set how POST
	    set contDone 0
	} else {
	    # there's no query data
................................................................................
	}
    } elseif {$state(-validate)} {
	set how HEAD
    } elseif {$isQueryChannel} {
	set how POST
	# The query channel must be blocking for the async Write to
	# work properly.
	fconfigure $state(-querychannel) -blocking 1 -translation binary
	set contDone 0
    }

    if {[catch {
	puts $s "$how $srvurl HTTP/1.0"
	puts $s "Accept: $http(-accept)"
	puts $s "Host: $host"
................................................................................
		set contDone 1
		set state(querylength) $value
	    }
	    if {[string length $key]} {
		puts $s "$key: $value"
	    }
	}
	if {$isQueryChannel && $state(querylength) == 0} {
	    # Try to determine size of data in channel
	    # If we cannot seek, the surrounding catch will trap us



	    set start [tell $state(-querychannel)]
	    seek $state(-querychannel) 0 end
	    set state(querylength) \
		    [expr {[tell $state(-querychannel)] - $start}]
	    seek $state(-querychannel) $start
	}
		
	if {$isQuery || $isQueryChannel} {
	    puts $s "Content-Type: $state(-type)"
	    if {!$contDone} {
		puts $s "Content-Length: $state(querylength)"
	    }
	    puts $s ""
	    fconfigure $s -translation {auto binary}
	    fileevent $s writable [list http::Write $token]
	} else {
	    puts $s ""
	}
	# Set up the read file event here in either case.  This seems to
	# help in the case where the server replies but does not
	# read the query post data, and the server is on the same
	# machine so the loopback interface is being used.

	flush $s
	fileevent $s readable [list http::Event $token]

	if {! [info exists state(-command)]} {

	    # geturl does EVERYTHING asynchronously, so if the user
	    # calls it synchronously, we just do a wait here.

	    wait $token
	}
    } err]} {
	# The socket probably was never connected,
	# or the connection dropped later.

	Finish $token $err
	cleanup $token
	return -code error $err
    }






    return $token
}

# Data access functions:
# Data - the URL data
# Status - the transaction status: ok, reset, eof, timeout
# Code - the HTTP transaction code, e.g., 200
................................................................................
    upvar 0 $token state
    return $state(status)
}
proc http::code {token} {
    variable $token
    upvar 0 $token state
    return $state(http)
}
proc http::ncode {token} {
    variable $token
    upvar 0 $token state
    if {[regexp {[0-9]+} $state(http) numeric_code]} {
	return $numeric_code
    } else {
	return $state(http)
    }
}
proc http::size {token} {
    variable $token
    upvar 0 $token state
    return $state(currentsize)
}

................................................................................
    if {[info exist state]} {
	unset state
    }
}

# http::Connect
#
#	This callback is made when an asyncronous connection completes.
#
# Arguments
#	token	The token returned from http::geturl
#
# Side Effects
#	Sets the status of the connection, which unblocks
# 	the waiting geturl call

 proc http::Connect {token} {
    variable $token
    upvar 0 $token state
    global errorInfo errorCode
    if {[eof $state(sock)] ||
	    [string length [fconfigure $state(sock) -error]]} {
	set state(status) error
	set state(error) [list \
		"connect failed [fconfigure $state(sock) -error]" \
		$errorInfo $errorCode]
    } else {
	set state(status) connect
    }
    fileevent $state(sock) writable {}
 }

# http::Write
#
#	Write POST query data to the socket
#
# Arguments
................................................................................
#	Write the socket and handle callbacks.

proc http::Write {token} {
    variable $token
    upvar 0 $token state
    set s $state(sock)
    



    # Output a block.  Tcl will buffer this if the socket blocks
    
    if {[catch {
	
	# Catch I/O errors on dead sockets

	set done 0
	if {[info exists state(-query)]} {
	    
	    # Chop up large query strings so queryprogress callback
	    # can give smooth feedback

	    puts -nonewline $s \
		    [string range $state(-query) $state(queryoffset) \
		    [expr {$state(queryoffset) + $state(-queryblocksize) - 1}]]
	    incr state(queryoffset) $state(-queryblocksize)








	    if {$state(queryoffset) >= $state(querylength)} {
		set state(queryoffset) $state(querylength)
		flush $s
		fileevent $s writable {}
	    }
	} else {
	    

	    # Copy blocks from the query channel




	    set outStr [read $state(-querychannel) $state(-queryblocksize)]
	    puts -nonewline $s $outStr
	    incr state(queryoffset) [string length $outStr]

	    if {[eof $state(-querychannel)]} {

		flush $s
		fileevent $s writable {}
	    }
	}
    } err]} {
	# Do not call Finish here, but instead let the read half of
	# the socket process whatever server reply there is to get.
	# Simply turn off this write process

	set state(posterror) $err
	fileevent $s writable {}
    }

    # Callback to the client after we've completely handled everything

    if {[string length $state(-queryprogress)]} {
	eval $state(-queryprogress) [list $token $state(querylength)\
		$state(queryoffset)]
    }
}

# http::Event
#
#	Handle input on the socket
#
................................................................................
#	Read the socket and handle callbacks.

 proc http::Event {token} {
    variable $token
    upvar 0 $token state
    set s $state(sock)

     if {[eof $s]} {
	Eof $token
	return
    }
    if {[string equal $state(state) "header"]} {
	if {[catch {gets $s line} n]} {
	    Finish $token $n
	} elseif {$n == 0} {
................................................................................
    incr state(currentsize) $count
    if {[info exists state(-progress)]} {
	eval $state(-progress) {$token $state(totalsize) $state(currentsize)}
    }
    # At this point the token may have been reset
    if {[string length $error]} {
	Finish $token $error
    } elseif {[catch {eof $s} iseof] || $iseof} {
	Eof $token
    } else {
	CopyStart $s $token
    }
}

# http::Eof

Changes to library/http2.3/http.tcl.

5
6
7
8
9
10
11
12
13







14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
...
220
221
222
223
224
225
226


227
228
229
230
231
232
233
...
248
249
250
251
252
253
254

255


256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
...
311
312
313
314
315
316
317

318
319
320
321
322

323
324
325
326
327
328
329
330
331
332
333
334
335
336





337
338
339
340
341
342
343
...
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
...
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
...
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395



396
397
398
399
400
401
402
403
404
405
406
407






408
409
410







411
412
413
414
415
416

417
418
419
420
421
422
423
424
425
426
427
428
429
430
...
440
441
442
443
444
445
446









447
448
449
450
451
452
453
...
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485

486
487
488



489
490
491

492
493
494
495
496
497
498
...
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517

518





519
520
521
522
523
524
525
526
527
528
529
530
531


532

533
534
535
536
537
538
539


540
541
542
543
544
545
546

547


548










549
550
551
552
553
554
555
...
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
...
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
#	the Safesock security policy.  These procedures use a 
#	callback interface to avoid using vwait, which is not 
#	defined in the safe base.
#
# See the file "license.terms" for information on usage and
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: http.tcl,v 1.28 2000/03/29 20:19:59 sandeep Exp $








package provide http 2.3	;# This uses Tcl namespaces

namespace eval http {
    variable http
    array set http {
	-accept */*
	-proxyhost {}
	-proxyport {}
	-useragent {Tcl http client package 2.2}
	-proxyfilter http::ProxyRequired
    }

    variable formMap
    variable alphanumeric a-zA-Z0-9
    variable c
    variable i 0
................................................................................
	-timeout 	0
	-type           application/x-www-form-urlencoded
	-queryprogress	{}
	state		header
	meta		{}
	currentsize	0
	totalsize	0


        type            text/html
        body            {}
	status		""
	http            ""
    }
    set options {-blocksize -channel -command -handler -headers \
	    -progress -query -queryblocksize -querychannel -queryprogress\
................................................................................
	} else {
	    unset $token
	    return -code error "Unknown option $flag, can be: $usage"
	}
    }

    # Make sure -query and -querychannel aren't both specified

    if {[info exists state(-query)] && [info exists state(-querychannel)]} {


	unset $token
	return -code error "Can't combine -query and -querychannel options!"
    }

    # Set a variable with whether or not we have a querychannel, because
    # we need to do special logic later if it does exist, and we don't
    # want to do a lot of [info exists...]
    set isQueryChannel [info exists state(-querychannel)]
    set isQuery [info exists state(-query)]

    if {![regexp -nocase {^(([^:]*)://)?([^/:]+)(:([0-9]+))?(/.*)?$} $url \
	    x prefix proto host y port srvurl]} {
	unset $token
	error "Unsupported URL: $url"
    }
    if {[string length $proto] == 0} {
................................................................................
    if {[info exists phost] && [string length $phost]} {
	set srvurl $url
	set conStat [catch {eval $defcmd $async {$phost $pport}} s]
    } else {
	set conStat [catch {eval $defcmd $async {$host $port}} s]
    }
    if {$conStat} {

	# something went wrong while trying to establish the connection
	# The proper response is probably to give the caller a token
	# containing error info, but that would break backwards compatibility.
	# So, let's follow tradition and throw an exception (after unsetting
	# the array).

	unset $token
	error $s
	#Finish $token $s
	#return $token
    }
    set state(sock) $s

    # Wait for the connection to complete

    if {$state(-timeout) > 0} {
	fileevent $s writable [list http::Connect $token]
	http::wait $token
	catch {fileevent $s writable {}}
	if {![string equal $state(status) "connect"]} {





	    return $token
	}
	set state(status) ""
    }

    # Send data in cr-lf format, but accept any line terminators

................................................................................
    fconfigure $s -translation {auto crlf} -buffersize $state(-blocksize)

    # The following is disallowed in safe interpreters, but the socket
    # is already in non-blocking mode in that case.

    catch {fconfigure $s -blocking off}
    set how GET
    set state(querylength) 0
    if {$isQuery} {
	set state(querylength) [string length $state(-query)]
	if {$state(querylength) > 0} {
	    set how POST
	    set contDone 0
	} else {
	    # there's no query data
................................................................................
	}
    } elseif {$state(-validate)} {
	set how HEAD
    } elseif {$isQueryChannel} {
	set how POST
	# The query channel must be blocking for the async Write to
	# work properly.
	fconfigure $state(-querychannel) -blocking 1
	set contDone 0
    }

    if {[catch {
	puts $s "$how $srvurl HTTP/1.0"
	puts $s "Accept: $http(-accept)"
	puts $s "Host: $host"
................................................................................
		set contDone 1
		set state(querylength) $value
	    }
	    if {[string length $key]} {
		puts $s "$key: $value"
	    }
	}
	if {$isQueryChannel && $state(querylength)==0} {
	    # Try to determine size of data in channel
	    if {[catch {seek $state(-querychannel) 0 end}]} {
		Finish $token "Unable to determine size of querychannel data"
		return $token
	    }
	    set state(querylength) [tell $state(-querychannel)]
	    seek $state(-querychannel) 0



	}
		
	if {$isQuery || $isQueryChannel} {
	    puts $s "Content-Type: $state(-type)"
	    if {!$contDone} {
		puts $s "Content-Length: $state(querylength)"
	    }
	    puts $s ""
	    fconfigure $s -translation {auto binary}
	    fileevent $s writable [list http::Write $token]
	} else {
	    puts $s ""






	    flush $s
	    fileevent $s readable [list http::Event $token]
	}







    } err]} {
	# The socket probably was never connected, or the connection
	# dropped later.

	reset $token ioerror
	return $token

    }

    if {! [info exists state(-command)]} {
	# geturl does EVERYTHING asynchronously, so if the user
	# calls it synchronously, we just do a wait here.
	wait $token
    }
    return $token
}

# Data access functions:
# Data - the URL data
# Status - the transaction status: ok, reset, eof, timeout
# Code - the HTTP transaction code, e.g., 200
................................................................................
    upvar 0 $token state
    return $state(status)
}
proc http::code {token} {
    variable $token
    upvar 0 $token state
    return $state(http)









}
proc http::size {token} {
    variable $token
    upvar 0 $token state
    return $state(currentsize)
}

................................................................................
    if {[info exist state]} {
	unset state
    }
}

# http::Connect
#
#	Wait for an asynchronous connection to complete
#
# Arguments
#	token	The token returned from http::geturl
#
# Side Effects
#	Sets the status of the connection, which unblocks
# 	the waiting geturl call

 proc http::Connect {token} {
    variable $token
    upvar 0 $token state

    if {[eof $state(sock)] || \
	[string length [fconfigure $state(sock) -error]]} {
	set state(status) ioerror



    } else {
	set state(status) connect
    }

 }

# http::Write
#
#	Write POST query data to the socket
#
# Arguments
................................................................................
#	Write the socket and handle callbacks.

proc http::Write {token} {
    variable $token
    upvar 0 $token state
    set s $state(sock)
    
    if {![info exist state(queryoffset)]} {
	set state(queryoffset) 0
    }
    # Output a block.  Tcl will buffer this if the socket blocks
    
    if {[catch {
	
	# Catch I/O errors on dead sockets


	if {[info exists state(-query)]} {





	    set outStr [string range $state(-query) $state(queryoffset) \
		    [expr {$state(queryoffset) + $state(-queryblocksize) - 1}]]
	    incr state(queryoffset) $state(-queryblocksize)
	} else {
	    # querychannel
	    set outStr [read $state(-querychannel) $state(-queryblocksize)]
	    incr state(queryoffset) $state(-queryblocksize)
	}
	puts -nonewline $s $outStr
	
	if {$state(querylength)>0 && \
		$state(queryoffset) >= $state(querylength)} {
	    set state(queryoffset) $state(querylength)


	}


	if {[string length $state(-queryprogress)]} {
	    eval $state(-queryprogress) [list $token $state(querylength)\
		    $state(queryoffset)]
	}
	
	if {($state(querylength)>0 && \


		$state(queryoffset) >= $state(querylength)) || \
		([info exists state(-querychannel)] && \
		    [eof $state(-querychannel)])} {
	    fileevent $s writable {}
	    flush $s
	    fileevent $s readable [list http::Event $token]
	}

    } err]} {


	Finish $token $err










    }
}

# http::Event
#
#	Handle input on the socket
#
................................................................................
#	Read the socket and handle callbacks.

 proc http::Event {token} {
    variable $token
    upvar 0 $token state
    set s $state(sock)

     if {[::eof $s]} {
	Eof $token
	return
    }
    if {[string equal $state(state) "header"]} {
	if {[catch {gets $s line} n]} {
	    Finish $token $n
	} elseif {$n == 0} {
................................................................................
    incr state(currentsize) $count
    if {[info exists state(-progress)]} {
	eval $state(-progress) {$token $state(totalsize) $state(currentsize)}
    }
    # At this point the token may have been reset
    if {[string length $error]} {
	Finish $token $error
    } elseif {[catch {::eof $s} iseof] || $iseof} {
	Eof $token
    } else {
	CopyStart $s $token
    }
}

# http::Eof






|

>
>
>
>
>
>
>
|







|







 







>
>







 







>
|
>
>




|
<
<
<
<







 







>

<
<
<
<
>
|
<
|
|








<
|
>
>
>
>
>







 







<







 







|







 







|

|
<
<
|
|
|
>
>
>












>
>
>
>
>
>
|
|
|
>
>
>
>
>
>
>

|
|

|
|
>


<
<
<
<
<







 







>
>
>
>
>
>
>
>
>







 







|











>
|
|
|
>
>
>



>







 







<
<
<






>

>
>
>
>
>
|


<
<
<
<
<
<
<
<
|
|
>
>
|
>
|
<
|
<
|
<
<
>
>
|
<
|
<
|
|
|
>

>
>
|
>
>
>
>
>
>
>
>
>
>







 







|







 







|







5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
...
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
...
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272




273
274
275
276
277
278
279
...
319
320
321
322
323
324
325
326
327




328
329

330
331
332
333
334
335
336
337
338
339

340
341
342
343
344
345
346
347
348
349
350
351
352
...
353
354
355
356
357
358
359

360
361
362
363
364
365
366
...
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
...
389
390
391
392
393
394
395
396
397
398


399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441





442
443
444
445
446
447
448
...
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
...
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
...
534
535
536
537
538
539
540



541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556








557
558
559
560
561
562
563

564

565


566
567
568

569

570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
...
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
...
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
#	the Safesock security policy.  These procedures use a 
#	callback interface to avoid using vwait, which is not 
#	defined in the safe base.
#
# See the file "license.terms" for information on usage and
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: http.tcl,v 1.30 2000/04/09 23:56:13 welch Exp $

# Rough version history:
# 1.0	Old http_get interface
# 2.0	http:: namespace and http::geturl
# 2.1	Added callbacks to handle arriving data, and timeouts
# 2.2	Added ability to fetch into a channel
# 2.3	Added SSL support, and ability to post from a channel

package provide http 2.3

namespace eval http {
    variable http
    array set http {
	-accept */*
	-proxyhost {}
	-proxyport {}
	-useragent {Tcl http client package 2.3}
	-proxyfilter http::ProxyRequired
    }

    variable formMap
    variable alphanumeric a-zA-Z0-9
    variable c
    variable i 0
................................................................................
	-timeout 	0
	-type           application/x-www-form-urlencoded
	-queryprogress	{}
	state		header
	meta		{}
	currentsize	0
	totalsize	0
	querylength	0
	queryoffset	0
        type            text/html
        body            {}
	status		""
	http            ""
    }
    set options {-blocksize -channel -command -handler -headers \
	    -progress -query -queryblocksize -querychannel -queryprogress\
................................................................................
	} else {
	    unset $token
	    return -code error "Unknown option $flag, can be: $usage"
	}
    }

    # Make sure -query and -querychannel aren't both specified

    set isQueryChannel [info exists state(-querychannel)]
    set isQuery [info exists state(-query)]
    if {$isQuery && $isQueryChannel} {
	unset $token
	return -code error "Can't combine -query and -querychannel options!"
    }

    # Validate URL, determine the server host and port, and check proxy case





    if {![regexp -nocase {^(([^:]*)://)?([^/:]+)(:([0-9]+))?(/.*)?$} $url \
	    x prefix proto host y port srvurl]} {
	unset $token
	error "Unsupported URL: $url"
    }
    if {[string length $proto] == 0} {
................................................................................
    if {[info exists phost] && [string length $phost]} {
	set srvurl $url
	set conStat [catch {eval $defcmd $async {$phost $pport}} s]
    } else {
	set conStat [catch {eval $defcmd $async {$host $port}} s]
    }
    if {$conStat} {

	# something went wrong while trying to establish the connection





	Finish $token

	cleanup $token
	return -code error $s
    }
    set state(sock) $s

    # Wait for the connection to complete

    if {$state(-timeout) > 0} {
	fileevent $s writable [list http::Connect $token]
	http::wait $token

	if {$state(status) != "connect"} {
	    
	    # Likely to be connection timeout.  If there was a connection
	    # error, (e.g., bad port), then http::wait will have 
	    # raised an error already

	    return $token
	}
	set state(status) ""
    }

    # Send data in cr-lf format, but accept any line terminators

................................................................................
    fconfigure $s -translation {auto crlf} -buffersize $state(-blocksize)

    # The following is disallowed in safe interpreters, but the socket
    # is already in non-blocking mode in that case.

    catch {fconfigure $s -blocking off}
    set how GET

    if {$isQuery} {
	set state(querylength) [string length $state(-query)]
	if {$state(querylength) > 0} {
	    set how POST
	    set contDone 0
	} else {
	    # there's no query data
................................................................................
	}
    } elseif {$state(-validate)} {
	set how HEAD
    } elseif {$isQueryChannel} {
	set how POST
	# The query channel must be blocking for the async Write to
	# work properly.
	fconfigure $state(-querychannel) -blocking 1 -translation binary
	set contDone 0
    }

    if {[catch {
	puts $s "$how $srvurl HTTP/1.0"
	puts $s "Accept: $http(-accept)"
	puts $s "Host: $host"
................................................................................
		set contDone 1
		set state(querylength) $value
	    }
	    if {[string length $key]} {
		puts $s "$key: $value"
	    }
	}
	if {$isQueryChannel && $state(querylength) == 0} {
	    # Try to determine size of data in channel
	    # If we cannot seek, the surrounding catch will trap us



	    set start [tell $state(-querychannel)]
	    seek $state(-querychannel) 0 end
	    set state(querylength) \
		    [expr {[tell $state(-querychannel)] - $start}]
	    seek $state(-querychannel) $start
	}
		
	if {$isQuery || $isQueryChannel} {
	    puts $s "Content-Type: $state(-type)"
	    if {!$contDone} {
		puts $s "Content-Length: $state(querylength)"
	    }
	    puts $s ""
	    fconfigure $s -translation {auto binary}
	    fileevent $s writable [list http::Write $token]
	} else {
	    puts $s ""
	}
	# Set up the read file event here in either case.  This seems to
	# help in the case where the server replies but does not
	# read the query post data, and the server is on the same
	# machine so the loopback interface is being used.

	flush $s
	fileevent $s readable [list http::Event $token]

	if {! [info exists state(-command)]} {

	    # geturl does EVERYTHING asynchronously, so if the user
	    # calls it synchronously, we just do a wait here.

	    wait $token
	}
    } err]} {
	# The socket probably was never connected,
	# or the connection dropped later.

	Finish $token $err
	cleanup $token
	return -code error $err
    }






    return $token
}

# Data access functions:
# Data - the URL data
# Status - the transaction status: ok, reset, eof, timeout
# Code - the HTTP transaction code, e.g., 200
................................................................................
    upvar 0 $token state
    return $state(status)
}
proc http::code {token} {
    variable $token
    upvar 0 $token state
    return $state(http)
}
proc http::ncode {token} {
    variable $token
    upvar 0 $token state
    if {[regexp {[0-9]+} $state(http) numeric_code]} {
	return $numeric_code
    } else {
	return $state(http)
    }
}
proc http::size {token} {
    variable $token
    upvar 0 $token state
    return $state(currentsize)
}

................................................................................
    if {[info exist state]} {
	unset state
    }
}

# http::Connect
#
#	This callback is made when an asyncronous connection completes.
#
# Arguments
#	token	The token returned from http::geturl
#
# Side Effects
#	Sets the status of the connection, which unblocks
# 	the waiting geturl call

 proc http::Connect {token} {
    variable $token
    upvar 0 $token state
    global errorInfo errorCode
    if {[eof $state(sock)] ||
	    [string length [fconfigure $state(sock) -error]]} {
	set state(status) error
	set state(error) [list \
		"connect failed [fconfigure $state(sock) -error]" \
		$errorInfo $errorCode]
    } else {
	set state(status) connect
    }
    fileevent $state(sock) writable {}
 }

# http::Write
#
#	Write POST query data to the socket
#
# Arguments
................................................................................
#	Write the socket and handle callbacks.

proc http::Write {token} {
    variable $token
    upvar 0 $token state
    set s $state(sock)
    



    # Output a block.  Tcl will buffer this if the socket blocks
    
    if {[catch {
	
	# Catch I/O errors on dead sockets

	set done 0
	if {[info exists state(-query)]} {
	    
	    # Chop up large query strings so queryprogress callback
	    # can give smooth feedback

	    puts -nonewline $s \
		    [string range $state(-query) $state(queryoffset) \
		    [expr {$state(queryoffset) + $state(-queryblocksize) - 1}]]
	    incr state(queryoffset) $state(-queryblocksize)








	    if {$state(queryoffset) >= $state(querylength)} {
		set state(queryoffset) $state(querylength)
		flush $s
		fileevent $s writable {}
	    }
	} else {
	    

	    # Copy blocks from the query channel




	    set outStr [read $state(-querychannel) $state(-queryblocksize)]
	    puts -nonewline $s $outStr
	    incr state(queryoffset) [string length $outStr]

	    if {[eof $state(-querychannel)]} {

		flush $s
		fileevent $s writable {}
	    }
	}
    } err]} {
	# Do not call Finish here, but instead let the read half of
	# the socket process whatever server reply there is to get.
	# Simply turn off this write process

	set state(posterror) $err
	fileevent $s writable {}
    }

    # Callback to the client after we've completely handled everything

    if {[string length $state(-queryprogress)]} {
	eval $state(-queryprogress) [list $token $state(querylength)\
		$state(queryoffset)]
    }
}

# http::Event
#
#	Handle input on the socket
#
................................................................................
#	Read the socket and handle callbacks.

 proc http::Event {token} {
    variable $token
    upvar 0 $token state
    set s $state(sock)

     if {[eof $s]} {
	Eof $token
	return
    }
    if {[string equal $state(state) "header"]} {
	if {[catch {gets $s line} n]} {
	    Finish $token $n
	} elseif {$n == 0} {
................................................................................
    incr state(currentsize) $count
    if {[info exists state(-progress)]} {
	eval $state(-progress) {$token $state(totalsize) $state(currentsize)}
    }
    # At this point the token may have been reset
    if {[string length $error]} {
	Finish $token $error
    } elseif {[catch {eof $s} iseof] || $iseof} {
	Eof $token
    } else {
	CopyStart $s $token
    }
}

# http::Eof