tcl-hacks

Check-in [49f97497bf]
Login

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

Overview
Comment:fix arch matching
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:49f97497bf5a6a990e6958300e5e4b6feef50136
User & Date: aspect 2018-07-24 11:14:38
Context
2018-07-24
11:15
find type should be generic, not just package check-in: 6211a10390 user: aspect tags: trunk
11:14
fix arch matching check-in: 49f97497bf user: aspect tags: trunk
10:55
move main back where it belongs check-in: 91650d811a user: aspect tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to hacks/cuppa/tpc.tcl.

139
140
141
142
143
144
145
















146
147
148
149
150
151
152
...
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
...
361
362
363
364
365
366
367
368
369
370
371
372

373
374
375
376
377
378
379
380
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
431
...
637
638
639
640
641
642
643

644
645
646
647
648
649
650
proc get_tpm {url} {
    set data [geturl $url]
    if {![regexp {\[\[TPM\[\[(.*)\]\]MPT\]\]} $data -> tpm]} {
        throw {TPM MISSING} "No TPM data at \"$url\""
    }
    return $tpm
}

















variable map_os {
    tcl         %
    linux-%     linux
    win32       windows
    solaris%    {solaris sunos}
    freebsd     freebsd_%
................................................................................

proc cache:drop {args} {
    # FIXME: also support older than X
    dictargs {
        type %
        name %
        ver 0-
        arch ""
        os %
        cpu %
        server %
    }

    set rowids [db eval {
        select
            packages.rowid as rowid
        from packages
        inner join pkgindex on packages.pkgindex_id = pkgindex.rowid
        inner join servers on pkgindex.server_id = servers.rowid
        where 1
          and type like :type
          and name like :name
          and vsatisfies(ver, :ver)
          and (cpu like :cpu
            or exists (select * from map_cpu where cpu like teapot and :cpu like local))
          and (os like :os
            or exists (select * from map_os where os like teapot and :os like local))
          and baseurl like :server
    }]
    log "Deleting [llength $rowids] records"
    db transaction {
        foreach rowid $rowids {
            db eval {
                delete from packages where rowid = :rowid
................................................................................
}

proc cache:info {args} {
    dictargs {
        type %
        name %
        ver 0-
        arch ""
        os %
        cpu %
        server %
    }

    db eval {
        select
            type, name, ver, arch
            format,
            length(data) as size,
            baseurl
        from packages
        inner join pkgindex on packages.pkgindex_id = pkgindex.rowid
        inner join servers on pkgindex.server_id = servers.rowid
        where 1
          and type like :type
          and name like :name
          and vsatisfies(ver, :ver)
          and (cpu like :cpu
            or exists (select * from map_cpu where cpu like teapot and :cpu like local))
          and (os like :os
            or exists (select * from map_os where os like teapot and :os like local))
          and baseurl like :server
        order by type, name, ver desc, arch
    } row {
        lappend result [row_as_dict row]
    }
    lappend result
    return -type dicts $result
}

proc find {name args} {
    dictargs {
        type package
        ver 0-
        os ""
        cpu ""
        server %
        limit 99999999
    }

    lassign [split [platform::generic] -] os_ cpu_
    if {$os eq ""} {set os $os_}
    if {$cpu eq ""} {set cpu $cpu_}
    db eval {
        select distinct
            pkgindex.rowid as rowid, type, name, ver, arch, url
        from pkgindex
        inner join servers on (server_id = servers.rowid)
        where 1
          and type like :type
          and name like :name
          and baseurl like :server
          and vsatisfies (ver, :ver)
          and (cpu like :cpu
            or exists (select * from map_cpu where cpu like teapot and :cpu like local))
          and (os like :os
            or exists (select * from map_os where os like teapot and :os like local))
        order by name, ver desc, priority desc
        limit :limit
    } row {
        lappend result [row_as_dict row]
    }
    lappend result
    return -type dicts $result
................................................................................
    set ex [file exists tpc.db]
    sqlite3 db tpc.db
    db eval {
        pragma foreign_keys = on
    }
    db collate  vcompare    {package vcompare}
    db function vsatisfies  {package vsatisfies}


    if {!$ex} {
        init_db
        index:add http://teapot.rkeene.org/
        index:add http://teapot.activestate.com/
    }








>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







|
<
<


>










|
<
<
<







 







|
<
<


>













|
<
<
<













|
<



>

<
<










|
<
<
<







 







>







139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
...
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
367
368
...
373
374
375
376
377
378
379
380


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
431
432
433
434
...
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
proc get_tpm {url} {
    set data [geturl $url]
    if {![regexp {\[\[TPM\[\[(.*)\]\]MPT\]\]} $data -> tpm]} {
        throw {TPM MISSING} "No TPM data at \"$url\""
    }
    return $tpm
}

# for mapping Teapot arch to requested arch
proc expand_arch {arch} {
    if {$arch eq "%"} {
        set arch "*"
    } elseif {$arch eq ""} {
        set arch [platform::patterns [platform::identify]]
    } else {
        set arch [platform::patterns $arch]
    }
    return $arch
}

proc lmatch {item list} {
    expr {$list eq "*" || $item in $list}
}

variable map_os {
    tcl         %
    linux-%     linux
    win32       windows
    solaris%    {solaris sunos}
    freebsd     freebsd_%
................................................................................

proc cache:drop {args} {
    # FIXME: also support older than X
    dictargs {
        type %
        name %
        ver 0-
        arch %


        server %
    }
    set arch [expand_arch $arch]
    set rowids [db eval {
        select
            packages.rowid as rowid
        from packages
        inner join pkgindex on packages.pkgindex_id = pkgindex.rowid
        inner join servers on pkgindex.server_id = servers.rowid
        where 1
          and type like :type
          and name like :name
          and vsatisfies(ver, :ver)
          and lmatch(arch, :arch)



          and baseurl like :server
    }]
    log "Deleting [llength $rowids] records"
    db transaction {
        foreach rowid $rowids {
            db eval {
                delete from packages where rowid = :rowid
................................................................................
}

proc cache:info {args} {
    dictargs {
        type %
        name %
        ver 0-
        arch %


        server %
    }
    set arch [expand_arch $arch]
    db eval {
        select
            type, name, ver, arch
            format,
            length(data) as size,
            baseurl
        from packages
        inner join pkgindex on packages.pkgindex_id = pkgindex.rowid
        inner join servers on pkgindex.server_id = servers.rowid
        where 1
          and type like :type
          and name like :name
          and vsatisfies(ver, :ver)
          and lmatch(arch, :arch)



          and baseurl like :server
        order by type, name, ver desc, arch
    } row {
        lappend result [row_as_dict row]
    }
    lappend result
    return -type dicts $result
}

proc find {name args} {
    dictargs {
        type package
        ver 0-
        arch ""

        server %
        limit 99999999
    }
    set arch [expand_arch $arch]
    lassign [split [platform::generic] -] os_ cpu_


    db eval {
        select distinct
            pkgindex.rowid as rowid, type, name, ver, arch, url
        from pkgindex
        inner join servers on (server_id = servers.rowid)
        where 1
          and type like :type
          and name like :name
          and baseurl like :server
          and vsatisfies (ver, :ver)
          and lmatch(arch, :arch)



        order by name, ver desc, priority desc
        limit :limit
    } row {
        lappend result [row_as_dict row]
    }
    lappend result
    return -type dicts $result
................................................................................
    set ex [file exists tpc.db]
    sqlite3 db tpc.db
    db eval {
        pragma foreign_keys = on
    }
    db collate  vcompare    {package vcompare}
    db function vsatisfies  {package vsatisfies}
    db function lmatch      lmatch

    if {!$ex} {
        init_db
        index:add http://teapot.rkeene.org/
        index:add http://teapot.activestate.com/
    }