tcl-hacks

Check-in [3efe5804f5]
Login

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

Overview
Comment:follow dependencies in install!
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:3efe5804f5c1b038e5eab77093844579171e200d
User & Date: aspect 2018-07-24 13:12:15
Context
2018-07-24
13:14
note some immediate fixme's check-in: da116e30d4 user: aspect tags: trunk
13:12
follow dependencies in install! check-in: 3efe5804f5 user: aspect tags: trunk
11:24
more consistent error handling. Display TPM throws nicely, let others go through to the keeper check-in: 9c29f30147 user: aspect tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to hacks/cuppa/tpc.tcl.

217
218
219
220
221
222
223







224
225
226
227
228
229
230
...
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
...
438
439
440
441
442
443
444

445
446
447
448
449
450
451
452
453
454
455
456

457
458
459
460
461
462
463
...
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
499
500
501
...
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
595
596
597
    }
    db eval {
        delete from servers where baseurl like :baseurl
    }
    log "Deleted [db total_changes] total items"
    return -type dicts [lappend result]
}








proc index:add {baseurl} {

    log "Indexing $baseurl ..."

    try {
        set data [get_tpm [join_url $baseurl list]]
................................................................................
    db eval { delete from pkgindex where server_id = $server_id }

    db transaction {
        foreach ent $data {

            lassign $ent type name ver arch

            if {$type eq "profile"} {
                continue
            } elseif {$type eq "redirect"} {
                continue
            }

            set os [lindex [split $arch -] 0]
            set cpu [lindex [split $arch -] end]

            if {[catch {package vsatisfies $ver 0-}]} {
                log "Ignoring bad version [list $name $ver]"
                continue
................................................................................
        log "Downloaded [string length $data] bytes"
        db eval {
            select format, data from packages where pkgindex_id = :rowid
        } row {
            return -type ignore [dict merge $_ [row_as_dict row]]
        }
    }

}

proc cat {name args} {
    set _ [get $name {*}$args]
    dict with _ {}
    if {$format eq "zip"} {
        return -type binary $data
    } else {
        return -type text $data
    }
}


proc meta {name args} {
    try {
        cat $name {*}$args
    } on ok {data opts} {
        set format [dict get $opts -type]
    }
    if {$format eq "text"} {
................................................................................
            log "Found metadata in zip teapot.txt"
        }
        $zip destroy
    }
    # FIXME: should check first line for eg {Package name version}
    if {$meta eq ""} {
        throw {TPM NO_META} "Metadata not found!"




    }
    set meta [regexp -line -inline -all {^(?:\s*#)?\s*Meta (\S+)\s+(.*)} $meta]
    foreach {_ key val} $meta {
        dict lappend res $key {*}$val
    }
    return -type dict $res
}

proc deps {name args} {
    set meta [meta $name {*}$args]
    foreach req [dict get $meta require] {
        # FIXME: parse properly
        if {[llength $req] > 2} {


            throw {TPM UNIMPLEMENTED} "Unsupported requirement format: $req"

        }
        lassign $req name version
        #if {$name in {Tcl Tk}} continue
        lappend res [list name $name ver $version]
    }
    lappend res
    return -type dicts $res
................................................................................
proc install {dir name args} {
    set fd [open $dir/tclenv.txt r+]
    finally close $fd

    # FIXME: read params from this file
    seek $fd 0 end

    # FIXME: follow dependencies

    set _ [get $name {*}$args]
    if {$_ eq ""} {
        throw {TPM NOT_FOUND} "No package found matching $name $args"
    }

























    dict with _ {}

    switch $type {



        "application" {
            createfile [set loc $dir/bin/$name] $data -permissions 0755
        }
        "package" {
            switch $format {
                "tm" {
                    createfile [set loc $dir/modules/$name-$ver.tm] $data
                }
                "zip" {
                    file mkdir [set loc $dir/lib/$name$ver]
                    set z [Zip new $data]
                    foreach ent [$z names] {
                        if {[string match */ $ent]} {
                            file mkdir $loc/$ent
                        } else {
                            createfile $loc/$ent [$z contents $ent] -binary 1
                        }
                    }
                }
                default {
                    throw {TPM UNIMPLEMENTED} "Unsupported entity format \"$format\""
                }
            }
        }
        default {
            throw {TPM UNIMPLEMENTED} "Unsupported entity type \"$type\""
        }
    }

    puts $fd [list installed $name $ver $loc]



    close $fd
}

proc main {args} {
    chan configure stdout -buffering none
    set ex [file exists tpc.db]







>
>
>
>
>
>
>







 







|
<
|
<
<







 







>












>







 







>
>
>
>











<

>
>
|
>







 







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

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







217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
...
248
249
250
251
252
253
254
255

256


257
258
259
260
261
262
263
...
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
...
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501

502
503
504
505
506
507
508
509
510
511
512
513
...
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
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627

628
629
630
631
632
633
634
635
636
637
    }
    db eval {
        delete from servers where baseurl like :baseurl
    }
    log "Deleted [db total_changes] total items"
    return -type dicts [lappend result]
}

proc index:refresh {{baseurl %}} {
    set baseurls [db onecolumn {select baseurl from servers where baseurl like :baseurl}]
    foreach baseurl $baseurls {
        index:add $baseurl
    }
}

proc index:add {baseurl} {

    log "Indexing $baseurl ..."

    try {
        set data [get_tpm [join_url $baseurl list]]
................................................................................
    db eval { delete from pkgindex where server_id = $server_id }

    db transaction {
        foreach ent $data {

            lassign $ent type name ver arch

            if {$type eq "profile"} continue    ;# used for collections - these just return metadata

            if {$type eq "redirect"} continue   ;# used for non-freely licensed pkgs @ activestate



            set os [lindex [split $arch -] 0]
            set cpu [lindex [split $arch -] end]

            if {[catch {package vsatisfies $ver 0-}]} {
                log "Ignoring bad version [list $name $ver]"
                continue
................................................................................
        log "Downloaded [string length $data] bytes"
        db eval {
            select format, data from packages where pkgindex_id = :rowid
        } row {
            return -type ignore [dict merge $_ [row_as_dict row]]
        }
    }
    throw {TPM NOT_FOUND} "No package found matching $name $args"
}

proc cat {name args} {
    set _ [get $name {*}$args]
    dict with _ {}
    if {$format eq "zip"} {
        return -type binary $data
    } else {
        return -type text $data
    }
}

# it would be nice if specific meta fields could be requested: require, depend, description ..
proc meta {name args} {
    try {
        cat $name {*}$args
    } on ok {data opts} {
        set format [dict get $opts -type]
    }
    if {$format eq "text"} {
................................................................................
            log "Found metadata in zip teapot.txt"
        }
        $zip destroy
    }
    # FIXME: should check first line for eg {Package name version}
    if {$meta eq ""} {
        throw {TPM NO_META} "Metadata not found!"
    }
    # fill in required keys first:
    set res {
        require ""
    }
    set meta [regexp -line -inline -all {^(?:\s*#)?\s*Meta (\S+)\s+(.*)} $meta]
    foreach {_ key val} $meta {
        dict lappend res $key {*}$val
    }
    return -type dict $res
}

proc deps {name args} {
    set meta [meta $name {*}$args]
    foreach req [dict get $meta require] {

        if {[llength $req] > 2} {
            # FIXME: parse properly
            #   <name> <ver> -is application
            #throw {TPM UNIMPLEMENTED} "Unsupported requirement format: $req"
            log "Ignoring unknown extra fields in requirement: $req"
        }
        lassign $req name version
        #if {$name in {Tcl Tk}} continue
        lappend res [list name $name ver $version]
    }
    lappend res
    return -type dicts $res
................................................................................
proc install {dir name args} {
    set fd [open $dir/tclenv.txt r+]
    finally close $fd

    # FIXME: read params from this file
    seek $fd 0 end

    # collect dependencies ..
    set deps {}
    lappend deps [dict create name $name {*}$args]



    for {set i 0} {$i < [llength $deps]} {incr i} {
        set dep [lindex $deps $i]
        log "# depends: $dep"

        set dep_name [dict get $dep name]
        dict unset dep name
        set dep_args $dep

        foreach rdep [deps $dep_name {*}$dep_args] {
            if {[dict get $rdep name] in {Tcl Tk}} continue     ;# FIXME ...
            if {[dict exists $rdep ver] && [dict get $rdep ver] eq ""} {           ;# FIXME: dicts-everywhere would simplify this
                dict unset rdep ver
            }
            if {$rdep ni $deps} {
                lappend deps $rdep
            }
        }
    }

    foreach pkgdesc $deps {
        set name [dict get $pkgdesc name]
        dict unset pkgdesc name
        set args $pkgdesc
        log "Installing $name $args"
        set _ [get $name {*}$args]
        dict with _ {}

        switch $type {
            "profile" {
                log "$name is a profile, nothing to install"
            }
            "application" {
                createfile [set loc $dir/bin/$name] $data -permissions 0755
            }
            "package" {
                switch $format {
                    "tm" {
                        createfile [set loc $dir/modules/$name-$ver.tm] $data
                    }
                    "zip" {
                        file mkdir [set loc $dir/lib/$name$ver]
                        set z [Zip new $data]
                        foreach ent [$z names] {
                            if {[string match */ $ent]} {
                                file mkdir $loc/$ent
                            } else {
                                createfile $loc/$ent [$z contents $ent] -binary 1
                            }
                        }
                    }
                    default {
                        throw {TPM UNIMPLEMENTED} "Unsupported entity format \"$format\""
                    }
                }
            }
            default {
                throw {TPM UNIMPLEMENTED} "Unsupported entity type \"$type\""
            }
        }

        puts $fd [list installed $name $ver $loc]
    }


    close $fd
}

proc main {args} {
    chan configure stdout -buffering none
    set ex [file exists tpc.db]