← Back to branch summary

~ubuntu-branches/ubuntu/utopic/critcl/utopic

« back to all changes in this revision

Viewing changes to examples/optional/build.tcl

  • Committer: Package Import Robot
  • Author(s): Andrew Shadura
  • Date: 2013-05-11 00:08:06 UTC
  • Revision ID: package-import@ubuntu.com-20130511000806-7hq1zc3fnn0gat79
Tags: upstream-3.1.9
Import upstream version 3.1.9

Show diffs side-by-side

added added

removed removed

Lines of Context:
examples/optional/build.tcl
 
1
#!/bin/sh
 
2
# -*- tcl -*- \
 
3
exec tclsh "$0" ${1+"$@"}
 
4
set me [file normalize [info script]]
 
5
set packages {optional}
 
6
proc main {} {
 
7
    global argv tcl_platform tag
 
8
    set tag {}
 
9
    if {![llength $argv]} {
 
10
        if {$tcl_platform(platform) eq "windows"} {
 
11
            set argv gui
 
12
        } else {
 
13
            set argv help
 
14
        }
 
15
    }
 
16
    if {[catch {
 
17
        eval _$argv
 
18
    }]} usage
 
19
    exit 0
 
20
}
 
21
proc usage {{status 1}} {
 
22
    global errorInfo
 
23
    if {[info exists errorInfo] && ($errorInfo ne {}) &&
 
24
        ![string match {invalid command name "_*"*} $errorInfo]
 
25
    } {
 
26
        puts stderr $::errorInfo
 
27
        exit
 
28
    }
 
29
 
 
30
    global argv0
 
31
    set prefix "Usage: "
 
32
    foreach c [lsort -dict [info commands _*]] {
 
33
        set c [string range $c 1 end]
 
34
        if {[catch {
 
35
            H${c}
 
36
        } res]} {
 
37
            puts stderr "$prefix$argv0 $c args...\n"
 
38
        } else {
 
39
            puts stderr "$prefix$argv0 $c $res\n"
 
40
        }
 
41
        set prefix "       "
 
42
    }
 
43
    exit $status
 
44
}
 
45
proc tag {t} {
 
46
    global tag
 
47
    set tag $t
 
48
    return
 
49
}
 
50
proc myexit {} {
 
51
    tag ok
 
52
    puts DONE
 
53
    return
 
54
}
 
55
proc log {args} {
 
56
    global tag
 
57
    set newline 1
 
58
    if {[lindex $args 0] eq "-nonewline"} {
 
59
        set newline 0
 
60
        set args [lrange $args 1 end]
 
61
    }
 
62
    if {[llength $args] == 2} {
 
63
        lassign $args chan text
 
64
        if {$chan ni {stdout stderr}} {
 
65
            ::_puts {*}[lrange [info level 0] 1 end]
 
66
            return
 
67
        }
 
68
    } else {
 
69
        set text [lindex $args 0]
 
70
        set chan stdout
 
71
    }
 
72
    # chan <=> tag, if not overriden
 
73
    if {[string match {Files left*} $text]} {
 
74
        set tag warn
 
75
        set text \n$text
 
76
    }
 
77
    if {$tag eq {}} { set tag $chan }
 
78
    #::_puts $tag/$text
 
79
 
 
80
    .t insert end-1c $text $tag
 
81
    set tag {}
 
82
    if {$newline} { 
 
83
        .t insert end-1c \n
 
84
    }
 
85
 
 
86
    update
 
87
    return
 
88
}
 
89
proc +x {path} {
 
90
    catch { file attributes $path -permissions u+x }
 
91
    return
 
92
}
 
93
proc grep {file pattern} {
 
94
    set lines [split [read [set chan [open $file r]]] \n]
 
95
    close $chan
 
96
    return [lsearch -all -inline -glob $lines $pattern]
 
97
}
 
98
proc version {file} {
 
99
    set provisions [grep $file {*package provide*}]
 
100
    #puts /$provisions/
 
101
    return [lindex $provisions 0 3]
 
102
}
 
103
proc Hhelp {} { return "\n\tPrint this help" }
 
104
proc _help {} {
 
105
    usage 0
 
106
    return
 
107
}
 
108
proc Hrecipes {} { return "\n\tList all brew commands, without details." }
 
109
proc _recipes {} {
 
110
    set r {}
 
111
    foreach c [info commands _*] {
 
112
        lappend r [string range $c 1 end]
 
113
    }
 
114
    puts [lsort -dict $r]
 
115
    return
 
116
}
 
117
proc Hinstall {} { return "?destination?\n\tInstall all packages, and application.\n\tdestination = path of package directory, default \[info library\]." }
 
118
proc _install {{ldir {}}} {
 
119
    global packages
 
120
    if {[llength [info level 0]] < 2} {
 
121
        set ldir [info library]
 
122
        set idir [file dirname [file dirname $ldir]]/include
 
123
    } else {
 
124
        set idir [file dirname $ldir]/include
 
125
    }
 
126
 
 
127
    # Create directories, might not exist.
 
128
    file mkdir $idir
 
129
    file mkdir $ldir
 
130
 
 
131
    package require critcl::app
 
132
 
 
133
    foreach p $packages {
 
134
        set src     [file dirname $::me]/$p.tcl
 
135
        set version [version $src]
 
136
 
 
137
        file delete -force             [pwd]/BUILD
 
138
        critcl::app::main [list -cache [pwd]/BUILD -libdir $ldir -includedir $idir -pkg $src]
 
139
 
 
140
        if {![file exists $ldir/$p]} {
 
141
            set ::NOTE {warn {DONE, with FAILURES}}
 
142
            break
 
143
        }
 
144
 
 
145
        file delete -force $ldir/$p$version
 
146
        file rename        $ldir/$p $ldir/$p$version
 
147
 
 
148
        puts -nonewline "Installed package:     "
 
149
        tag ok
 
150
        puts $ldir/$p$version
 
151
    }
 
152
    return
 
153
}
 
154
proc Hdebug {} { return "?destination?\n\tInstall debug builds of all packages.\n\tdestination = path of package directory, default \[info library\]." }
 
155
proc _debug {{ldir {}}} {
 
156
    global packages
 
157
    if {[llength [info level 0]] < 2} {
 
158
        set ldir [info library]
 
159
        set idir [file dirname [file dirname $ldir]]/include
 
160
    } else {
 
161
        set idir [file dirname $ldir]/include
 
162
    }
 
163
 
 
164
    # Create directories, might not exist.
 
165
    file mkdir $idir
 
166
    file mkdir $ldir
 
167
 
 
168
    package require critcl::app
 
169
 
 
170
    foreach p $packages {
 
171
        set src     [file dirname $::me]/$p.tcl
 
172
        set version [version $src]
 
173
 
 
174
        file delete -force             [pwd]/BUILD.$p
 
175
        critcl::app::main [list -cache [pwd]/BUILD.$p -keep -debug all -libdir $ldir -includedir $idir -pkg $src]
 
176
 
 
177
        if {![file exists $ldir/$p]} {
 
178
            set ::NOTE {warn {DONE, with FAILURES}}
 
179
            break
 
180
        }
 
181
 
 
182
        file delete -force $ldir/$p$version
 
183
        file rename        $ldir/$p $ldir/$p$version
 
184
 
 
185
        puts -nonewline "Installed package:     "
 
186
        tag ok
 
187
        puts $ldir/$p$version
 
188
    }
 
189
    return
 
190
}
 
191
proc Hgui {} { return "\n\tInstall all packages, and application.\n\tDone from a small GUI." }
 
192
proc _gui {} {
 
193
    global INSTALLPATH
 
194
    package require Tk
 
195
    package require widget::scrolledwindow
 
196
 
 
197
    wm protocol . WM_DELETE_WINDOW ::_exit
 
198
 
 
199
    label  .l -text {Install Path: }
 
200
    entry  .e -textvariable ::INSTALLPATH
 
201
    button .i -command Install -text Install
 
202
 
 
203
    widget::scrolledwindow .st -borderwidth 1 -relief sunken
 
204
    text   .t
 
205
    .st setwidget .t
 
206
 
 
207
    .t tag configure stdout -font {Helvetica 8}
 
208
    .t tag configure stderr -background red    -font {Helvetica 12}
 
209
    .t tag configure ok     -background green  -font {Helvetica 8}
 
210
    .t tag configure warn   -background yellow -font {Helvetica 12}
 
211
 
 
212
    grid .l  -row 0 -column 0 -sticky new
 
213
    grid .e  -row 0 -column 1 -sticky new
 
214
    grid .i  -row 0 -column 2 -sticky new
 
215
    grid .st -row 1 -column 0 -sticky swen -columnspan 2
 
216
 
 
217
    grid rowconfigure . 0 -weight 0
 
218
    grid rowconfigure . 1 -weight 1
 
219
 
 
220
    grid columnconfigure . 0 -weight 0
 
221
    grid columnconfigure . 1 -weight 1
 
222
    grid columnconfigure . 2 -weight 0
 
223
 
 
224
    set INSTALLPATH [info library]
 
225
 
 
226
    # Redirect all output into our log window, and disable uncontrolled exit.
 
227
    rename ::puts ::_puts
 
228
    rename ::log ::puts
 
229
    rename ::exit   ::_exit
 
230
    rename ::myexit ::exit
 
231
 
 
232
    # And start to interact with the user.
 
233
    vwait forever
 
234
    return
 
235
}
 
236
proc Install {} {
 
237
    global INSTALLPATH NOTE
 
238
    .i configure -state disabled
 
239
 
 
240
    set NOTE {ok DONE}
 
241
    set fail [catch {
 
242
        _install $INSTALLPATH
 
243
 
 
244
        puts ""
 
245
        tag  [lindex $NOTE 0]
 
246
        puts [lindex $NOTE 1]
 
247
    } e o]
 
248
 
 
249
    .i configure -state normal
 
250
    .i configure -command ::_exit -text Exit -bg green
 
251
 
 
252
    if {$fail} {
 
253
        # rethrow
 
254
        return {*}$o $e
 
255
    }
 
256
    return
 
257
}
 
258
proc Hwrap4tea {} { return "?destination?\n\tGenerate a source package with TEA-based build system wrapped around critcl.\n\tdestination = path of source package directory, default is sub-directory 'tea' of the CWD." }
 
259
proc _wrap4tea {{dst {}}} {
 
260
    global packages
 
261
 
 
262
    if {[llength [info level 0]] < 2} {
 
263
        set dst [file join [pwd] tea]
 
264
    }
 
265
 
 
266
    file mkdir $dst
 
267
 
 
268
    package require critcl::app
 
269
 
 
270
    foreach p $packages {
 
271
        set src     [file dirname $::me]/$p.tcl
 
272
        set version [version $src]
 
273
 
 
274
        file delete -force             [pwd]/BUILD
 
275
        critcl::app::main [list -cache [pwd]/BUILD -libdir $dst -tea $src]
 
276
        file delete -force         $dst/$p$version
 
277
        file rename        $dst/$p $dst/$p$version
 
278
 
 
279
        puts "Wrapped package:     $dst/$p$version"
 
280
    }
 
281
    return
 
282
}
 
283
main