1#!/bin/sh
2# -*- tcl -*- \
3exec tclsh "$0" ${1+"$@"}
4set me [file normalize [info script]]
5set packages {pool}
6proc 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}
21proc 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}
45proc tag {t} {
46    global tag
47    set tag $t
48    return
49}
50proc myexit {} {
51    tag ok
52    puts DONE
53    return
54}
55proc 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}
89proc +x {path} {
90    catch { file attributes $path -permissions u+x }
91    return
92}
93proc 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}
98proc version {file} {
99    set provisions [grep $file {*package provide*}]
100    #puts /$provisions/
101    return [lindex $provisions 0 3]
102}
103proc Hhelp {} { return "\n\tPrint this help" }
104proc _help {} {
105    usage 0
106    return
107}
108proc Hrecipes {} { return "\n\tList all brew commands, without details." }
109proc _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}
117proc Hinstall {} { return "?destination?\n\tInstall all packages, and application.\n\tdestination = path of package directory, default \[info library\]." }
118proc _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}
154proc Hdebug {} { return "?destination?\n\tInstall debug builds of all packages.\n\tdestination = path of package directory, default \[info library\]." }
155proc _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}
191proc Hgui {} { return "\n\tInstall all packages, and application.\n\tDone from a small GUI." }
192proc _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}
236proc 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}
258proc 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." }
259proc _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}
283main
284