1### 2### Utility for the build process. Main purpose currently: 3### 4### - Build the pkgIndex in each directory 5### 6 7# adjust the paths; 8# - auto_path is needed, when nx is loaded via good old pkgIndex.tcl 9# - tcl::tm::roots is needed when nx is provided as a Tcl module (.tm) 10lappend auto_path .. 11::tcl::tm::roots [pwd] 12#puts stderr TM-LIST=[ ::tcl::tm::path list ] 13 14set verbose 0 15 16package require nx 17namespace eval ::nx {}; # make pkg_mkIndex happy 18 19### 20nx::Object create make { 21 # 22 # shared lib add files for pkgIndex.tcl 23 # 24 :object method mkIndex {name} { 25 if {$::verbose} {puts stderr "+++ mkIndex in [pwd]"} 26 set fls {} 27 foreach f [glob -nocomplain *tcl] { 28 if {![file isdirectory $f]} { 29 set F [file open $f]; set c [read $F]; close $F 30 if {[string match "*package provide*" $c]} { lappend fls $f } 31 } 32 } 33 34 set so [glob -nocomplain *[info sharedlibextension]] 35 set version $::nsf::version 36 # loading libnext into nextsh might cause problems on some systems 37 foreach lib [list libnext$version[info sharedlibextension] \ 38 next$version.dll] { 39 set p [lsearch -exact $so $lib] 40 if {$p != -1} { 41 set so [lreplace $so $p $p] 42 puts stderr "new so=<$so>" 43 } 44 } 45 #puts stderr "[pwd]: call so=<$so>" 46 lappend fls {*}$so 47 48 if {$fls ne ""} { 49 if {[file exists pkgIndex.tcl]} { 50 file delete -force pkgIndex.tcl 51 } 52 #puts stderr "callinglevel <[current callinglevel]> $fls" 53 54 # 55 # redefine the logging behavior to show just error or warnings, 56 # preceded by the current directory 57 # 58 #set ::current [pwd] 59 proc ::tclLog msg { 60 if {[regexp {^(error|warning)} $msg]} { 61 if {[regexp -nocase error $msg]} { 62 error $msg 63 } 64 puts stderr "$msg ([pwd])" 65 } 66 } 67 68 set flags "-verbose -direct -load nsf" 69 # the following test is just an approximization, loading nsf + 70 # nx does not seem to work for binary extensions (e.g. mongodb) 71 if {$fls ne "nx.tcl" && ![string match "*[info sharedlibextension]" $fls]} { 72 append flags " -load nx" 73 } 74 #package prefer latest 75 if {$::verbose} {puts stderr "[pwd]:\n\tcall pkg_mkIndex $flags . $fls"} 76 pkg_mkIndex {*}$flags . {*}$fls 77 if {$::verbose} {puts stderr "[pwd] done"} 78 } 79 80 foreach addFile [glob -nocomplain *.add] { 81 if {[file exists $addFile]} { 82 puts stderr "Appending $addFile to pkgIndex.tcl in [pwd]" 83 set OUT [file open pkgIndex.tcl a] 84 set IN [file open $addFile] 85 puts -nonewline $OUT [read $IN] 86 close $IN; close $OUT 87 } 88 } 89 90 #puts stderr "+++ mkIndex name=$name, pwd=[pwd] DONE" 91 } 92 93 :public object method inEachDir {path cmd} { 94 if {$::verbose} {puts stderr "[pwd] inEachDir $path (dir [file isdirectory $path]) $cmd"} 95 if { [file isdirectory $path] 96 && ![string match *CVS $path] 97 && ![string match *SCCS $path] 98 && ![string match *Attic $path] 99 && ![string match *dbm* $path] 100 } { 101 set olddir [pwd] 102 cd $path 103 if {[catch {make {*}$cmd $path} errMsg]} { 104 error "$errMsg (in directory [pwd])" 105 } 106 set files [glob -nocomplain *] 107 cd $olddir 108 foreach p $files { :inEachDir $path/$p $cmd } 109 if {$::verbose} {puts stderr "+++ change back to $olddir"} 110 } 111 } 112 113 :object method in {path cmd} { 114 if {[file isdirectory $path] && ![string match *CVS $path]} { 115 set olddir [pwd] 116 cd $path 117 make {*}$cmd $path 118 cd $olddir 119 } 120 } 121} 122 123### Tcl file-command 124rename file tcl_file 125nx::Object create file { 126 :require namespace 127 128 array set :destructive { 129 atime 0 attributes 0 copy 1 delete 1 dirname 0 130 executable 0 exists 0 extension 0 isdirectory 0 isfile 0 131 join 0 lstat 0 mkdir 1 mtime 0 nativename 0 132 owned 0 pathtype 0 readable 0 readlink 0 rename 1 133 rootname 0 size 0 split 0 stat 0 tail 0 134 type 0 volumes 0 writable 0 135 } 136 137 foreach subcmd [array names :destructive] { 138 :public object method $subcmd args { 139 #puts stderr " [pwd] call: '::tcl_file [current method] $args'" 140 ::tcl_file [current method] {*}$args 141 } 142 } 143} 144 145rename open file::open 146proc open {f {mode r}} { file open $f $mode } 147 148 149### minus n option 150nx::Class create make::-n 151foreach f [file info object methods] { 152 if {$f eq "unknown" || $f eq "next" || $f eq "self"} continue 153 if {![file exists destructive($f)] || [file eval [list set :destructive($f)]]} { 154 #puts stderr destruct=$f 155 make::-n method $f args { 156 puts "--- [pwd]:\t[current method] $args" 157 } 158 } else { 159 #puts stderr nondestruct=$f 160 make::-n method $f args { 161 set r [next] 162 #puts "??? [current method] $args -> {$r}" 163 return $r 164 } 165 } 166} 167 168### command line parameters 169if {![info exists argv] || $argv eq ""} {set argv -all} 170if {$argv eq "-n"} {set argv "-n -all"} 171 172nx::Class create Script { 173 :public object method create args { 174 lappend args {*}$::argv 175 set s [next] 176 set method [list] 177 foreach arg [lrange $args 1 end] { 178 switch -glob -- $arg { 179 "-all" {$s all} 180 "-n" {$s n} 181 "-*" {set method [string range $arg 1 end]} 182 default { 183 puts "$s $method $arg" 184 $s $method $arg 185 } 186 } 187 } 188 } 189 190 :object method unknown args { 191 puts stderr "$::argv0: Unknown option ´-$args´ provided" 192 } 193 194 :public method n {} {file mixin make::-n} 195 196 :public method all {} {make inEachDir . mkIndex} 197 198 :public method dir {dirName} {cd $dirName} 199 200 :public method target {path} {make eval [list set :target $path]} 201 202 if {[catch {:create main} errorMsg]} { 203 puts stderr "*** $errorMsg" 204 # Exit silently, alltough we are leaving from an active stack 205 # frame. 206 ::nsf::configure debug 0 207 exit -1 208 } 209} 210 211#puts stderr "+++ make.tcl finished." 212 213#exit $::result 214