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