tcl-hacks

Check-in [d393e032d2]
Login

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

Overview
Comment:tipple init first draft
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:d393e032d2aaa13133c1bbff44ab6cf439e65f5c
User & Date: aspect 2018-05-30 08:45:56
Context
2018-05-30
10:26
use-cases and more readme check-in: 6f520aa71c user: aspect tags: trunk
08:45
tipple init first draft check-in: d393e032d2 user: aspect tags: trunk
04:50
add more links to other projects check-in: 68292c9f7f user: aspect tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Added tipple/tipple.tcl.



















































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
#!/usr/bin/env tclsh
#

proc createfile {path data args} {
    if {[file exists $path]} {
        return -code error "File already exists! \"$path\""
    }
    set fd [open $path w]
    try {
        puts -nonewline $fd [dedent $data]
    } finally {
        close $fd
    }
    if {$args ne ""} {
        file attributes $path {*}$args
    }
}

proc dedent {lines} {
    regexp {\n( +)} $lines -> indent
    regsub -all \n$indent   $lines  \n  lines
    regsub      { +$}       $lines  ""  lines
    regexp {\n(.*)} $lines -> lines
    return $lines
}

namespace eval tipple {
    namespace ensemble create
    namespace export {[a-z]*}

    proc help {} {
        puts "Subcommands: [lmap c [info commands [namespace current]::\[a-z\]*] {namespace tail $c}]"
    }

    proc init {topdir} {

        set topdir [file normalize $topdir]

        if {[file exists $topdir]} {
            if {[file exists $topdir/tipple.txt]} {
                return -code error "Error: $topdir/tipple.txt already exists!"
            }
            puts "Setting up in existing directory: $topdir"
        } else {
            puts "Setting up new directory: $topdir"
        }

        set tclver [info tclversion]
        regexp {^(\d+).(\d+)} $tclver -> majver minver

        set bindir $topdir/bin
        set libdir $topdir/lib/tcl$tclver
        set moddir $topdir/lib/tcl${majver}/site-tcl

        puts "mkdir -p $topdir $bindir $libdir $moddir"
        file mkdir $topdir $bindir $libdir $moddir

        createfile $bindir/activate [subst -noc {
            # source this file to initialize your env:
            PATH="$bindir:\$PATH"
            TCLLIBPATH="$libdir"
            TCL${majver}_${minver}_TM_PATH="$moddir"
            export PATH TCLLIBPATH TCL${majver}_${minver}_TM_PATH
        }]

        if {[file exists $bindir/tclsh]} {

            puts "Not modifying existing $bindir/tclsh"

        } else {

            set tclexe [info nameofexecutable]

            puts "Creating wrapper script $bindir/tclsh -> $tclexe"

            createfile $bindir/tclsh [subst -noc {
                #!/bin/sh
                . "$bindir/activate"
                exec "$tclexe" "\$@"
            }] -permissions 0755

        }

        createfile $topdir/tipple.txt [subst {
            # Tcl environment initialised at [clock format [clock seconds]]
            tcl_version $tclver
            lib_dir [list $libdir]
            tm_dir  [list $moddir]

        }]
    }
}

proc main {args} {
    if {$args eq ""} {set args "help"}
    try {
        tipple {*}$args
    } on error {err opts} {
        puts stderr "Error: $err"
        return 1
    }
    return 0
}

exit [main {*}$::argv]