Diff
Not logged in

Differences From Artifact [5031a13764]:

To Artifact [3124877c79]:


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 {