Check-in [f1d6d9f8d9]
Not logged in

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

Overview
Comment:Unify all synchronous calls to http::geturl with error handling by utility function geturl_followRedirects
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:f1d6d9f8d981e369b1b4b5a0cdf2ed51530f3d40
User & Date: oehhar 2016-03-03 21:09:40
Context
2016-10-31 15:46
Load and register tls only if no https handler was registered before check-in: 2e7e8c373f user: oehhar tags: trunk
2016-03-03 21:09
Unify all synchronous calls to http::geturl with error handling by utility function geturl_followRedirects check-in: f1d6d9f8d9 user: oehhar tags: trunk
2015-11-09 17:25
Unify all synchronous calls to http::geturl with error handling by utility function geturl_followRedirects Closed-Leaf check-in: 0f7ac08844 user: oehhar tags: unify_http::geturl
2015-11-09 16:24
restore deleted debug line check-in: c7cdb73c8f user: oehhar tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to ClientSide.tcl.

49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
...
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
...
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
....
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
....
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437

1438
1439
1440
1441
1442
1443
1444
....
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
....
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
....
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381


3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
if {[catch {
    package require tls
    http::register https 443 [list ::tls::socket -ssl2 no -ssl3 no -tls1 yes]
} err]} {
    log::log warning "No https support: $err"
}

package provide WS::Client 2.3.8

namespace eval ::WS::Client {
    ##
    ## serviceArr is indexed by service name and contains a dictionary that
    ## defines the service.  The dictionary has the following structure:
    ##   targetNamespace - the target namespace
    ##   operList - list of operations
................................................................................
        file {
            upvar #0 [::uri::geturl $url] token
            set xml $token(data)
            unset token
        }
        http -
        https {
            set token [::http::geturl $url]
            ::http::wait $token
            set ncode [::http::ncode $token]
            set xml [::http::data $token]
            ::http::cleanup $token
            if {$ncode != 200} {
                return \
                    -code error \
                    -errorcode [list WS CLIENT HTTPFAIL $url] \
                    "HTTP get of import file failed '$url'"
            }
        }
        default {
            return \
                -code error \
                -errorcode [list WS CLIENT UNKURLTYP $url] \
                "Unknown URL type '$url'"
        }
................................................................................
            upvar #0 [::uri::geturl $url] token
            set wsdlInfo [ParseWsdl $token(data) -headers $headers -serviceAlias $serviceAlias]
            unset token
        }
        http -
        https {
            if {[llength $headers]} {
                set token [::WS::Utils::geturl_followRedirects $url -headers $headers]
            } else {
                set token [::WS::Utils::geturl_followRedirects $url]
            }
            ::http::wait $token
            if {![string equal [::http::status $token] ok] ||
                [::http::ncode $token] != 200} {
                set errorCode [list WS CLIENT HTTPERROR [::http::code $token]]
                set errorInfo [FormatHTTPError $token]
                ::http::cleanup $token
                return \
                    -code error \
                    -errorcode $errorCode \
                    $errorInfo
            }
            set wsdlInfo [ParseWsdl [::http::data $token] -headers $headers -serviceAlias $serviceAlias]
            ::http::cleanup $token
        }
        default {
            return \
                -code error \
                -errorcode [list WS CLIENT UNKURLTYP $url] \
                "Unknown URL type '$url'"
        }
................................................................................
    if {[dict exists $serviceInfo headers]} {
        set headers [concat $headers [dict get $serviceInfo headers]]
    }
    if {[dict exists $serviceInfo operation $operationName action]} {
        lappend headers  SOAPAction [format {"%s"} [dict get $serviceInfo operation $operationName action]]
    }
    if {[llength $headers]} {
        ::log::log info [list ::http::geturl $url -query $query -type [dict get $serviceInfo contentType] -headers $headers]
        set token [::http::geturl $url -query $query -type [dict get $serviceInfo contentType] -headers $headers]
    } else {
        ::log::log info [::http::geturl $url -query $query -type [dict get $serviceInfo contentType]]
        set token [::http::geturl $url -query $query -type [dict get $serviceInfo contentType]]
    }
    ::http::wait $token

    ##
    ## Check for errors
    ##
    set body [::http::data $token]
    ::log::log info "\nReceived: $body"
    if {![string equal [::http::status $token] ok] ||
        ([::http::ncode $token] != 200 && [string equal $body {}])} {
        set errorCode [list WS CLIENT HTTPERROR [::http::code $token]]
        set errorInfo {}
        set results [FormatHTTPError $token]
        set hadError 1
    } else {
        set hadError 0
        set results [::http::data $token]
    }
    ::http::cleanup $token
    if {$hadError} {
        ::log::log debug "Leaving (error) ::WS::Client::DoRawCall"
        return \
            -code error \
            -errorcode $errorCode \
            -errorinfo $errorInfo \
            $results
    } else {
        ::log::log debug "Leaving ::WS::Client::DoRawCall with {$results}"
        return $results
    }

}

###########################################################################
#
# Public Procedure Header - as this procedure is modified, please be sure
#                           that you update this header block. Thanks.
#
................................................................................
    if {[dict exists $serviceInfo headers]} {
        set headers [concat $headers [dict get $serviceInfo headers]]
    }
    if {[dict exists $serviceInfo operation $operationName action]} {
        lappend headers  SOAPAction [format {"%s"} [dict get $serviceInfo operation $operationName action]]
    }
    if {[llength $headers]} {
        ::log::log info [list ::http::geturl $url -query $query -type [dict get $serviceInfo contentType] -headers $headers]
        set token [::http::geturl $url -query $query -type [dict get $serviceInfo contentType] -headers $headers]
    } else {
        ::log::log info  [list ::http::geturl $url -query $query -type [dict get $serviceInfo contentType]  ]
        set token [::http::geturl $url -query $query -type [dict get $serviceInfo contentType] ]
    }
    ::http::wait $token

    ##
    ## Check for errors
    ##
    set httpStatus [::http::status $token]
    if {[string equal $httpStatus ok] && [::http::ncode $token] == 500} {
        set body [::http::data $token]
        ::log::log debug "\tReceived: $body"
        set outTransform [dict get $serviceInfo outTransform]
        if {![string equal $outTransform {}]} {
            SaveAndSetOptions $serviceName
            catch {set body [$outTransform $serviceName $operationName REPLY $body]}
            RestoreSavedOptions $serviceName
        }

        set hadError [catch {parseResults $serviceName $operationName $body} results]
        if {$hadError} {
            lassign $::errorCode mainError subError
            if {[string equal $mainError WSCLIENT] && [string equal $subError NOSOAP]} {
                ::log::log debug "\tHTTP error $body"
                set results $body
                set errorCode [list WSCLIENT HTTPERROR $body]
................................................................................
                set hadError 1
            } else {
                ::log::log debug "Reply was $body"
                set errorCode $::errorCode
                set errorInfo $::errorInfo
            }
        }
    } elseif {![string equal $httpStatus ok] || [::http::ncode $token] != 200} {
        ::log::log debug "\tHTTP error [array get $token]"
        set results [FormatHTTPError $token]
        set errorCode [list WSCLIENT HTTPERROR [::http::code $token]]
        set errorInfo {}
        set hadError 1
    } else {
        set body [::http::data $token]
        ::log::log debug "\tReceived: $body"
        set outTransform [dict get $serviceInfo outTransform]
        if {![string equal $outTransform {}]} {
            SaveAndSetOptions $serviceName
            catch {set body [$outTransform $serviceName $operationName REPLY $body]}
            RestoreSavedOptions $serviceName
        }
        SaveAndSetOptions $serviceName
        catch {set hadError [catch {parseResults $serviceName $operationName $body} results]}
        RestoreSavedOptions $serviceName
        if {$hadError} {
            ::log::log debug "Reply was $body"
            set errorCode $::errorCode
            set errorInfo $::errorInfo
        }
    }
    ::http::cleanup $token
    if {$hadError} {
        ::log::log debug "Leaving (error) ::WS::Client::DoCall"
        return \
            -code error \
            -errorcode $errorCode \
            -errorinfo $errorInfo \
            $results
................................................................................
    } else {
        RestoreSavedOptions $serviceName
    }
    if {[dict exists $serviceInfo headers]} {
        set headers [concat $headers [dict get $serviceInfo headers]]
    }
    if {[llength $headers]} {
        ::log::log info [list ::http::geturl $url -query $query -type [dict get $serviceInfo contentType] -headers $headers]
        set token [::http::geturl $url -query $query -type [dict get $serviceInfo contentType] -headers $headers]
    } else {
        ::log::log [list ::http::geturl $url -query $query -type [dict get $serviceInfo contentType]]
        set token [::http::geturl $url -query $query -type [dict get $serviceInfo contentType]]
    }
    ::http::wait $token

    ##
    ## Check for errors
    ##
    set body [::http::data $token]
    if {![string equal [::http::status $token] ok] ||
        ([::http::ncode $token] != 200 && [string equal $body {}])} {
        set errorCode [list WS CLIENT HTTPERROR [::http::code $token]]
        set errorInfo {}
        set results [FormatHTTPError $token]
        set hadError 1
    } else {
        set hadError 0
        set results [::http::data $token]
    }
    ::http::cleanup $token
    if {$hadError} {
        ::log::log debug "Leaving (error) ::WS::Client::DoRawRestCall"
        return \
            -code error \
            -errorcode $errorCode \
            -errorinfo $errorInfo \
            $results
    } else {
        ::log::log debug "Leaving ::WS::Client::DoRawRestCall with {$results}"
        return $results
    }

}

###########################################################################
#
# Public Procedure Header - as this procedure is modified, please be sure
#                           that you update this header block. Thanks.
#
................................................................................
    } else {
        RestoreSavedOptions $serviceName
    }
    if {[dict exists $serviceInfo headers]} {
        set headers [concat $headers [dict get $serviceInfo headers]]
    }
    if {[llength $headers]} {
        ::log::log info [list ::http::geturl $url -query $query -type [dict get $serviceInfo contentType] -headers $headers]
        set token [::http::geturl $url -query $query -type [dict get $serviceInfo contentType] -headers $headers]
    } else {
        ::log::log info [list::http::geturl $url -query $query -type [dict get $serviceInfo contentType]]
        set token [::http::geturl $url -query $query -type [dict get $serviceInfo contentType]]
    }
    ::http::wait $token

    ##
    ## Check for errors
    ##
    set body [::http::data $token]
    ::log::log info "\tReceived: $body"
    set httpStatus [::http::status $token]
    set hadError 0
    set results {}
    if {![string equal $httpStatus ok] ||
        ([::http::ncode $token] != 200 && [string equal $body {}])} {
        ::log::log debug "\tHTTP error [array get $token]"
        set results [FormatHTTPError $token]
        set errorCode [list WS CLIENT HTTPERROR [::http::code $token]]
        set errorInfo {}
        set hadError 1
    } else {
        SaveAndSetOptions $serviceName
        if {[catch {set hadError [catch {parseRestResults $serviceName $objectName $operationName $body} results]} err]} {
            RestoreSavedOptions $serviceName
            return -code error -errorcode $::errorCode -errorinfo $::errorInfo $err
        } else {
            RestoreSavedOptions $serviceName
        }
        if {$hadError} {
            ::log::log debug "Reply was [::http::data $token]"
            set errorCode $::errorCode
            set errorInfo $::errorInfo
        }
    }
    ::http::cleanup $token
    if {$hadError} {
        ::log::log debug "Leaving (error) ::WS::Client::DoRestCall"
        return \
            -code error \
            -errorcode $errorCode \
            -errorinfo $errorInfo \
            $results
    } else {


        ::log::log debug "Leaving ::WS::Client::DoRestCall with {$results}"
        return $results
    }

}

###########################################################################
#
# Public Procedure Header - as this procedure is modified, please be sure
#                           that you update this header block. Thanks.
#







|







 







|
<
<
<
<
<
<
<
<
<
<







 







|

|

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







 







|
|

|
|

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







 







<
|

<
|

<




<
<
<
<
|
|
|
|
|
|
>







 







<
<
<
<
<
<

<
<
<
<
<
<
<
<









<







 







|
|

|
|

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







 







|
|

|
|

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

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







49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
...
526
527
528
529
530
531
532
533










534
535
536
537
538
539
540
...
905
906
907
908
909
910
911
912
913
914
915











916

917
918
919
920
921
922
923
....
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275


























1276
1277


1278
1279
1280
1281
1282
1283
1284
....
1360
1361
1362
1363
1364
1365
1366

1367
1368

1369
1370

1371
1372
1373
1374




1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
....
1390
1391
1392
1393
1394
1395
1396






1397








1398
1399
1400
1401
1402
1403
1404
1405
1406

1407
1408
1409
1410
1411
1412
1413
....
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145

























3146
3147


3148
3149
3150
3151
3152
3153
3154
....
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243


















3244
3245






3246






3247

3248




3249
3250
3251
3252


3253
3254
3255
3256
3257
3258
3259
if {[catch {
    package require tls
    http::register https 443 [list ::tls::socket -ssl2 no -ssl3 no -tls1 yes]
} err]} {
    log::log warning "No https support: $err"
}

package provide WS::Client 2.3.9

namespace eval ::WS::Client {
    ##
    ## serviceArr is indexed by service name and contains a dictionary that
    ## defines the service.  The dictionary has the following structure:
    ##   targetNamespace - the target namespace
    ##   operList - list of operations
................................................................................
        file {
            upvar #0 [::uri::geturl $url] token
            set xml $token(data)
            unset token
        }
        http -
        https {
            set xml [::WS::Utils::geturl_fetchbody $url]










        }
        default {
            return \
                -code error \
                -errorcode [list WS CLIENT UNKURLTYP $url] \
                "Unknown URL type '$url'"
        }
................................................................................
            upvar #0 [::uri::geturl $url] token
            set wsdlInfo [ParseWsdl $token(data) -headers $headers -serviceAlias $serviceAlias]
            unset token
        }
        http -
        https {
            if {[llength $headers]} {
                set body [::WS::Utils::geturl_fetchbody $url -headers $headers]
            } else {
                set body [::WS::Utils::geturl_fetchbody $url]
            }











            set wsdlInfo [ParseWsdl $body -headers $headers -serviceAlias $serviceAlias]

        }
        default {
            return \
                -code error \
                -errorcode [list WS CLIENT UNKURLTYP $url] \
                "Unknown URL type '$url'"
        }
................................................................................
    if {[dict exists $serviceInfo headers]} {
        set headers [concat $headers [dict get $serviceInfo headers]]
    }
    if {[dict exists $serviceInfo operation $operationName action]} {
        lappend headers  SOAPAction [format {"%s"} [dict get $serviceInfo operation $operationName action]]
    }
    if {[llength $headers]} {
        set body [::WS::Utils::geturl_fetchbody -bodyalwaysok 1\
            $url -query $query -type [dict get $serviceInfo contentType] -headers $headers]
    } else {
        set body [::WS::Utils::geturl_fetchbody -bodyalwaysok 1\
            $url -query $query -type [dict get $serviceInfo contentType]]
    }


























    ::log::log debug "Leaving ::WS::Client::DoRawCall with {$body}"
    return $body


}

###########################################################################
#
# Public Procedure Header - as this procedure is modified, please be sure
#                           that you update this header block. Thanks.
#
................................................................................
    if {[dict exists $serviceInfo headers]} {
        set headers [concat $headers [dict get $serviceInfo headers]]
    }
    if {[dict exists $serviceInfo operation $operationName action]} {
        lappend headers  SOAPAction [format {"%s"} [dict get $serviceInfo operation $operationName action]]
    }
    if {[llength $headers]} {

        set body [::WS::Utils::geturl_fetchbody -codeok {200 500} -codevar ncode $url -query $query -type [dict get $serviceInfo contentType] -headers $headers]
    } else {

        set token [::WS::Utils::geturl_fetchbody -codeok {200 500} -codevar ncode $url -query $query -type [dict get $serviceInfo contentType] ]
    }


    ##
    ## Check for errors
    ##




    set outTransform [dict get $serviceInfo outTransform]
    if {![string equal $outTransform {}]} {
        SaveAndSetOptions $serviceName
        catch {set body [$outTransform $serviceName $operationName REPLY $body]}
        RestoreSavedOptions $serviceName
    }
    if { $ncode == 500} {
        set hadError [catch {parseResults $serviceName $operationName $body} results]
        if {$hadError} {
            lassign $::errorCode mainError subError
            if {[string equal $mainError WSCLIENT] && [string equal $subError NOSOAP]} {
                ::log::log debug "\tHTTP error $body"
                set results $body
                set errorCode [list WSCLIENT HTTPERROR $body]
................................................................................
                set hadError 1
            } else {
                ::log::log debug "Reply was $body"
                set errorCode $::errorCode
                set errorInfo $::errorInfo
            }
        }






    } else {








        SaveAndSetOptions $serviceName
        catch {set hadError [catch {parseResults $serviceName $operationName $body} results]}
        RestoreSavedOptions $serviceName
        if {$hadError} {
            ::log::log debug "Reply was $body"
            set errorCode $::errorCode
            set errorInfo $::errorInfo
        }
    }

    if {$hadError} {
        ::log::log debug "Leaving (error) ::WS::Client::DoCall"
        return \
            -code error \
            -errorcode $errorCode \
            -errorinfo $errorInfo \
            $results
................................................................................
    } else {
        RestoreSavedOptions $serviceName
    }
    if {[dict exists $serviceInfo headers]} {
        set headers [concat $headers [dict get $serviceInfo headers]]
    }
    if {[llength $headers]} {
        set body [geturl_fetchbody -bodyalwaysok 1\
            $url -query $query -type [dict get $serviceInfo contentType] -headers $headers]
    } else {
        set body [geturl_fetchbody -bodyalwaysok 1\
            $url -query $query -type [dict get $serviceInfo contentType]]
    }

























    ::log::log debug "Leaving ::WS::Client::DoRawRestCall with {$body}"
    return $body


}

###########################################################################
#
# Public Procedure Header - as this procedure is modified, please be sure
#                           that you update this header block. Thanks.
#
................................................................................
    } else {
        RestoreSavedOptions $serviceName
    }
    if {[dict exists $serviceInfo headers]} {
        set headers [concat $headers [dict get $serviceInfo headers]]
    }
    if {[llength $headers]} {
        set body [geturl_fetchbody -bodyalwaysok 1\
            $url -query $query -type [dict get $serviceInfo contentType] -headers $headers]
    } else {
        set body [geturl_fetchbody -bodyalwaysok 1\
            $url -query $query -type [dict get $serviceInfo contentType]]
    }


















    SaveAndSetOptions $serviceName
    if {[catch {parseRestResults $serviceName $objectName $operationName $body} results]} {






        ::log::log debug "Reply was $body"






        ::log::log debug "Leaving (error) ::WS::Client::DoRestCall"

        return -code error $results




    }
    RestoreSavedOptions $serviceName
    ::log::log debug "Leaving ::WS::Client::DoRestCall with {$results}"
    return $results


}

###########################################################################
#
# Public Procedure Header - as this procedure is modified, please be sure
#                           that you update this header block. Thanks.
#

Changes to Utilities.tcl.

4614
4615
4616
4617
4618
4619
4620

4621
4622



























































































        }
        # problem w/ relative versus absolute paths
        set url [eval ::uri::join [array get uri]]
        ::log::log debug "url = $url"
        set finalUrl $url
    }
    # > 5 redirects reached -> exit with error

    return -code error "http redirect limit exceeded"
}


































































































>
|

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
4614
4615
4616
4617
4618
4619
4620
4621
4622
4623
4624
4625
4626
4627
4628
4629
4630
4631
4632
4633
4634
4635
4636
4637
4638
4639
4640
4641
4642
4643
4644
4645
4646
4647
4648
4649
4650
4651
4652
4653
4654
4655
4656
4657
4658
4659
4660
4661
4662
4663
4664
4665
4666
4667
4668
4669
4670
4671
4672
4673
4674
4675
4676
4677
4678
4679
4680
4681
4682
4683
4684
4685
4686
4687
4688
4689
4690
4691
4692
4693
4694
4695
4696
4697
4698
4699
4700
4701
4702
4703
4704
4705
4706
4707
4708
4709
4710
4711
4712
4713
4714
        }
        # problem w/ relative versus absolute paths
        set url [eval ::uri::join [array get uri]]
        ::log::log debug "url = $url"
        set finalUrl $url
    }
    # > 5 redirects reached -> exit with error
    return -errorcode [list WS CLIENT REDIRECTLIMIT $url]\
            -code error "http redirect limit exceeded for $url"
}
###########################################################################
#
# Private Procedure Header - as this procedure is modified, please be sure
#                           that you update this header block. Thanks.
#
#>>BEGIN PRIVATE<<
#
# Procedure Name : ::WS::Utils::geturl_fetchbody
#
# Description : fetch via http following redirects and return data or error
#
# Arguments :
#       ?-codeok list? - list of acceptable http codes.
#                       If not given, 200 is used
#       ?-codevar varname ? - Uplevel variable name to return current code
#                       value.
#       ?-bodyalwaysok bool? - If a body is delivered any ncode is ok
#       url        - target document url
#       args       - additional argument list to http::geturl call
#
# Returns :     fetched data
#
# Side-Effects :        None
#
# Exception Conditions :        None
#
# Pre-requisite Conditions :    None
#
# Original Author : Harald Oehlmann
#
#>>END PRIVATE<<
#
# Maintenance History - as this file is modified, please be sure that you
#                       update this segment of the file header block by
#                       adding a complete entry at the bottom of the list.
#
# Version     Date     Programmer   Comments / Changes / Reasons
# -------  ----------  ----------   -------------------------------------------
#       1  11/08/2015  H.Oehlmann   Initial version
#
###########################################################################
proc ::WS::Utils::geturl_fetchbody {args} {
    set codeOkList {200}
    set codeVar ""
    set bodyAlwaysOk 0
    ::log::log info [concat ::WS::Utils::geturl_fetchbody $args]
    if {[lindex $args 0] eq "-codeok"} {
        set codeOkList [lindex $args 1]
        set args [lrange $args 2 end]
    }
    if {[lindex $args 0] eq "-codevar"} {
        set codeVar [lindex $args 1]
        set args [lrange $args 2 end]
    }
    if {[lindex $args 0] eq "-bodyalwaysok"} {
        set bodyAlwaysOk [lindex $args 1]
        set args [lrange $args 2 end]
    }
    
    set token [eval ::WS::Utils::geturl_followRedirects $args]
    ::http::wait $token
    if {[string equal [::http::status $token] ok]} {
        if {[::http::size $token] == 0} {
            ::log::log debug "\tHTTP error: no data"
            ::http::cleanup $token
            return -errorcode [list WS CLIENT NODATA [lindex $args 0]]\
                    -code error "HTTP failure socket closed"
        }
        if {![string equal $codeVar ""]} {
            upvar 1 $codeVar ncode
        }
        set ncode [::http::ncode $token]
        set body [::http::data $token]
        ::http::cleanup $token
        if {$bodyAlwaysOk && ![string equal $body ""]
            || -1 != [lsearch $codeOkList $ncode]
        } {
            # >> Fetch ok
            ::log::log debug "\tReceived: $body"
            return $body
        }
        ::log::log debug "\tHTTP error: Wrong code $ncode or no data"
        return -code error -errorcode [list WS CLIENT HTTPERROR $ncode]\
                "HTTP failure code $ncode"
    }
    ::log::log debug "\tHTTP error [array get $token]"
    set error [::http::error $token]
    ::http::cleanup $token
    return -errorcode [list WS CLIENT HTTPERROR $error]\
            -code error "HTTP error: $error"
}

Changes to pkgIndex.tcl.

4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

package ifneeded WS::Client 2.3.8  [list source [file join $dir ClientSide.tcl]]
package ifneeded WS::Server 2.3.7  [list source [file join $dir ServerSide.tcl]]
package ifneeded WS::Utils 2.3.10 [list source [file join $dir Utilities.tcl]]

package ifneeded WS::Embeded 2.3.0 [list source [file join $dir Embedded.tcl]]
package ifneeded WS::AOLserver 2.0.0 [list source [file join $dir AOLserver.tcl]]
package ifneeded WS::Channel 2.0.0 [list source [file join $dir ChannelServer.tcl]]

package ifneeded WS::Wub 2.2.1 [list source [file join $dir WubServer.tcl]]
package ifneeded Wsdl 2.0.0 [list source [file join $dir WubServer.tcl]]

package ifneeded WS::CheckAndBuild 0.0.3 [list source [file join $dir CheckAndBuild.tcl]]







|











4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

package ifneeded WS::Client 2.3.9  [list source [file join $dir ClientSide.tcl]]
package ifneeded WS::Server 2.3.7  [list source [file join $dir ServerSide.tcl]]
package ifneeded WS::Utils 2.3.10 [list source [file join $dir Utilities.tcl]]

package ifneeded WS::Embeded 2.3.0 [list source [file join $dir Embedded.tcl]]
package ifneeded WS::AOLserver 2.0.0 [list source [file join $dir AOLserver.tcl]]
package ifneeded WS::Channel 2.0.0 [list source [file join $dir ChannelServer.tcl]]

package ifneeded WS::Wub 2.2.1 [list source [file join $dir WubServer.tcl]]
package ifneeded Wsdl 2.0.0 [list source [file join $dir WubServer.tcl]]

package ifneeded WS::CheckAndBuild 0.0.3 [list source [file join $dir CheckAndBuild.tcl]]