tcl-hacks

Check-in [91650d811a]
Login

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

Overview
Comment:move main back where it belongs
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:91650d811a17e152692bf723d88240e8f6778cef
User & Date: aspect 2018-07-24 10:55:40
Context
2018-07-24
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
2018-07-22
23:46
more hacks around being a teapot check-in: f3f967e9df user: aspect tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to hacks/cuppa/tpc.tcl.

540
541
542
543
544
545
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
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
...
690
691
692
693
694
695
696
697

































































698
        #if {$name in {Tcl Tk}} continue
        lappend res [list name $name ver $version]
    }
    lappend res
    return -type dicts $res
}

proc main {args} {
    chan configure stdout -buffering none
    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/
    }

    try {
        set r [{*}$args]
    } on error {err opt} {
        log "Error: $err"
        return 1
    } on ok {res opt} {
        if {![dict exists $opt -type]} {
            dict set opt -type text
        }
        switch [dict get $opt -type] {
            ignore {}
            dict {
                array set {} $res
                parray {}
            }
            dicts {
                set row [lindex $res 0]
                dict unset row rowid
                set keys [dict keys $row]
                puts \x1b\[1m[join $keys \t]\x1b\[0m
                foreach row $res {
                    dict unset row rowid
                    puts [join [dict values $row] \t]
                }
            }
            table {
                foreach row $res {
                    puts [join $row \t]
                }
            }
            text {
                puts -nonewline $res
            }
            binary {
                set trans [chan configure stdout -translation]
                chan configure stdout -translation binary
                puts -nonewline stdout $res
                chan configure stdout -translation $trans
            }
            default {
                if {$res ne ""} {puts $res}
            }
        }
    }
    return 0
}

proc mkenv {dir} {
    if {[file isdirectory $dir]} {
        throw {TPC EXISTS} "Directory \"$dir\" already exists!"
    }

    set tclexe [info nameofexe]
    set tclver [info patch]
................................................................................
        }
    }

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

    close $fd
}


































































exit [main {*}$::argv]







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







 








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

540
541
542
543
544
545
546































































547
548
549
550
551
552
553
...
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
        #if {$name in {Tcl Tk}} continue
        lappend res [list name $name ver $version]
    }
    lappend res
    return -type dicts $res
}
































































proc mkenv {dir} {
    if {[file isdirectory $dir]} {
        throw {TPC EXISTS} "Directory \"$dir\" already exists!"
    }

    set tclexe [info nameofexe]
    set tclver [info patch]
................................................................................
        }
    }

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

    close $fd
}

proc main {args} {
    chan configure stdout -buffering none
    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/
    }

    try {
        set r [{*}$args]
    } on error {err opt} {
        log "Error: $err"
        array set E $opt
        parray E
        return 1
    } on ok {res opt} {
        if {![dict exists $opt -type]} {
            dict set opt -type text
        }
        switch [dict get $opt -type] {
            ignore {}
            dict {
                array set {} $res
                parray {}
            }
            dicts {
                set row [lindex $res 0]
                dict unset row rowid
                set keys [dict keys $row]
                puts \x1b\[1m[join $keys \t]\x1b\[0m
                foreach row $res {
                    dict unset row rowid
                    puts [join [dict values $row] \t]
                }
            }
            table {
                foreach row $res {
                    puts [join $row \t]
                }
            }
            text {
                puts -nonewline $res
            }
            binary {
                set trans [chan configure stdout -translation]
                chan configure stdout -translation binary
                puts -nonewline stdout $res
                chan configure stdout -translation $trans
            }
            default {
                if {$res ne ""} {puts $res}
            }
        }
    }
    return 0
}

exit [main {*}$::argv]