︙ | | |
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
|
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
|
-
+
+
+
+
+
+
+
|
unset -nocomplain pkgr_path
}
#
# NOTE: This procedure is used to provide a TIP #194 compatible [apply]
# command to the native Tcl 8.4 interpreter. Eagle and native Tcl
# 8.5 (or higher) have this command built-in.
# 8.5 (or higher) have this command built-in. The lambdaExpr
# argument must be a list with two or three elements. The first
# element is the list of arguments to the procedure. The second
# element is the body of the procedure. The third element is the
# target namespace for the procedure. If the third element is not
# specified, the global namespace is used. Any remaining arguments
# are passed to the procedure verbatim.
#
if {[llength [info commands ::apply]] == 0} then {
proc ::apply { lambdaExpr args } {
set length [llength $lambdaExpr]
if {$length < 2 || $length > 3} {
error [appendArgs \
|
︙ | | |
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
|
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
|
-
+
+
+
|
return [uplevel 1 [list $procName] $args]
}
}
#
# NOTE: This procedure returns a formatted, possibly version-specific,
# package name, for use in logging.
# package name, for use in logging. The package argument is the
# name of the package. The version argument is the version of the
# package.
#
proc formatPackageName { package version } {
return [string trim [appendArgs $package " " $version]]
}
#
# NOTE: This procedure returns a formatted script result. If the string
|
︙ | | |
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
|
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
|
-
+
+
+
-
+
-
+
+
+
-
+
+
|
}
#
# NOTE: This procedure returns the list of API keys to use when looking
# up packages via the package repository server. An empty list
# is returned if no API keys are currently configured. The prefix
# argument is an extra variable name prefix to check prior to any
# that are already configured.
# that are already configured. The prefixOnly argument should be
# non-zero to exclude any API keys other than those based on the
# prefix specified by the caller.
#
# <internal>
proc getApiKeys { {prefix ""} } {
proc getApiKeys { {prefix ""} {prefixOnly false} } {
global env
variable autoApiKeys
#
# NOTE: If the caller specified a variable name prefix, try to use it
# first.
#
set prefixes [list]
if {[string length $prefix] > 0} then {
lappend prefixes $prefix
}
#
# NOTE: Next, fallback to the variable name prefix for this package.
# NOTE: Next, fallback to the variable name prefix for this package,
# unless the caller has forbidden us to do so.
#
if {!$prefixOnly} then {
lappend prefixes [getLookupVarNamePrefix]
lappend prefixes [getLookupVarNamePrefix]
}
#
# NOTE: Try each variable name prefix, in order, until a set of API
# keys is found.
#
foreach prefix $prefixes {
#
|
︙ | | |
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
|
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
|
-
+
+
+
-
+
|
if {[info exists env($varName)]} then {
return $env($varName)
}
}
#
# NOTE: If there is a default list of API keys, just return it.
# NOTE: If there is a default list of API keys, just return it,
# unless the caller has forbidden us to do so.
#
if {!$prefixOnly && \
if {[info exists autoApiKeys] && [llength $autoApiKeys] > 0} then {
[info exists autoApiKeys] && [llength $autoApiKeys] > 0} then {
return $autoApiKeys
}
#
# NOTE: Otherwise, return the system default, which is "anonymous"
# packages only (i.e. those without any owners).
#
|
︙ | | |
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
|
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
|
-
+
|
set metadata(certificate) $certificate
}
}
#
# NOTE: This procedure, which may only be used from an Eagle script, checks
# if a native Tcl library is loaded and ready. If not, a script error
# is raised.
# is raised. There are no arguments.
#
proc tclMustBeReady {} {
#
# NOTE: This procedure is useless when running in native Tcl; therefore,
# forbid its use there.
#
if {![isEagle]} then {
|
︙ | | |
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
|
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
|
-
+
|
error "cannot use Tcl language, supporting library is not loaded"
}
}
#
# NOTE: This procedure is designed for Eagle. It attempts to load the
# "best" native Tcl library. It may raise any number of script
# errors.
# errors. There are no arguments.
#
proc makeTclReady {} {
#
# NOTE: This procedure is useless when running in native Tcl; therefore,
# forbid its use there.
#
if {![isEagle]} then {
|
︙ | | |
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
|
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
|
-
+
|
#
tclMustBeReady
}
#
# NOTE: This procedure, which may only be used from a native Tcl script,
# checks if Garuda and Eagle are loaded and ready. If not, a script
# error is raised.
# error is raised. There are no arguments.
#
proc eagleMustBeReady {} {
#
# NOTE: This procedure is useless when running in Eagle; therefore,
# forbid its use there.
#
if {[isEagle]} then {
|
︙ | | |
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
|
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
|
-
+
|
error "cannot use Eagle language, supporting package is not loaded"
}
}
#
# NOTE: This procedure is designed for native Tcl. It attempts to load
# the Garuda package and gain access to Eagle. It may raise any
# number of script errors.
# number of script errors. There are no arguments.
#
proc makeEagleReady {} {
#
# NOTE: This procedure is useless when running in Eagle; therefore,
# forbid its use there.
#
if {[isEagle]} then {
|
︙ | | |
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
|
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
}
}
} else {
error "unsupported script certificate"
}
}
#
# NOTE: This procedure returns non-zero if the specified package can be
# downloaded, i.e. because it is not required for the downloading
# process itself to be functional, etc. The package argument is
# the name of the package to check.
#
proc canDownloadPackage { package } {
#
# NOTE: Since the "http" and "tls" packages are required from within
# the custom [package unknown] itself, in order to locate and
# download the requested package, we must return false here to
# prevent needless recursion.
#
if {[lsearch -exact [list http tls] $package] != -1} then {
return false
}
#
# NOTE: Currently, all other packages, including Garuda, are legal to
# handle from the custom [package unknown] handler.
#
return true
}
#
# NOTE: This procedure performs initial setup of the package repository
# client, using the current configuration parameters. There are
# no arguments. It may load the Garuda package when evaluated in
# native Tcl. It may load a native Tcl library when evaluated in
# Eagle. It may install the [package unknown] hook.
#
|
︙ | | |
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
|
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
|
+
-
-
-
+
+
+
-
-
-
-
+
+
+
+
+
|
#
proc packageUnknownHandler { package {version ""} } {
variable verboseUnknownResult
#
# NOTE: First, run our special [package unknown] handler.
#
if {[canDownloadPackage $package]} then {
set code(1) [catch {
getPackageFromRepository $package $version handler
} result(1)]
set code(1) [catch {
getPackageFromRepository $package $version handler
} result(1)]
if {$verboseUnknownResult} then {
pkgLog [appendArgs \
"repository handler results for package \"" [formatPackageName \
$package $version] "\" are " [formatResult $code(1) $result(1)]]
if {$verboseUnknownResult} then {
pkgLog [appendArgs \
"repository handler results for package \"" [formatPackageName \
$package $version] "\" are " [formatResult $code(1) $result(1)]]
}
}
#
# NOTE: Next, run the saved [package unknown] handler.
#
set code(2) [catch {
runSavedPackageUnknownHandler $package $version
|
︙ | | |
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
|
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
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
#
# NOTE: This procedure sets up the default values for all configuration
# parameters used by the package repository client. There are no
# arguments.
#
proc setupPackageUnknownVars {} {
#
# NOTE: Is this HTTP request processor allowed to use plain HTTP if/when
# the "tls" package is not available? This should only be changed
# if the "tls" package cannot be easily installed for use with the
# native Tcl interpreter in use. It should be noted here that the
# official package repository server reserves the right to refuse
# plain HTTP connections, which means that changing this setting
# may be totally pointless.
#
variable allowInsecureHttp; # DEFAULT: false
if {![info exists allowInsecureHttp]} then {
set allowInsecureHttp false
}
#
# NOTE: What is the default set of API keys if none were set explicitly?
# This list is subject to change at any time -AND- may be empty or
# may contain non-working API keys, please do not rely on it.
#
variable autoApiKeys; # DEFAULT: 0000000000000000000000000000000000000000
|
︙ | | |
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
|
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
|
+
+
+
+
+
+
-
+
+
+
+
+
+
|
# designed to process a single HTTP request, including any HTTP
# 3XX redirects (up to the specified limit), and return the raw
# HTTP response data. It does not contain special code to handle
# HTTP status codes other than 3XX (e.g. 4XX, 5XX, etc).
#
# <public>
proc getFileViaHttp { uri redirectLimit channel quiet args } {
#
# NOTE: This variable is used to determine if plain HTTP is allowed if
# the "tls" package is not available.
#
variable allowInsecureHttp
#
# NOTE: This variable is used to keep track of the currently scheduled
# (i.e. pending) [after] event.
#
variable afterForPageProgress
#
# NOTE: This procedure requires the modern version of the HTTP package,
# which is typically included with the Tcl core distribution.
#
package require http 2.0
#
# NOTE: If the 'tls' package is available, always attempt to use HTTPS.
# NOTE: If the 'tls' package is available, always attempt to use HTTPS;
# otherwise, only attempt to use HTTP if explicitly allowed.
#
if {[catch {package require tls}] == 0} then {
::http::register https 443 ::tls::socket
if {[string range $uri 0 6] eq "http://"} then {
set uri [appendArgs https:// [string range $uri 7 end]]
}
} elseif {$allowInsecureHttp} then {
if {[string range $uri 0 7] eq "https://"} then {
set uri [appendArgs http:// [string range $uri 8 end]]
}
}
#
# NOTE: Unless the caller forbids it, display progress messages during
# the download.
#
if {!$quiet} then {
|
︙ | | |