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