1###
2# Amalgamated package for practcl
3# Do not edit directly, tweak the source in src/ and rerun
4# build.tcl
5###
6package require Tcl 8.5
7package provide practcl 0.11
8namespace eval ::practcl {}
9
10###
11# START: httpwget/wget.tcl
12###
13###
14# Tool to download file from the web
15# Enhacements to http
16###
17package provide http::wget 0.1
18package require http
19
20::namespace eval ::http {}
21
22###
23# topic: 1ed971e03ae89415e2f25d20e59b765c
24# description: this proc contributed by Donal Fellows
25###
26proc ::http::_followRedirects {url args} {
27    while 1 {
28        set token [geturl $url -validate 1]
29        set ncode [ncode $token]
30        if { $ncode eq "404" } {
31          error "URL Not found"
32        }
33        switch -glob $ncode {
34            30[1237] {### redirect - see below ###}
35            default  {cleanup $token ; return $url}
36        }
37        upvar #0 $token state
38        array set meta [set ${token}(meta)]
39        cleanup $token
40        if {![info exists meta(Location)]} {
41           return $url
42        }
43        set url $meta(Location)
44        unset meta
45    }
46    return $url
47}
48
49###
50# topic: fced7bc395596569ac225a719c686dcc
51###
52proc ::http::wget {url destfile {verbose 1}} {
53    set tmpchan [open $destfile w]
54    fconfigure $tmpchan -translation binary
55    if { $verbose } {
56        puts [list  GETTING [file tail $destfile] from $url]
57    }
58    set real_url [_followRedirects $url]
59    set token [geturl $real_url -channel $tmpchan -binary yes]
60    if {[ncode $token] != "200"} {
61      error "DOWNLOAD FAILED"
62    }
63    cleanup $token
64    close $tmpchan
65}
66
67
68###
69# END: httpwget/wget.tcl
70###
71###
72# START: setup.tcl
73###
74###
75# Practcl
76# An object oriented templating system for stamping out Tcl API calls to C
77###
78
79package require TclOO
80###
81# Seek out Tcllib if it's available
82###
83set tcllib_path {}
84foreach path {.. ../.. ../../..} {
85  foreach path [glob -nocomplain [file join [file normalize $path] tcllib* modules]] {
86    set tclib_path $path
87    lappend ::auto_path $path
88    break
89  }
90  if {$tcllib_path ne {}} break
91}
92namespace eval ::practcl {}
93namespace eval ::practcl::OBJECT {}
94
95###
96# END: setup.tcl
97###
98###
99# START: buildutil.tcl
100###
101###
102# Build utility functions
103###
104
105###
106# A command to do nothing. A handy way of
107# negating an instruction without
108# having to comment it completely out.
109# It's also a handy attachment point for
110# an object to be named later
111###
112if {[info command ::noop] eq {}} {
113  proc ::noop args {}
114}
115
116proc ::practcl::debug args {
117  #puts $args
118  ::practcl::cputs ::DEBUG_INFO $args
119}
120
121###
122# Drop in a static copy of Tcl
123###
124proc ::practcl::doexec args {
125  puts [list {*}$args]
126  exec {*}$args >&@ stdout
127}
128
129proc ::practcl::doexec_in {path args} {
130  set PWD [pwd]
131  cd $path
132  puts [list {*}$args]
133  exec {*}$args >&@ stdout
134  cd $PWD
135}
136
137proc ::practcl::dotclexec args {
138  puts [list [info nameofexecutable] {*}$args]
139  exec [info nameofexecutable] {*}$args >&@ stdout
140}
141
142proc ::practcl::domake {path args} {
143  set PWD [pwd]
144  cd $path
145  puts [list *** $path ***]
146  puts [list make {*}$args]
147  exec make {*}$args >&@ stdout
148  cd $PWD
149}
150
151proc ::practcl::domake.tcl {path args} {
152  set PWD [pwd]
153  cd $path
154  puts [list *** $path ***]
155  puts [list make.tcl {*}$args]
156  exec [info nameofexecutable] make.tcl {*}$args >&@ stdout
157  cd $PWD
158}
159
160proc ::practcl::fossil {path args} {
161  set PWD [pwd]
162  cd $path
163  puts [list {*}$args]
164  exec fossil {*}$args >&@ stdout
165  cd $PWD
166}
167
168
169proc ::practcl::fossil_status {dir} {
170  if {[info exists ::fosdat($dir)]} {
171    return $::fosdat($dir)
172  }
173  set result {
174tags experimental
175version {}
176  }
177  set pwd [pwd]
178  cd $dir
179  set info [exec fossil status]
180  cd $pwd
181  foreach line [split $info \n] {
182    if {[lindex $line 0] eq "checkout:"} {
183      set hash [lindex $line end-3]
184      set maxdate [lrange $line end-2 end-1]
185      dict set result hash $hash
186      dict set result maxdate $maxdate
187      regsub -all {[^0-9]} $maxdate {} isodate
188      dict set result isodate $isodate
189    }
190    if {[lindex $line 0] eq "tags:"} {
191      set tags [lrange $line 1 end]
192      dict set result tags $tags
193      break
194    }
195  }
196  set ::fosdat($dir) $result
197  return $result
198}
199
200proc ::practcl::os {} {
201  return [${::practcl::MAIN} define get TEACUP_OS]
202}
203
204if {[::package vcompare $::tcl_version 8.6] < 0} {
205  # Approximate ::zipfile::mkzip with exec calls
206  proc ::practcl::mkzip {exename barekit vfspath} {
207    set path [file dirname [file normalize $exename]]
208    set zipfile [file join $path [file rootname $exename].zip]
209    file copy -force $barekit $exename
210    set pwd [pwd]
211    cd $vfspath
212    exec zip -r $zipfile .
213    cd $pwd
214    set fout [open $exename a]
215    set fin [open $zipfile r]
216    chan configure $fout -translation binary
217    chan configure $fin -translation binary
218    chan copy $fin $fout
219    chan close $fin
220    chan close $fout
221    exec zip -A $exename
222  }
223  proc ::practcl::sort_dict list {
224    set result {}
225    foreach key [lsort -dictionary [dict keys $list]] {
226      dict set result $key [dict get $list $key]
227    }
228    return $result
229  }
230} else {
231  proc ::practcl::mkzip {exename barekit vfspath} {
232    ::practcl::tcllib_require zipfile::mkzip
233    ::zipfile::mkzip::mkzip $exename -runtime $barekit -directory $vfspath
234  }
235  proc ::practcl::sort_dict list {
236    return [::lsort -stride 2 -dictionary $list]
237  }
238}
239
240proc ::practcl::local_os {} {
241  # If we have already run this command, return
242  # a cached copy of the data
243  if {[info exists ::practcl::LOCAL_INFO]} {
244    return $::practcl::LOCAL_INFO
245  }
246  set result [array get ::practcl::CONFIG]
247  dict set result TEACUP_PROFILE unknown
248  dict set result TEACUP_OS unknown
249  dict set result EXEEXT {}
250  set windows 0
251  if {$::tcl_platform(platform) eq "windows"} {
252    set windows 1
253  }
254  if {$windows} {
255    set system "windows"
256    set arch ix86
257    dict set result TEACUP_PROFILE win32-ix86
258    dict set result TEACUP_OS windows
259    dict set result EXEEXT .exe
260  } else {
261    set system [exec uname -s]-[exec uname -r]
262    set arch unknown
263    dict set result TEACUP_OS generic
264  }
265  dict set result TEA_PLATFORM $system
266  dict set result TEA_SYSTEM $system
267  if {[info exists ::SANDBOX]} {
268    dict set result sandbox $::SANDBOX
269  }
270  switch -glob $system {
271    Linux* {
272      dict set result TEACUP_OS linux
273      set arch [exec uname -m]
274      dict set result TEACUP_PROFILE "linux-glibc2.3-$arch"
275    }
276    GNU* {
277      set arch [exec uname -m]
278      dict set result TEACUP_OS "gnu"
279    }
280    NetBSD-Debian {
281      set arch [exec uname -m]
282      dict set result TEACUP_OS "netbsd-debian"
283    }
284    OpenBSD-* {
285      set arch [exec arch -s]
286      dict set result TEACUP_OS "openbsd"
287    }
288    Darwin* {
289      set arch [exec uname -m]
290      dict set result TEACUP_OS "macosx"
291      if {$arch eq "x86_64"} {
292        dict set result TEACUP_PROFILE "macosx10.5-i386-x86_84"
293      } else {
294        dict set result TEACUP_PROFILE "macosx-universal"
295      }
296    }
297    OpenBSD* {
298      set arch [exec arch -s]
299      dict set result TEACUP_OS "openbsd"
300    }
301  }
302  if {$arch eq "unknown"} {
303    catch {set arch [exec uname -m]}
304  }
305  switch -glob $arch {
306    i*86 {
307      set arch "ix86"
308    }
309    amd64 {
310      set arch "x86_64"
311    }
312  }
313  dict set result TEACUP_ARCH $arch
314  if {[dict get $result TEACUP_PROFILE] eq "unknown"} {
315    dict set result TEACUP_PROFILE [dict get $result TEACUP_OS]-$arch
316  }
317  set OS [dict get $result TEACUP_OS]
318  dict set result os $OS
319
320  # Look for a local preference file
321  set pathlist {}
322  set userhome [file normalize ~/tcl]
323  set local_install [file join $userhome lib]
324  switch $OS {
325    windows {
326      set userhome [file join [file normalize $::env(LOCALAPPDATA)] Tcl]
327      if {[file exists c:/Tcl/Teapot]} {
328        dict set result teapot c:/Tcl/Teapot
329      }
330    }
331    macosx {
332      set userhome [file join [file normalize {~/Library/Application Support/}] Tcl]
333      if {[file exists {~/Library/Application Support/ActiveState/Teapot/repository/}]} {
334        dict set result teapot [file normalize {~/Library/Application Support/ActiveState/Teapot/repository/}]
335      }
336      dict set result local_install [file normalize ~/Library/Tcl]
337      if {![dict exists $result sandbox]} {
338        dict set result sandbox       [file normalize ~/Library/Tcl/sandbox]
339      }
340    }
341    default {
342    }
343  }
344  dict set result userhome $userhome
345  # Load user preferences
346  if {[file exists [file join $userhome practcl.rc]]} {
347    set dat [::practcl::read_rc_file [file join $userhome practcl.rc]]
348    foreach {f v} $dat {
349      dict set result $f $v
350    }
351  }
352  if {![dict exists $result prefix]} {
353    dict set result prefix   $userhome
354  }
355
356  # Create a default path for the teapot
357  if {![dict exists $result teapot]} {
358    dict set result teapot [file join $userhome teapot]
359  }
360  # Create a default path for the local sandbox
361  if {![dict exists $result sandbox]} {
362    dict set result sandbox [file join $userhome sandbox]
363  }
364  # Create a default path for download folder
365  if {![dict exists $result download]} {
366    dict set result download [file join $userhome download]
367  }
368  # Path to install local packages
369  if {![dict exists $result local_install]} {
370    dict set result local_install [file join $userhome lib]
371  }
372  if {![dict exists result fossil_mirror] && [::info exists ::env(FOSSIL_MIRROR)]} {
373    dict set result fossil_mirror $::env(FOSSIL_MIRROR)
374  }
375
376  set ::practcl::LOCAL_INFO $result
377  return $result
378}
379
380
381###
382# Detect local platform
383###
384proc ::practcl::config.tcl {path} {
385   return [read_configuration $path]
386}
387
388proc ::practcl::read_configuration {path} {
389  dict set result buildpath $path
390  set result [local_os]
391  set OS [dict get $result TEACUP_OS]
392  set windows 0
393  dict set result USEMSVC 0
394  if {[file exists [file join $path config.tcl]]} {
395    # We have a definitive configuration file. Read its content
396    # and take it as gospel
397    set cresult [read_rc_file [file join $path config.tcl]]
398    set cresult [::practcl::de_shell $cresult]
399    if {[dict exists $cresult srcdir] && ![dict exists $cresult sandbox]} {
400      dict set cresult sandbox  [file dirname [dict get $cresult srcdir]]
401    }
402    set result [dict merge $result [::practcl::de_shell $cresult]]
403  }
404  if {[file exists [file join $path config.site]]} {
405    # No config.tcl file is present but we do seed
406    dict set result USEMSVC 0
407    foreach {f v} [::practcl::de_shell [::practcl::read_sh_file [file join $path config.site]]] {
408      dict set result $f $v
409      dict set result XCOMPILE_${f} $v
410    }
411    dict set result CONFIG_SITE [file join $path config.site]
412    if {[dict exist $result XCOMPILE_CC] && [regexp mingw [dict get $result XCOMPILE_CC]]} {
413      set windows 1
414    }
415  } elseif {[info exists ::env(VisualStudioVersion)]} {
416    set windows 1
417    dict set result USEMSVC 1
418  }
419  if {$windows && [dict get $result TEACUP_OS] ne "windows"} {
420    if {![dict exists exists $result TEACUP_ARCH]} {
421      dict set result TEACUP_ARCH ix86
422    }
423    dict set result TEACUP_PROFILE win32-[dict get $result TEACUP_ARCH]
424    dict set result TEACUP_OS windows
425    dict set result EXEEXT .exe
426  }
427  return $result
428}
429
430
431###
432# Convert an MSYS path to a windows native path
433###
434if {$::tcl_platform(platform) eq "windows"} {
435proc ::practcl::msys_to_tclpath msyspath {
436  return [exec sh -c "cd $msyspath ; pwd -W"]
437}
438proc ::practcl::tcl_to_myspath tclpath {
439  set path [file normalize $tclpath]
440  return "/[string index $path 0][string range $path 2 end]"
441  #return [exec sh -c "cd $tclpath ; pwd"]
442}
443} else {
444proc ::practcl::msys_to_tclpath msyspath {
445  return [file normalize $msyspath]
446}
447proc ::practcl::tcl_to_myspath msyspath {
448  return [file normalize $msyspath]
449}
450}
451
452
453# Try to load  a package, and failing that
454# retrieve tcllib
455proc ::practcl::tcllib_require {pkg args} {
456  # Try to load the package from the local environment
457  if {[catch [list ::package require $pkg {*}$args] err]==0} {
458    return $err
459  }
460  ::practcl::LOCAL tool tcllib env-load
461  uplevel #0 [list ::package require $pkg {*}$args]
462}
463
464namespace eval ::practcl::platform {}
465
466proc ::practcl::platform::tcl_core_options {os} {
467  ###
468  # Download our required packages
469  ###
470  set tcl_config_opts {}
471  # Auto-guess options for the local operating system
472  switch $os {
473    windows {
474      #lappend tcl_config_opts --disable-stubs
475    }
476    linux {
477    }
478    macosx {
479      lappend tcl_config_opts --enable-corefoundation=yes  --enable-framework=no
480    }
481  }
482  lappend tcl_config_opts --with-tzdata
483  return $tcl_config_opts
484}
485
486proc ::practcl::platform::tk_core_options {os} {
487  ###
488  # Download our required packages
489  ###
490  set tk_config_opts {}
491
492  # Auto-guess options for the local operating system
493  switch $os {
494    windows {
495    }
496    linux {
497      lappend tk_config_opts --enable-xft=no --enable-xss=no
498    }
499    macosx {
500      lappend tk_config_opts --enable-aqua=yes
501    }
502  }
503  return $tk_config_opts
504}
505
506###
507# Read a stylized key/value list stored in a file
508###
509proc ::practcl::read_rc_file {filename {localdat {}}} {
510  set result $localdat
511  set fin [open $filename r]
512  set bufline {}
513  set rawcount 0
514  set linecount 0
515  while {[gets $fin thisline]>=0} {
516    incr rawcount
517    append bufline \n $thisline
518    if {![info complete $bufline]} continue
519    set line [string trimleft $bufline]
520    set bufline {}
521    if {[string index [string trimleft $line] 0] eq "#"} continue
522    append result \n $line
523    #incr linecount
524    #set key [lindex $line 0]
525    #set value [lindex $line 1]
526    #dict set result $key $value
527  }
528  close $fin
529  return $result
530}
531
532###
533# topic: e71f3f61c348d56292011eec83e95f0aacc1c618
534# description: Converts a XXX.sh file into a series of Tcl variables
535###
536proc ::practcl::read_sh_subst {line info} {
537  regsub -all {\x28} $line \x7B line
538  regsub -all {\x29} $line \x7D line
539
540  #set line [string map $key [string trim $line]]
541  foreach {field value} $info {
542    catch {set $field $value}
543  }
544  if [catch {subst $line} result] {
545    return {}
546  }
547  set result [string trim $result]
548  return [string trim $result ']
549}
550
551###
552# topic: 03567140cca33c814664c7439570f669b9ab88e6
553###
554proc ::practcl::read_sh_file {filename {localdat {}}} {
555  set fin [open $filename r]
556  set result {}
557  if {$localdat eq {}} {
558    set top 1
559    set local [array get ::env]
560    dict set local EXE {}
561  } else {
562    set top 0
563    set local $localdat
564  }
565  while {[gets $fin line] >= 0} {
566    set line [string trim $line]
567    if {[string index $line 0] eq "#"} continue
568    if {$line eq {}} continue
569    catch {
570    if {[string range $line 0 6] eq "export "} {
571      set eq [string first "=" $line]
572      set field [string trim [string range $line 6 [expr {$eq - 1}]]]
573      set value [read_sh_subst [string range $line [expr {$eq+1}] end] $local]
574      dict set result $field [read_sh_subst $value $local]
575      dict set local $field $value
576    } elseif {[string range $line 0 7] eq "include "} {
577      set subfile [read_sh_subst [string range $line 7 end] $local]
578      foreach {field value} [read_sh_file $subfile $local] {
579        dict set result $field $value
580      }
581    } else {
582      set eq [string first "=" $line]
583      if {$eq > 0} {
584        set field [read_sh_subst [string range $line 0 [expr {$eq - 1}]] $local]
585        set value [string trim [string range $line [expr {$eq+1}] end] ']
586        #set value [read_sh_subst [string range $line [expr {$eq+1}] end] $local]
587        dict set local $field $value
588        dict set result $field $value
589      }
590    }
591    } err opts
592    if {[dict get $opts -code] != 0} {
593      #puts $opts
594      puts "Error reading line:\n$line\nerr: $err\n***"
595      return $err {*}$opts
596    }
597  }
598  return $result
599}
600
601###
602# A simpler form of read_sh_file tailored
603# to pulling data from (tcl|tk)Config.sh
604###
605proc ::practcl::read_Config.sh filename {
606  set fin [open $filename r]
607  set result {}
608  set linecount 0
609  while {[gets $fin line] >= 0} {
610    set line [string trim $line]
611    if {[string index $line 0] eq "#"} continue
612    if {$line eq {}} continue
613    catch {
614      set eq [string first "=" $line]
615      if {$eq > 0} {
616        set field [string range $line 0 [expr {$eq - 1}]]
617        set value [string trim [string range $line [expr {$eq+1}] end] ']
618        #set value [read_sh_subst [string range $line [expr {$eq+1}] end] $local]
619        dict set result $field $value
620        incr $linecount
621      }
622    } err opts
623    if {[dict get $opts -code] != 0} {
624      #puts $opts
625      puts "Error reading line:\n$line\nerr: $err\n***"
626      return $err {*}$opts
627    }
628  }
629  return $result
630}
631
632###
633# A simpler form of read_sh_file tailored
634# to pulling data from a Makefile
635###
636proc ::practcl::read_Makefile filename {
637  set fin [open $filename r]
638  set result {}
639  while {[gets $fin line] >= 0} {
640    set line [string trim $line]
641    if {[string index $line 0] eq "#"} continue
642    if {$line eq {}} continue
643    catch {
644      set eq [string first "=" $line]
645      if {$eq > 0} {
646        set field [string trim [string range $line 0 [expr {$eq - 1}]]]
647        set value [string trim [string trim [string range $line [expr {$eq+1}] end] ']]
648        switch $field {
649          PKG_LIB_FILE {
650            dict set result libfile $value
651          }
652          srcdir {
653            if {$value eq "."} {
654              dict set result srcdir [file dirname $filename]
655            } else {
656              dict set result srcdir $value
657            }
658          }
659          PACKAGE_NAME {
660            dict set result name $value
661          }
662          PACKAGE_VERSION {
663            dict set result version $value
664          }
665          LIBS {
666            dict set result PRACTCL_LIBS $value
667          }
668          PKG_LIB_FILE {
669            dict set result libfile $value
670          }
671        }
672      }
673    } err opts
674    if {[dict get $opts -code] != 0} {
675      #puts $opts
676      puts "Error reading line:\n$line\nerr: $err\n***"
677      return $err {*}$opts
678    }
679    # the Compile field is about where most TEA files start getting silly
680    if {$field eq "compile"} {
681      break
682    }
683  }
684  return $result
685}
686
687## Append arguments to a buffer
688# The command works like puts in that each call will also insert
689# a line feed. Unlike puts, blank links in the interstitial are
690# suppressed
691proc ::practcl::cputs {varname args} {
692  upvar 1 $varname buffer
693  if {[llength $args]==1 && [string length [string trim [lindex $args 0]]] == 0} {
694
695  }
696  if {[info exist buffer]} {
697    if {[string index $buffer end] ne "\n"} {
698      append buffer \n
699    }
700  } else {
701    set buffer \n
702  }
703  # Trim leading \n's
704  append buffer [string trimleft [lindex $args 0] \n] {*}[lrange $args 1 end]
705}
706
707proc ::practcl::tcl_to_c {body} {
708  set result {}
709  foreach rawline [split $body \n] {
710    set line [string map [list \" \\\" \\ \\\\] $rawline]
711    cputs result "\n        \"$line\\n\" \\"
712  }
713  return [string trimright $result \\]
714}
715
716
717proc ::practcl::_tagblock {text {style tcl} {note {}}} {
718  if {[string length [string trim $text]]==0} {
719    return {}
720  }
721  set output {}
722  switch $style {
723    tcl {
724      ::practcl::cputs output "# BEGIN $note"
725    }
726    c {
727      ::practcl::cputs output "/* BEGIN $note */"
728    }
729    default {
730      ::practcl::cputs output "# BEGIN $note"
731    }
732  }
733  ::practcl::cputs output $text
734  switch $style {
735    tcl {
736      ::practcl::cputs output "# END $note"
737    }
738    c {
739      ::practcl::cputs output "/* END $note */"
740    }
741    default {
742      ::practcl::cputs output "# END $note"
743    }
744  }
745  return $output
746}
747
748proc ::practcl::de_shell {data} {
749  set values {}
750  foreach flag {DEFS TCL_DEFS TK_DEFS} {
751    if {[dict exists $data $flag]} {
752      #set value {}
753      #foreach item [dict get $data $flag] {
754      #  append value " " [string map {{ } {\ }} $item]
755      #}
756      dict set values $flag [dict get $data $flag]
757    }
758  }
759  set map {}
760  lappend map {${PKG_OBJECTS}} %LIBRARY_OBJECTS%
761  lappend map {$(PKG_OBJECTS)} %LIBRARY_OBJECTS%
762  lappend map {${PKG_STUB_OBJECTS}} %LIBRARY_STUB_OBJECTS%
763  lappend map {$(PKG_STUB_OBJECTS)} %LIBRARY_STUB_OBJECTS%
764
765  if {[dict exists $data name]} {
766    lappend map %LIBRARY_NAME% [dict get $data name]
767    lappend map %LIBRARY_VERSION% [dict get $data version]
768    lappend map %LIBRARY_VERSION_NODOTS% [string map {. {}} [dict get $data version]]
769    if {[dict exists $data libprefix]} {
770      lappend map %LIBRARY_PREFIX% [dict get $data libprefix]
771    } else {
772      lappend map %LIBRARY_PREFIX% [dict get $data prefix]
773    }
774  }
775  foreach flag [dict keys $data] {
776    if {$flag in {TCL_DEFS TK_DEFS DEFS}} continue
777    set value [string trim [dict get $data $flag] \"]
778    dict set map "\$\{${flag}\}" $value
779    dict set map "\$\(${flag}\)" $value
780    #dict set map "\$${flag}" $value
781    dict set map "%${flag}%" $value
782    dict set values $flag [dict get $data $flag]
783    #dict set map "\$\{${flag}\}" $proj($flag)
784  }
785  set changed 1
786  while {$changed} {
787    set changed 0
788    foreach {field value} $values {
789      if {$field in {TCL_DEFS TK_DEFS DEFS}} continue
790      dict with values {}
791      set newval [string map $map $value]
792      if {$newval eq $value} continue
793      set changed 1
794      dict set values $field $newval
795    }
796  }
797  return $values
798}
799
800###
801# END: buildutil.tcl
802###
803###
804# START: fileutil.tcl
805###
806###
807# Bits stolen from fileutil
808###
809proc ::practcl::cat fname {
810    if {![file exists $fname]} {
811       return
812    }
813    set fin [open $fname r]
814    set data [read $fin]
815    close $fin
816    return $data
817}
818
819proc ::practcl::grep {pattern {files {}}} {
820    set result [list]
821    if {[llength $files] == 0} {
822	      # read from stdin
823    	  set lnum 0
824	      while {[gets stdin line] >= 0} {
825	          incr lnum
826    	      if {[regexp -- $pattern $line]} {
827		            lappend result "${lnum}:${line}"
828	          }
829    	  }
830    } else {
831	      foreach filename $files {
832            set file [open $filename r]
833            set lnum 0
834            while {[gets $file line] >= 0} {
835                incr lnum
836                if {[regexp -- $pattern $line]} {
837                    lappend result "${filename}:${lnum}:${line}"
838                }
839            }
840            close $file
841    	  }
842    }
843    return $result
844}
845
846proc ::practcl::file_lexnormalize {sp} {
847    set spx [file split $sp]
848
849    # Resolution of embedded relative modifiers (., and ..).
850
851    if {
852	([lsearch -exact $spx . ] < 0) &&
853	([lsearch -exact $spx ..] < 0)
854    } {
855	# Quick path out if there are no relative modifiers
856	return $sp
857    }
858
859    set absolute [expr {![string equal [file pathtype $sp] relative]}]
860    # A volumerelative path counts as absolute for our purposes.
861
862    set sp $spx
863    set np {}
864    set noskip 1
865
866    while {[llength $sp]} {
867	set ele    [lindex $sp 0]
868	set sp     [lrange $sp 1 end]
869	set islast [expr {[llength $sp] == 0}]
870
871	if {[string equal $ele ".."]} {
872	    if {
873		($absolute  && ([llength $np] >  1)) ||
874		(!$absolute && ([llength $np] >= 1))
875	    } {
876		# .. : Remove the previous element added to the
877		# new path, if there actually is enough to remove.
878		set np [lrange $np 0 end-1]
879	    }
880	} elseif {[string equal $ele "."]} {
881	    # Ignore .'s, they stay at the current location
882	    continue
883	} else {
884	    # A regular element.
885	    lappend np $ele
886	}
887    }
888    if {[llength $np] > 0} {
889	return [eval [linsert $np 0 file join]]
890	# 8.5: return [file join {*}$np]
891    }
892    return {}
893}
894
895proc ::practcl::file_relative {base dst} {
896    # Ensure that the link to directory 'dst' is properly done relative to
897    # the directory 'base'.
898
899    if {![string equal [file pathtype $base] [file pathtype $dst]]} {
900	return -code error "Unable to compute relation for paths of different pathtypes: [file pathtype $base] vs. [file pathtype $dst], ($base vs. $dst)"
901    }
902
903    set base [file_lexnormalize [file join [pwd] $base]]
904    set dst  [file_lexnormalize [file join [pwd] $dst]]
905
906    set save $dst
907    set base [file split $base]
908    set dst  [file split $dst]
909
910    while {[string equal [lindex $dst 0] [lindex $base 0]]} {
911	set dst  [lrange $dst  1 end]
912	set base [lrange $base 1 end]
913	if {![llength $dst]} {break}
914    }
915
916    set dstlen  [llength $dst]
917    set baselen [llength $base]
918
919    if {($dstlen == 0) && ($baselen == 0)} {
920	# Cases:
921	# (a) base == dst
922
923	set dst .
924    } else {
925	# Cases:
926	# (b) base is: base/sub = sub
927	#     dst  is: base     = {}
928
929	# (c) base is: base     = {}
930	#     dst  is: base/sub = sub
931
932	while {$baselen > 0} {
933	    set dst [linsert $dst 0 ..]
934	    incr baselen -1
935	}
936	# 8.5: set dst [file join {*}$dst]
937	set dst [eval [linsert $dst 0 file join]]
938    }
939
940    return $dst
941}
942
943proc ::practcl::log {fname comment} {
944  set fname [file normalize $fname]
945  if {[info exists ::practcl::logchan($fname)]} {
946    set fout $::practcl::logchan($fname)
947    after cancel $::practcl::logevent($fname)
948  } else {
949    set fout [open $fname a]
950  }
951  puts $fout $comment
952  # Defer close until idle
953  set ::practcl::logevent($fname) [after idle "close $fout ; unset ::practcl::logchan($fname)"]
954}
955
956###
957# END: fileutil.tcl
958###
959###
960# START: installutil.tcl
961###
962###
963# Installer tools
964###
965proc ::practcl::_isdirectory name {
966  return [file isdirectory $name]
967}
968###
969# Return true if the pkgindex file contains
970# any statement other than "package ifneeded"
971# and/or if any package ifneeded loads a DLL
972###
973proc ::practcl::_pkgindex_directory {path} {
974  set buffer {}
975  set pkgidxfile [file join $path pkgIndex.tcl]
976  if {![file exists $pkgidxfile]} {
977    # No pkgIndex file, read the source
978    foreach file [glob -nocomplain $path/*.tm] {
979      set file [file normalize $file]
980      set fname [file rootname [file tail $file]]
981      ###
982      # We used to be able to ... Assume the package is correct in the filename
983      # No hunt for a "package provides"
984      ###
985      set package [lindex [split $fname -] 0]
986      set version [lindex [split $fname -] 1]
987      ###
988      # Read the file, and override assumptions as needed
989      ###
990      set fin [open $file r]
991      set dat [read $fin]
992      close $fin
993      # Look for a teapot style Package statement
994      foreach line [split $dat \n] {
995        set line [string trim $line]
996        if { [string range $line 0 9] != "# Package " } continue
997        set package [lindex $line 2]
998        set version [lindex $line 3]
999        break
1000      }
1001      # Look for a package provide statement
1002      foreach line [split $dat \n] {
1003        set line [string trim $line]
1004        if { [string range $line 0 14] != "package provide" } continue
1005        set package [lindex $line 2]
1006        set version [lindex $line 3]
1007        break
1008      }
1009      if {[string trim $version] ne {}} {
1010        append buffer "package ifneeded $package $version \[list source \[file join \$dir [file tail $file]\]\]" \n
1011      }
1012    }
1013    foreach file [glob -nocomplain $path/*.tcl] {
1014      if { [file tail $file] == "version_info.tcl" } continue
1015      set fin [open $file r]
1016      set dat [read $fin]
1017      close $fin
1018      if {![regexp "package provide" $dat]} continue
1019      set fname [file rootname [file tail $file]]
1020      # Look for a package provide statement
1021      foreach line [split $dat \n] {
1022        set line [string trim $line]
1023        if { [string range $line 0 14] != "package provide" } continue
1024        set package [lindex $line 2]
1025        set version [lindex $line 3]
1026        if {[string index $package 0] in "\$ \[ @"} continue
1027        if {[string index $version 0] in "\$ \[ @"} continue
1028        append buffer "package ifneeded $package $version \[list source \[file join \$dir [file tail $file]\]\]" \n
1029        break
1030      }
1031    }
1032    return $buffer
1033  }
1034  set fin [open $pkgidxfile r]
1035  set dat [read $fin]
1036  close $fin
1037  set trace 0
1038  #if {[file tail $path] eq "tool"} {
1039  #  set trace 1
1040  #}
1041  set thisline {}
1042  foreach line [split $dat \n] {
1043    append thisline $line \n
1044    if {![info complete $thisline]} continue
1045    set line [string trim $line]
1046    if {[string length $line]==0} {
1047      set thisline {} ; continue
1048    }
1049    if {[string index $line 0] eq "#"} {
1050      set thisline {} ; continue
1051    }
1052    if {[regexp "if.*catch.*package.*Tcl.*return" $thisline]} {
1053      if {$trace} {puts "[file dirname $pkgidxfile] Ignoring $thisline"}
1054      set thisline {} ; continue
1055    }
1056    if {[regexp "if.*package.*vsatisfies.*package.*provide.*return" $thisline]} {
1057      if {$trace} { puts "[file dirname $pkgidxfile] Ignoring $thisline" }
1058      set thisline {} ; continue
1059    }
1060    if {![regexp "package.*ifneeded" $thisline]} {
1061      # This package index contains arbitrary code
1062      # source instead of trying to add it to the master
1063      # package index
1064      if {$trace} { puts "[file dirname $pkgidxfile] Arbitrary code $thisline" }
1065      return {source [file join $dir pkgIndex.tcl]}
1066    }
1067    append buffer $thisline \n
1068    set thisline {}
1069  }
1070  if {$trace} {puts [list [file dirname $pkgidxfile] $buffer]}
1071  return $buffer
1072}
1073
1074
1075proc ::practcl::_pkgindex_path_subdir {path} {
1076  set result {}
1077  foreach subpath [glob -nocomplain [file join $path *]] {
1078    if {[file isdirectory $subpath]} {
1079      lappend result $subpath {*}[_pkgindex_path_subdir $subpath]
1080    }
1081  }
1082  return $result
1083}
1084###
1085# Index all paths given as though they will end up in the same
1086# virtual file system
1087###
1088proc ::practcl::pkgindex_path {args} {
1089  set stack {}
1090  set buffer {
1091lappend ::PATHSTACK $dir
1092  }
1093  foreach base $args {
1094    set base [file normalize $base]
1095    set paths {}
1096    foreach dir [glob -nocomplain [file join $base *]] {
1097      if {[file tail $dir] eq "teapot"} continue
1098      lappend paths $dir {*}[::practcl::_pkgindex_path_subdir $dir]
1099    }
1100    set i    [string length  $base]
1101    # Build a list of all of the paths
1102    if {[llength $paths]} {
1103      foreach path $paths {
1104        if {$path eq $base} continue
1105        set path_indexed($path) 0
1106      }
1107    } else {
1108      puts [list WARNING: NO PATHS FOUND IN $base]
1109    }
1110    set path_indexed($base) 1
1111    set path_indexed([file join $base boot tcl]) 1
1112    foreach path $paths {
1113      if {$path_indexed($path)} continue
1114      set thisdir [file_relative $base $path]
1115      set idxbuf [::practcl::_pkgindex_directory $path]
1116      if {[string length $idxbuf]} {
1117        incr path_indexed($path)
1118        append buffer "set dir \[set PKGDIR \[file join \[lindex \$::PATHSTACK end\] $thisdir\]\]" \n
1119        append buffer [string map {$dir $PKGDIR} [string trimright $idxbuf]] \n
1120      }
1121    }
1122  }
1123  append buffer {
1124set dir [lindex $::PATHSTACK end]
1125set ::PATHSTACK [lrange $::PATHSTACK 0 end-1]
1126}
1127  return $buffer
1128}
1129
1130proc ::practcl::installDir {d1 d2} {
1131  puts [format {%*sCreating %s} [expr {4 * [info level]}] {} [file tail $d2]]
1132  file delete -force -- $d2
1133  file mkdir $d2
1134
1135  foreach ftail [glob -directory $d1 -nocomplain -tails *] {
1136    set f [file join $d1 $ftail]
1137    if {[file isdirectory $f] && [string compare CVS $ftail]} {
1138      installDir $f [file join $d2 $ftail]
1139    } elseif {[file isfile $f]} {
1140	    file copy -force $f [file join $d2 $ftail]
1141	    if {$::tcl_platform(platform) eq {unix}} {
1142        file attributes [file join $d2 $ftail] -permissions 0644
1143	    } else {
1144        file attributes [file join $d2 $ftail] -readonly 1
1145	    }
1146    }
1147  }
1148
1149  if {$::tcl_platform(platform) eq {unix}} {
1150    file attributes $d2 -permissions 0755
1151  } else {
1152    file attributes $d2 -readonly 1
1153  }
1154}
1155
1156proc ::practcl::copyDir {d1 d2 {toplevel 1}} {
1157  #if {$toplevel} {
1158  #  puts [list ::practcl::copyDir $d1 -> $d2]
1159  #}
1160  #file delete -force -- $d2
1161  file mkdir $d2
1162  if {[file isfile $d1]} {
1163    file copy -force $d1 $d2
1164    set ftail [file tail $d1]
1165    if {$::tcl_platform(platform) eq {unix}} {
1166      file attributes [file join $d2 $ftail] -permissions 0644
1167    } else {
1168      file attributes [file join $d2 $ftail] -readonly 1
1169    }
1170  } else {
1171    foreach ftail [glob -directory $d1 -nocomplain -tails *] {
1172      set f [file join $d1 $ftail]
1173      if {[file isdirectory $f] && [string compare CVS $ftail]} {
1174        copyDir $f [file join $d2 $ftail] 0
1175      } elseif {[file isfile $f]} {
1176        file copy -force $f [file join $d2 $ftail]
1177        if {$::tcl_platform(platform) eq {unix}} {
1178          file attributes [file join $d2 $ftail] -permissions 0644
1179        } else {
1180          file attributes [file join $d2 $ftail] -readonly 1
1181        }
1182      }
1183    }
1184  }
1185}
1186
1187###
1188# END: installutil.tcl
1189###
1190###
1191# START: makeutil.tcl
1192###
1193###
1194# Backward compatible Make facilities
1195# These were used early in development and are consdiered deprecated
1196###
1197
1198proc ::practcl::trigger {args} {
1199  ::practcl::LOCAL make trigger {*}$args
1200  foreach {name obj} [::practcl::LOCAL make objects] {
1201    set ::make($name) [$obj do]
1202  }
1203}
1204
1205proc ::practcl::depends {args} {
1206  ::practcl::LOCAL make depends {*}$args
1207}
1208
1209proc ::practcl::target {name info {action {}}} {
1210  set obj [::practcl::LOCAL make task $name $info $action]
1211  set ::make($name) 0
1212  set filename [$obj define get filename]
1213  if {$filename ne {}} {
1214    set ::target($name) $filename
1215  }
1216}
1217###
1218# END: makeutil.tcl
1219###
1220###
1221# START: class metaclass.tcl
1222###
1223::oo::class create ::practcl::metaclass {
1224  superclass ::oo::object
1225
1226  method _MorphPatterns {} {
1227    return {{@name@} {::practcl::@name@} {::practcl::*@name@} {::practcl::*@name@*}}
1228  }
1229
1230  method define {submethod args} {
1231    my variable define
1232    switch $submethod {
1233      dump {
1234        return [array get define]
1235      }
1236      add {
1237        set field [lindex $args 0]
1238        if {![info exists define($field)]} {
1239          set define($field) {}
1240        }
1241        foreach arg [lrange $args 1 end] {
1242          if {$arg ni $define($field)} {
1243            lappend define($field) $arg
1244          }
1245        }
1246        return $define($field)
1247      }
1248      remove {
1249        set field [lindex $args 0]
1250        if {![info exists define($field)]} {
1251          return
1252        }
1253        set rlist [lrange $args 1 end]
1254        set olist $define($field)
1255        set nlist {}
1256        foreach arg $olist {
1257          if {$arg in $rlist} continue
1258          lappend nlist $arg
1259        }
1260        set define($field) $nlist
1261        return $nlist
1262      }
1263      exists {
1264        set field [lindex $args 0]
1265        return [info exists define($field)]
1266      }
1267      getnull -
1268      get -
1269      cget {
1270        set field [lindex $args 0]
1271        if {[info exists define($field)]} {
1272          return $define($field)
1273        }
1274        return [lindex $args 1]
1275      }
1276      set {
1277        if {[llength $args]==1} {
1278          set arglist [lindex $args 0]
1279        } else {
1280          set arglist $args
1281        }
1282        array set define $arglist
1283        if {[dict exists $arglist class]} {
1284          my select
1285        }
1286      }
1287      default {
1288        array $submethod define {*}$args
1289      }
1290    }
1291  }
1292
1293
1294  method meta {submethod args} {
1295    my variable meta
1296    if {![info exists meta]} {
1297      set meta {}
1298    }
1299    switch $submethod {
1300      dump {
1301        return $meta
1302      }
1303      add {
1304        set field [lindex $args 0]
1305        if {![dict exists $meta $field]} {
1306          dict set meta $field {}
1307        }
1308        foreach arg [lrange $args 1 end] {
1309          if {$arg ni [dict get $meta $field]} {
1310            dict lappend meta $field $arg
1311          }
1312        }
1313        return [dict get $meta $field]
1314      }
1315      remove {
1316        set field [lindex $args 0]
1317        if {![dict exists meta $field]} {
1318          return
1319        }
1320        set rlist [lrange $args 1 end]
1321        set olist [dict get $meta $field]
1322        set nlist {}
1323        foreach arg $olist {
1324          if {$arg in $rlist} continue
1325          lappend nlist $arg
1326        }
1327        dict set meta $field $nlist
1328        return $nlist
1329      }
1330      exists {
1331        return [dict exists $meta {*}$args]
1332      }
1333      getnull -
1334      get {
1335        if {[dict exists $meta {*}$args]} {
1336          return [dict get $meta {*}$args]
1337        }
1338        return {}
1339      }
1340      cget {
1341        set field [lindex $args 0]
1342        if {[dict exists $meta $field]} {
1343          return [dict get $meta $field]
1344        }
1345        return [lindex $args 1]
1346      }
1347      set {
1348        if {[llength $args]==1} {
1349          foreach {field value} $args {
1350            dict set meta [string trimright $field :]: $value
1351          }
1352        } else {
1353          set field [lindex $args end-1]
1354          set value [lindex $args end]
1355          dict set meta {*}[lrange $args 0 end-2] [string trimright $field :]: $value
1356        }
1357      }
1358      default {
1359        error "Valid: add cget dump exists get getnull remove set"
1360      }
1361    }
1362  }
1363
1364  method graft args {
1365    my variable organs
1366    if {[llength $args] == 1} {
1367      error "Need two arguments"
1368    }
1369    set object {}
1370    foreach {stub object} $args {
1371      dict set organs $stub $object
1372      oo::objdefine [self] forward <${stub}> $object
1373      oo::objdefine [self] export <${stub}>
1374    }
1375    return $object
1376  }
1377
1378  method initialize {} {}
1379
1380
1381  method link {command args} {
1382    my variable links
1383    switch $command {
1384      object {
1385        foreach obj $args {
1386          foreach linktype [$obj linktype] {
1387            my link add $linktype $obj
1388          }
1389        }
1390      }
1391      add {
1392        ###
1393        # Add a link to an object that was externally created
1394        ###
1395        if {[llength $args] ne 2} { error "Usage: link add LINKTYPE OBJECT"}
1396        lassign $args linktype object
1397        if {[info exists links($linktype)] && $object in $links($linktype)} {
1398          return
1399        }
1400        lappend links($linktype) $object
1401      }
1402      remove {
1403        set object [lindex $args 0]
1404        if {[llength $args]==1} {
1405          set ltype *
1406        } else {
1407          set ltype [lindex $args 1]
1408        }
1409        foreach {linktype elements} [array get links $ltype] {
1410          if {$object in $elements} {
1411            set nlist {}
1412            foreach e $elements {
1413              if { $object ne $e } { lappend nlist $e }
1414            }
1415            set links($linktype) $nlist
1416          }
1417        }
1418      }
1419      list {
1420        if {[llength $args]==0} {
1421          return [array get links]
1422        }
1423        if {[llength $args] != 1} { error "Usage: link list LINKTYPE"}
1424        set linktype [lindex $args 0]
1425        if {![info exists links($linktype)]} {
1426          return {}
1427        }
1428        return $links($linktype)
1429      }
1430      dump {
1431        return [array get links]
1432      }
1433    }
1434  }
1435
1436  method morph classname {
1437    my variable define
1438    if {$classname ne {}} {
1439      set map [list @name@ $classname]
1440      foreach pattern [string map $map [my _MorphPatterns]] {
1441        set pattern [string trim $pattern]
1442        set matches [info commands $pattern]
1443        if {![llength $matches]} continue
1444        set class [lindex $matches 0]
1445        break
1446      }
1447      set mixinslot {}
1448      foreach {slot pattern} {
1449        distribution ::practcl::distribution*
1450        product      ::practcl::product*
1451        toolset      ::practcl::toolset*
1452      } {
1453        if {[string match $pattern $class]} {
1454           set mixinslot $slot
1455           break
1456        }
1457      }
1458      if {$mixinslot ne {}} {
1459        my mixin $mixinslot $class
1460      } elseif {[info command $class] ne {}} {
1461        if {[info object class [self]] ne $class} {
1462          ::oo::objdefine [self] class $class
1463          ::practcl::debug [self] morph $class
1464           my define set class $class
1465        }
1466      } else {
1467        error "[self] Could not detect class for $classname"
1468      }
1469    }
1470    if {[::info exists define(oodefine)]} {
1471      ::oo::objdefine [self] $define(oodefine)
1472      #unset define(oodefine)
1473    }
1474  }
1475
1476  method mixin {slot classname} {
1477    my variable mixinslot
1478    set class {}
1479    set map [list @slot@ $slot @name@ $classname]
1480    foreach pattern [split [string map $map {
1481      @name@
1482      @slot@.@name@
1483      ::practcl::@name@
1484      ::practcl::@slot@.@name@
1485      ::practcl::@slot@*@name@
1486      ::practcl::*@name@*
1487    }] \n] {
1488      set pattern [string trim $pattern]
1489      set matches [info commands $pattern]
1490      if {![llength $matches]} continue
1491      set class [lindex $matches 0]
1492      break
1493    }
1494    ::practcl::debug [self] mixin $slot $class
1495    dict set mixinslot $slot $class
1496    set mixins {}
1497    foreach {s c} $mixinslot {
1498      if {$c eq {}} continue
1499      lappend mixins $c
1500    }
1501    oo::objdefine [self] mixin {*}$mixins
1502  }
1503
1504  method organ {{stub all}} {
1505    my variable organs
1506    if {![info exists organs]} {
1507      return {}
1508    }
1509    if { $stub eq "all" } {
1510      return $organs
1511    }
1512    if {[dict exists $organs $stub]} {
1513      return [dict get $organs $stub]
1514    }
1515  }
1516
1517  method script script {
1518    eval $script
1519  }
1520
1521  method select {} {
1522    my variable define
1523    if {[info exists define(class)]} {
1524      my morph $define(class)
1525    } else {
1526      if {[::info exists define(oodefine)]} {
1527        ::oo::objdefine [self] $define(oodefine)
1528        #unset define(oodefine)
1529      }
1530    }
1531  }
1532
1533  method source filename {
1534    source $filename
1535  }
1536}
1537
1538###
1539# END: class metaclass.tcl
1540###
1541###
1542# START: class toolset baseclass.tcl
1543###
1544###
1545# Ancestor-less class intended to be a mixin
1546# which defines a family of build related behaviors
1547# that are modified when targetting either gcc or msvc
1548###
1549oo::class create ::practcl::toolset {
1550  ###
1551  # find or fake a key/value list describing this project
1552  ###
1553  method config.sh {} {
1554    return [my read_configuration]
1555  }
1556
1557  method BuildDir {PWD} {
1558    set name [my define get name]
1559    set debug [my define get debug 0]
1560    if {[my <project> define get LOCAL 0]} {
1561      return [my define get builddir [file join $PWD local $name]]
1562    }
1563    if {$debug} {
1564      return [my define get builddir [file join $PWD debug $name]]
1565    } else {
1566      return [my define get builddir [file join $PWD pkg $name]]
1567    }
1568  }
1569
1570  method MakeDir {srcdir} {
1571    return $srcdir
1572  }
1573
1574  method read_configuration {} {
1575    my variable conf_result
1576    if {[info exists conf_result]} {
1577      return $conf_result
1578    }
1579    set result {}
1580    set name [my define get name]
1581    set PWD $::CWD
1582    set builddir [my define get builddir]
1583    my unpack
1584    set srcdir [my define get srcdir]
1585    if {![file exists $builddir]} {
1586      my Configure
1587    }
1588    set filename [file join $builddir config.tcl]
1589    # Project uses the practcl template. Use the leavings from autoconf
1590    if {[file exists $filename]} {
1591      set dat [::practcl::read_configuration $builddir]
1592      foreach {item value} [::practcl::sort_dict $dat] {
1593        dict set result $item $value
1594      }
1595      set conf_result $result
1596      return $result
1597    }
1598    set filename [file join $builddir ${name}Config.sh]
1599    if {[file exists $filename]} {
1600      set l [expr {[string length $name]+1}]
1601      foreach {field dat} [::practcl::read_Config.sh $filename] {
1602        set field [string tolower $field]
1603        if {[string match ${name}_* $field]} {
1604          set field [string range $field $l end]
1605        }
1606        switch $field {
1607          version {
1608            dict set result pkg_vers $dat
1609          }
1610          lib_file {
1611            set field libfile
1612          }
1613        }
1614        dict set result $field $dat
1615      }
1616      set conf_result $result
1617      return $result
1618    }
1619    ###
1620    # Oh man... we have to guess
1621    ###
1622    set filename [file join $builddir Makefile]
1623    if {![file exists $filename]} {
1624      error "Could not locate any configuration data in $srcdir"
1625    }
1626    foreach {field dat} [::practcl::read_Makefile $filename] {
1627      dict set result $field $dat
1628    }
1629    if {![dict exists $result PRACTCL_PKG_LIBS] && [dict exists $result LIBS]} {
1630      dict set result PRACTCL_PKG_LIBS [dict get $result LIBS]
1631    }
1632    set conf_result $result
1633    cd $PWD
1634    return $result
1635  }
1636
1637  ## method DEFS
1638  # This method populates 4 variables:
1639  # name - The name of the package
1640  # version - The version of the package
1641  # defs - C flags passed to the compiler
1642  # includedir - A list of paths to feed to the compiler for finding headers
1643  #
1644  method build-cflags {PROJECT DEFS namevar versionvar defsvar} {
1645    upvar 1 $namevar name $versionvar version NAME NAME $defsvar defs
1646    set name [string tolower [${PROJECT} define get name [${PROJECT} define get pkg_name]]]
1647    set NAME [string toupper $name]
1648    set version [${PROJECT} define get version [${PROJECT} define get pkg_vers]]
1649    if {$version eq {}} {
1650      set version 0.1a
1651    }
1652    set defs $DEFS
1653    foreach flag {
1654      -DPACKAGE_NAME
1655      -DPACKAGE_VERSION
1656      -DPACKAGE_TARNAME
1657      -DPACKAGE_STRING
1658    } {
1659      if {[set i [string first $flag $defs]] >= 0} {
1660        set j [string first -D $flag [expr {$i+[string length $flag]}]]
1661        set predef [string range $defs 0 [expr {$i-1}]]
1662        set postdef [string range $defs $j end]
1663        set defs "$predef $postdef"
1664      }
1665    }
1666    append defs " -DPACKAGE_NAME=\"${name}\" -DPACKAGE_VERSION=\"${version}\""
1667    append defs " -DPACKAGE_TARNAME=\"${name}\" -DPACKAGE_STRING=\"${name}\x5c\x20${version}\""
1668    return $defs
1669  }
1670
1671  method critcl args {
1672    if {![info exists critcl]} {
1673      ::practcl::LOCAL tool critcl env-load
1674      set critcl [file join [::practcl::LOCAL tool critcl define get srcdir] main.tcl
1675    }
1676    set srcdir [my SourceRoot]
1677    set PWD [pwd]
1678    cd $srcdir
1679    ::practcl::dotclexec $critcl {*}$args
1680    cd $PWD
1681  }
1682
1683  method make-autodetect {} {}
1684}
1685
1686
1687oo::objdefine ::practcl::toolset {
1688
1689
1690  method select object {
1691    ###
1692    # Select the toolset to use for this project
1693    ###
1694    if {[$object define exists toolset]} {
1695      return [$object define get toolset]
1696    }
1697    set class [$object define get toolset]
1698    if {$class ne {}} {
1699      $object mixin toolset $class
1700    } else {
1701      if {[info exists ::env(VisualStudioVersion)]} {
1702        $object mixin toolset ::practcl::toolset.msvc
1703      } else {
1704        $object mixin toolset ::practcl::toolset.gcc
1705      }
1706    }
1707  }
1708}
1709
1710###
1711# END: class toolset baseclass.tcl
1712###
1713###
1714# START: class toolset gcc.tcl
1715###
1716
1717::oo::class create ::practcl::toolset.gcc {
1718  superclass ::practcl::toolset
1719
1720  method Autoconf {} {
1721    ###
1722    # Re-run autoconf for this project
1723    # Not a good idea in practice... but in the right hands it can be useful
1724    ###
1725    set pwd [pwd]
1726    set srcdir [file normalize [my define get srcdir]]
1727    cd $srcdir
1728    foreach template {configure.ac configure.in} {
1729      set input [file join $srcdir $template]
1730      if {[file exists $input]} {
1731        puts "autoconf -f $input > [file join $srcdir configure]"
1732        exec autoconf -f $input > [file join $srcdir configure]
1733      }
1734    }
1735    cd $pwd
1736  }
1737
1738  method BuildDir {PWD} {
1739    set name [my define get name]
1740    set debug [my define get debug 0]
1741    if {[my <project> define get LOCAL 0]} {
1742      return [my define get builddir [file join $PWD local $name]]
1743    }
1744    if {$debug} {
1745      return [my define get builddir [file join $PWD debug $name]]
1746    } else {
1747      return [my define get builddir [file join $PWD pkg $name]]
1748    }
1749  }
1750
1751  method ConfigureOpts {} {
1752    set opts {}
1753    set builddir [my define get builddir]
1754
1755    if {[my define get broken_destroot 0]} {
1756      set PREFIX [my <project> define get prefix_broken_destdir]
1757    } else {
1758      set PREFIX [my <project> define get prefix]
1759    }
1760    switch [my define get name] {
1761      tcl {
1762        set opts [::practcl::platform::tcl_core_options [my <project> define get TEACUP_OS]]
1763      }
1764      tk {
1765        set opts [::practcl::platform::tk_core_options  [my <project> define get TEACUP_OS]]
1766      }
1767    }
1768    if {[my <project> define get CONFIG_SITE] != {}} {
1769      lappend opts --host=[my <project> define get HOST]
1770    }
1771    set inside_msys [string is true -strict [my <project> define get MSYS_ENV 0]]
1772    lappend opts --with-tclsh=[info nameofexecutable]
1773    if {![my <project> define get LOCAL 0]} {
1774      set obj [my <project> tclcore]
1775      if {$obj ne {}} {
1776        if {$inside_msys} {
1777          lappend opts --with-tcl=[::practcl::file_relative [file normalize $builddir] [$obj define get builddir]]
1778        } else {
1779          lappend opts --with-tcl=[file normalize [$obj define get builddir]]
1780        }
1781      }
1782      if {[my define get tk 0]} {
1783        set obj [my <project> tkcore]
1784        if {$obj ne {}} {
1785          if {$inside_msys} {
1786            lappend opts --with-tk=[::practcl::file_relative [file normalize $builddir] [$obj define get builddir]]
1787          } else {
1788            lappend opts --with-tk=[file normalize [$obj define get builddir]]
1789          }
1790        }
1791      }
1792    } else {
1793      lappend opts --with-tcl=[file join $PREFIX lib]
1794      if {[my define get tk 0]} {
1795        lappend opts --with-tk=[file join $PREFIX lib]
1796      }
1797    }
1798
1799    lappend opts {*}[my define get config_opts]
1800    if {![regexp -- "--prefix" $opts]} {
1801      lappend opts --prefix=$PREFIX --exec-prefix=$PREFIX
1802    }
1803    if {[my define get debug 0]} {
1804      lappend opts --enable-symbols=true
1805    }
1806    #--exec_prefix=$PREFIX
1807    #if {$::tcl_platform(platform) eq "windows"} {
1808    #  lappend opts --disable-64bit
1809    #}
1810    if {[my define get static 1]} {
1811      lappend opts --disable-shared
1812      #--disable-stubs
1813      #
1814    } else {
1815      lappend opts --enable-shared
1816    }
1817    return $opts
1818  }
1819
1820  # Detect what directory contains the Makefile template
1821  method MakeDir {srcdir} {
1822    set localsrcdir $srcdir
1823    if {[file exists [file join $srcdir generic]]} {
1824      my define add include_dir [file join $srcdir generic]
1825    }
1826    set os [my <project> define get TEACUP_OS]
1827    switch $os {
1828      windows {
1829        if {[file exists [file join $srcdir win]]} {
1830          my define add include_dir [file join $srcdir win]
1831        }
1832        if {[file exists [file join $srcdir win Makefile.in]]} {
1833          set localsrcdir [file join $srcdir win]
1834        }
1835      }
1836      default {
1837        if {[file exists [file join $srcdir $os]]} {
1838          my define add include_dir [file join $srcdir $os]
1839        }
1840        if {[file exists [file join $srcdir unix]]} {
1841          my define add include_dir [file join $srcdir unix]
1842        }
1843        if {[file exists [file join $srcdir $os Makefile.in]]} {
1844          set localsrcdir [file join $srcdir $os]
1845        } elseif {[file exists [file join $srcdir unix Makefile.in]]} {
1846          set localsrcdir [file join $srcdir unix]
1847        }
1848      }
1849    }
1850    return $localsrcdir
1851  }
1852
1853  method make-autodetect {} {
1854    set srcdir [my define get srcdir]
1855    set localsrcdir [my define get localsrcdir]
1856    if {$srcdir eq $localsrcdir} {
1857      if {![file exists [file join $srcdir tclconfig install-sh]]} {
1858        # ensure we have tclconfig with all of the trimmings
1859        set teapath {}
1860        if {[file exists [file join $srcdir .. tclconfig install-sh]]} {
1861          set teapath [file join $srcdir .. tclconfig]
1862        } else {
1863          set tclConfigObj [::practcl::LOCAL tool tclconfig]
1864          $tclConfigObj load
1865          set teapath [$tclConfigObj define get srcdir]
1866        }
1867        set teapath [file normalize $teapath]
1868        #file mkdir [file join $srcdir tclconfig]
1869        if {[catch {file link -symbolic [file join $srcdir tclconfig] $teapath}]} {
1870          ::practcl::copyDir [file join $teapath] [file join $srcdir tclconfig]
1871        }
1872      }
1873    }
1874    set builddir [my define get builddir]
1875    file mkdir $builddir
1876    if {![file exists [file join $localsrcdir configure]]} {
1877      if {[file exists [file join $localsrcdir autogen.sh]]} {
1878        cd $localsrcdir
1879        catch {exec sh autogen.sh >>& [file join $builddir autoconf.log]}
1880        cd $::CWD
1881      }
1882    }
1883    set opts [my ConfigureOpts]
1884    if {[file exists [file join $builddir autoconf.log]]} {
1885      file delete [file join $builddir autoconf.log]
1886    }
1887    ::practcl::debug [list PKG [my define get name] CONFIGURE {*}$opts]
1888    ::practcl::log   [file join $builddir autoconf.log] [list  CONFIGURE {*}$opts]
1889    cd $builddir
1890    if {[my <project> define get CONFIG_SITE] ne {}} {
1891      set ::env(CONFIG_SITE) [my <project> define get CONFIG_SITE]
1892    }
1893    catch {exec sh [file join $localsrcdir configure] {*}$opts >>& [file join $builddir autoconf.log]}
1894    cd $::CWD
1895  }
1896
1897  method make-clean {} {
1898    set builddir [file normalize [my define get builddir]]
1899    catch {::practcl::domake $builddir clean}
1900  }
1901
1902  method make-compile {} {
1903    set name [my define get name]
1904    set srcdir [my define get srcdir]
1905    if {[my define get static 1]} {
1906      puts "BUILDING Static $name $srcdir"
1907    } else {
1908      puts "BUILDING Dynamic $name $srcdir"
1909    }
1910    cd $::CWD
1911    set builddir [file normalize [my define get builddir]]
1912    file mkdir $builddir
1913    if {![file exists [file join $builddir Makefile]]} {
1914      my Configure
1915    }
1916    if {[file exists [file join $builddir make.tcl]]} {
1917      if {[my define get debug 0]} {
1918        ::practcl::domake.tcl $builddir debug all
1919      } else {
1920        ::practcl::domake.tcl $builddir all
1921      }
1922    } else {
1923      ::practcl::domake $builddir all
1924    }
1925  }
1926
1927  method make-install DEST {
1928    set PWD [pwd]
1929    set builddir [my define get builddir]
1930    if {[my <project> define get LOCAL 0] || $DEST eq {}} {
1931      if {[file exists [file join $builddir make.tcl]]} {
1932        puts "[self] Local INSTALL (Practcl)"
1933        ::practcl::domake.tcl $builddir install
1934      } else {[my define get broken_destroot 0] == 0} {
1935        puts "[self] Local INSTALL (TEA)"
1936        ::practcl::domake $builddir install
1937      }
1938    } else {
1939      if {[file exists [file join $builddir make.tcl]]} {
1940        # Practcl builds can inject right to where we need them
1941        puts "[self] VFS INSTALL $DEST (Practcl)"
1942        ::practcl::domake.tcl $builddir install-package $DEST
1943      } elseif {[my define get broken_destroot 0] == 0} {
1944        # Most modern TEA projects understand DESTROOT in the makefile
1945        puts "[self] VFS INSTALL $DEST (TEA)"
1946        ::practcl::domake $builddir install DESTDIR=[::practcl::file_relative $builddir $DEST]
1947      } else {
1948        # But some require us to do an install into a fictitious filesystem
1949        # and then extract the gooey parts within.
1950        # (*cough*) TkImg
1951        set PREFIX [my <project> define get prefix]
1952        set BROKENROOT [::practcl::msys_to_tclpath [my <project> define get prefix_broken_destdir]]
1953        file delete -force $BROKENROOT
1954        file mkdir $BROKENROOT
1955        ::practcl::domake $builddir $install
1956        ::practcl::copyDir $BROKENROOT  [file join $DEST [string trimleft $PREFIX /]]
1957        file delete -force $BROKENROOT
1958      }
1959    }
1960    cd $PWD
1961  }
1962
1963  method build-compile-sources {PROJECT COMPILE CPPCOMPILE INCLUDES} {
1964    set objext [my define get OBJEXT o]
1965    set EXTERN_OBJS {}
1966    set OBJECTS {}
1967    set result {}
1968    set builddir [$PROJECT define get builddir]
1969    file mkdir [file join $builddir objs]
1970    set debug [$PROJECT define get debug 0]
1971
1972    set task {}
1973    ###
1974    # Compile the C sources
1975    ###
1976    ::practcl::debug ### COMPILE PRODUCTS
1977    foreach {ofile info} [${PROJECT} project-compile-products] {
1978      ::practcl::debug $ofile $info
1979      if {[dict exists $info library]} {
1980        #dict set task $ofile done 1
1981        continue
1982      }
1983      # Products with no cfile aren't compiled
1984      if {![dict exists $info cfile] || [set cfile [dict get $info cfile]] eq {}} {
1985        #dict set task $ofile done 1
1986        continue
1987      }
1988      set ofile [file rootname $ofile]
1989      dict set task $ofile done 0
1990      if {[dict exists $info external] && [dict get $info external]==1} {
1991        dict set task $ofile external 1
1992      } else {
1993        dict set task $ofile external 0
1994      }
1995      set cfile [dict get $info cfile]
1996      if {$debug} {
1997        set ofilename [file join $builddir objs [file rootname [file tail $ofile]].debug.${objext}]
1998      } else {
1999        set ofilename [file join $builddir objs [file tail $ofile]].${objext}
2000      }
2001      dict set task $ofile source $cfile
2002      dict set task $ofile objfile $ofilename
2003      if {![dict exist $info command]} {
2004        if {[file extension $cfile] in {.c++ .cpp}} {
2005          set cmd $CPPCOMPILE
2006        } else {
2007          set cmd $COMPILE
2008        }
2009        if {[dict exists $info extra]} {
2010          append cmd " [dict get $info extra]"
2011        }
2012        append cmd " $INCLUDES"
2013        append cmd " -c $cfile"
2014        append cmd " -o $ofilename"
2015        dict set task $ofile command $cmd
2016      }
2017    }
2018    set completed 0
2019    while {$completed==0} {
2020      set completed 1
2021      foreach {ofile info} $task {
2022        set waiting {}
2023        if {[dict exists $info done] && [dict get $info done]} continue
2024        ::practcl::debug COMPILING $ofile $info
2025        set filename [dict get $info objfile]
2026        if {[file exists $filename] && [file mtime $filename]>[file mtime [dict get $info source]]} {
2027          lappend result $filename
2028          dict set task $ofile done 1
2029          continue
2030        }
2031        if {[dict exists $info depend]} {
2032          foreach file [dict get $info depend] {
2033            if {[dict exists $task $file command] && [dict exists $task $file done] && [dict get $task $file done] != 1} {
2034              set waiting $file
2035              break
2036            }
2037          }
2038        }
2039        if {$waiting ne {}} {
2040          set completed 0
2041          puts "$ofile waiting for $waiting"
2042          continue
2043        }
2044        if {[dict exists $info command]} {
2045          set cmd [dict get $info command]
2046          puts "$cmd"
2047          exec {*}$cmd >&@ stdout
2048        }
2049        if {[file exists $filename]} {
2050          lappend result $filename
2051          dict set task $ofile done 1
2052          continue
2053        }
2054        error "Failed to produce $filename"
2055      }
2056    }
2057    return $result
2058  }
2059
2060method build-Makefile {path PROJECT} {
2061  array set proj [$PROJECT define dump]
2062  set path $proj(builddir)
2063  cd $path
2064  set includedir .
2065  set objext [my define get OBJEXT o]
2066
2067  #lappend includedir [::practcl::file_relative $path $proj(TCL_INCLUDES)]
2068  lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TCL_SRC_DIR) generic]]]
2069  lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(srcdir) generic]]]
2070  foreach include [$PROJECT toolset-include-directory] {
2071    set cpath [::practcl::file_relative $path [file normalize $include]]
2072    if {$cpath ni $includedir} {
2073      lappend includedir $cpath
2074    }
2075  }
2076  set INCLUDES  "-I[join $includedir " -I"]"
2077  set NAME [string toupper $proj(name)]
2078  set result {}
2079  set products {}
2080  set libraries {}
2081  set thisline {}
2082  ::practcl::cputs result "${NAME}_DEFS = $proj(DEFS)\n"
2083  ::practcl::cputs result "${NAME}_INCLUDES = -I\"[join $includedir "\" -I\""]\"\n"
2084  ::practcl::cputs result "${NAME}_COMPILE = \$(CC) \$(CFLAGS) \$(PKG_CFLAGS) \$(${NAME}_DEFS) \$(${NAME}_INCLUDES) \$(INCLUDES) \$(AM_CPPFLAGS) \$(CPPFLAGS) \$(AM_CFLAGS)"
2085  ::practcl::cputs result "${NAME}_CPPCOMPILE = \$(CXX) \$(CFLAGS) \$(PKG_CFLAGS) \$(${NAME}_DEFS) \$(${NAME}_INCLUDES) \$(INCLUDES) \$(AM_CPPFLAGS) \$(CPPFLAGS) \$(AM_CFLAGS)"
2086
2087  foreach {ofile info} [$PROJECT project-compile-products] {
2088    dict set products $ofile $info
2089    set fname [file rootname ${ofile}].${objext}
2090    if {[dict exists $info library]} {
2091lappend libraries $ofile
2092continue
2093    }
2094    if {[dict exists $info depend]} {
2095      ::practcl::cputs result "\n${fname}: [dict get $info depend]"
2096    } else {
2097      ::practcl::cputs result "\n${fname}:"
2098    }
2099    set cfile [dict get $info cfile]
2100    if {[file extension $cfile] in {.c++ .cpp}} {
2101      set cmd "\t\$\(${NAME}_CPPCOMPILE\)"
2102    } else {
2103      set cmd "\t\$\(${NAME}_COMPILE\)"
2104    }
2105    if {[dict exists $info extra]} {
2106      append cmd " [dict get $info extra]"
2107    }
2108    append cmd " -c [dict get $info cfile] -o \$@\n\t"
2109    ::practcl::cputs result  $cmd
2110  }
2111
2112  set map {}
2113  lappend map %LIBRARY_NAME% $proj(name)
2114  lappend map %LIBRARY_VERSION% $proj(version)
2115  lappend map %LIBRARY_VERSION_NODOTS% [string map {. {}} $proj(version)]
2116  lappend map %LIBRARY_PREFIX% [$PROJECT define getnull libprefix]
2117
2118  if {[string is true [$PROJECT define get SHARED_BUILD]]} {
2119    set outfile [$PROJECT define get libfile]
2120  } else {
2121    set outfile [$PROJECT shared_library]
2122  }
2123  $PROJECT define set shared_library $outfile
2124  ::practcl::cputs result "
2125${NAME}_SHLIB = $outfile
2126${NAME}_OBJS = [dict keys $products]
2127"
2128
2129  #lappend map %OUTFILE% {\[$]@}
2130  lappend map %OUTFILE% $outfile
2131  lappend map %LIBRARY_OBJECTS% "\$(${NAME}_OBJS)"
2132  ::practcl::cputs result "$outfile: \$(${NAME}_OBJS)"
2133  ::practcl::cputs result "\t[string map $map [$PROJECT define get PRACTCL_SHARED_LIB]]"
2134  if {[$PROJECT define get PRACTCL_VC_MANIFEST_EMBED_DLL] ni {: {}}} {
2135    ::practcl::cputs result "\t[string map $map [$PROJECT define get PRACTCL_VC_MANIFEST_EMBED_DLL]]"
2136  }
2137  ::practcl::cputs result {}
2138  if {[string is true [$PROJECT define get SHARED_BUILD]]} {
2139    #set outfile [$PROJECT static_library]
2140    set outfile $proj(name).a
2141  } else {
2142    set outfile [$PROJECT define get libfile]
2143  }
2144  $PROJECT define set static_library $outfile
2145  dict set map %OUTFILE% $outfile
2146  ::practcl::cputs result "$outfile: \$(${NAME}_OBJS)"
2147  ::practcl::cputs result "\t[string map $map [$PROJECT define get PRACTCL_STATIC_LIB]]"
2148  ::practcl::cputs result {}
2149  return $result
2150}
2151
2152###
2153# Produce a static or dynamic library
2154###
2155method build-library {outfile PROJECT} {
2156  array set proj [$PROJECT define dump]
2157  set path $proj(builddir)
2158  cd $path
2159  set includedir .
2160  #lappend includedir [::practcl::file_relative $path $proj(TCL_INCLUDES)]
2161  lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TCL_SRC_DIR) generic]]]
2162  lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(srcdir) generic]]]
2163  if {[$PROJECT define get tk 0]} {
2164    lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TK_SRC_DIR) generic]]]
2165    lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TK_SRC_DIR) ttk]]]
2166    lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TK_SRC_DIR) xlib]]]
2167    lappend includedir [::practcl::file_relative $path [file normalize $proj(TK_BIN_DIR)]]
2168  }
2169  foreach include [$PROJECT toolset-include-directory] {
2170    set cpath [::practcl::file_relative $path [file normalize $include]]
2171    if {$cpath ni $includedir} {
2172      lappend includedir $cpath
2173    }
2174  }
2175  my build-cflags $PROJECT $proj(DEFS) name version defs
2176  set NAME [string toupper $name]
2177  set debug [$PROJECT define get debug 0]
2178  set os [$PROJECT define get TEACUP_OS]
2179
2180  set INCLUDES  "-I[join $includedir " -I"]"
2181  if {$debug} {
2182    set COMPILE "$proj(CC) $proj(CFLAGS_DEBUG) -ggdb \
2183$proj(CFLAGS_WARNING) $INCLUDES $defs"
2184
2185    if {[info exists proc(CXX)]} {
2186      set COMPILECPP "$proj(CXX) $defs $INCLUDES $proj(CFLAGS_DEBUG) -ggdb \
2187  $defs $proj(CFLAGS_WARNING)"
2188    } else {
2189      set COMPILECPP $COMPILE
2190    }
2191  } else {
2192    set COMPILE "$proj(CC) $proj(CFLAGS) $defs"
2193
2194    if {[info exists proc(CXX)]} {
2195      set COMPILECPP "$proj(CXX) $defs $proj(CFLAGS)"
2196    } else {
2197      set COMPILECPP $COMPILE
2198    }
2199  }
2200
2201  set products [my build-compile-sources $PROJECT $COMPILE $COMPILECPP $INCLUDES]
2202
2203  set map {}
2204  lappend map %LIBRARY_NAME% $proj(name)
2205  lappend map %LIBRARY_VERSION% $proj(version)
2206  lappend map %LIBRARY_VERSION_NODOTS% [string map {. {}} $proj(version)]
2207  lappend map %OUTFILE% $outfile
2208  lappend map %LIBRARY_OBJECTS% $products
2209  lappend map {${CFLAGS}} "$proj(CFLAGS_DEFAULT) $proj(CFLAGS_WARNING)"
2210
2211  if {[string is true [$PROJECT define get SHARED_BUILD 1]]} {
2212    set cmd [$PROJECT define get PRACTCL_SHARED_LIB]
2213    append cmd " [$PROJECT define get PRACTCL_LIBS]"
2214    set cmd [string map $map $cmd]
2215    puts $cmd
2216    exec {*}$cmd >&@ stdout
2217    if {[$PROJECT define get PRACTCL_VC_MANIFEST_EMBED_DLL] ni {: {}}} {
2218      set cmd [string map $map [$PROJECT define get PRACTCL_VC_MANIFEST_EMBED_DLL]]
2219      puts $cmd
2220      exec {*}$cmd >&@ stdout
2221    }
2222  } else {
2223    set cmd [string map $map [$PROJECT define get PRACTCL_STATIC_LIB]]
2224    puts $cmd
2225    exec {*}$cmd >&@ stdout
2226  }
2227  set ranlib [$PROJECT define get RANLIB]
2228  if {$ranlib ni {{} :}} {
2229    catch {exec $ranlib $outfile}
2230  }
2231}
2232
2233###
2234# Produce a static executable
2235###
2236method build-tclsh {outfile PROJECT} {
2237  puts " BUILDING STATIC TCLSH "
2238  set TCLOBJ [$PROJECT tclcore]
2239  ::practcl::toolset select $TCLOBJ
2240  set PKG_OBJS {}
2241  foreach item [$PROJECT link list core.library] {
2242    if {[string is true [$item define get static]]} {
2243      lappend PKG_OBJS $item
2244    }
2245  }
2246  foreach item [$PROJECT link list package] {
2247    if {[string is true [$item define get static]]} {
2248      lappend PKG_OBJS $item
2249    }
2250  }
2251  array set TCL [$TCLOBJ read_configuration]
2252
2253  set TKOBJ  [$PROJECT tkcore]
2254  if {[info command $TKOBJ] eq {}} {
2255    set TKOBJ ::noop
2256    $PROJECT define set static_tk 0
2257  } else {
2258    ::practcl::toolset select $TKOBJ
2259    array set TK  [$TKOBJ read_configuration]
2260    set do_tk [$TKOBJ define get static]
2261    $PROJECT define set static_tk $do_tk
2262    $PROJECT define set tk $do_tk
2263    set TKSRCDIR [$TKOBJ define get srcdir]
2264  }
2265  set path [file dirname $outfile]
2266  cd $path
2267  ###
2268  # For a static Tcl shell, we need to build all local sources
2269  # with the same DEFS flags as the tcl core was compiled with.
2270  # The DEFS produced by a TEA extension aren't intended to operate
2271  # with the internals of a staticly linked Tcl
2272  ###
2273  my build-cflags $PROJECT $TCL(defs) name version defs
2274  set debug [$PROJECT define get debug 0]
2275  set NAME [string toupper $name]
2276  set result {}
2277  set libraries {}
2278  set thisline {}
2279  set OBJECTS {}
2280  set EXTERN_OBJS {}
2281  foreach obj $PKG_OBJS {
2282    $obj compile
2283    set config($obj) [$obj read_configuration]
2284  }
2285  set os [$PROJECT define get TEACUP_OS]
2286  set TCLSRCDIR [$TCLOBJ define get srcdir]
2287
2288  set includedir .
2289  foreach include [$TCLOBJ toolset-include-directory] {
2290    set cpath [::practcl::file_relative $path [file normalize $include]]
2291    if {$cpath ni $includedir} {
2292      lappend includedir $cpath
2293    }
2294  }
2295  lappend includedir [::practcl::file_relative $path [file normalize ../tcl/compat/zlib]]
2296  if {[$PROJECT define get static_tk]} {
2297    lappend includedir [::practcl::file_relative $path [file normalize [file join $TKSRCDIR generic]]]
2298    lappend includedir [::practcl::file_relative $path [file normalize [file join $TKSRCDIR ttk]]]
2299    lappend includedir [::practcl::file_relative $path [file normalize [file join $TKSRCDIR xlib]]]
2300    lappend includedir [::practcl::file_relative $path [file normalize $TKSRCDIR]]
2301  }
2302
2303  foreach include [$PROJECT toolset-include-directory] {
2304    set cpath [::practcl::file_relative $path [file normalize $include]]
2305    if {$cpath ni $includedir} {
2306      lappend includedir $cpath
2307    }
2308  }
2309
2310  set INCLUDES  "-I[join $includedir " -I"]"
2311  if {$debug} {
2312      set COMPILE "$TCL(cc) $TCL(shlib_cflags) $TCL(cflags_debug) -ggdb \
2313$TCL(cflags_warning) $TCL(extra_cflags)"
2314  } else {
2315      set COMPILE "$TCL(cc) $TCL(shlib_cflags) $TCL(cflags_optimize) \
2316$TCL(cflags_warning) $TCL(extra_cflags)"
2317  }
2318  append COMPILE " " $defs
2319  lappend OBJECTS {*}[my build-compile-sources $PROJECT $COMPILE $COMPILE $INCLUDES]
2320
2321  set TCLSRC [file normalize $TCLSRCDIR]
2322
2323  if {[${PROJECT} define get TEACUP_OS] eq "windows"} {
2324    set windres [$PROJECT define get RC windres]
2325    set RSOBJ [file join $path build tclkit.res.o]
2326    set RCSRC [${PROJECT} define get kit_resource_file]
2327    set RCMAN [${PROJECT} define get kit_manifest_file]
2328
2329    set cmd [list $windres -o $RSOBJ -DSTATIC_BUILD --include [::practcl::file_relative $path [file join $TCLSRC generic]]]
2330    if {[$PROJECT define get static_tk]} {
2331      if {$RCSRC eq {} || ![file exists $RCSRC]} {
2332        set RCSRC [file join $TKSRCDIR win rc wish.rc]
2333      }
2334      if {$RCMAN eq {} || ![file exists $RCMAN]} {
2335        set RCMAN [file join [$TKOBJ define get builddir] wish.exe.manifest]
2336      }
2337      set TKSRC [file normalize $TKSRCDIR]
2338      lappend cmd --include [::practcl::file_relative $path [file join $TKSRC generic]] \
2339        --include [::practcl::file_relative $path [file join $TKSRC win]] \
2340        --include [::practcl::file_relative $path [file join $TKSRC win rc]]
2341    } else {
2342      if {$RCSRC eq {} || ![file exists $RCSRC]} {
2343        set RCSRC [file join $TCLSRCDIR tclsh.rc]
2344      }
2345      if {$RCMAN eq {} || ![file exists $RCMAN]} {
2346        set RCMAN [file join [$TCLOBJ define get builddir] tclsh.exe.manifest]
2347      }
2348    }
2349    foreach item [${PROJECT} define get resource_include] {
2350      lappend cmd --include [::practcl::file_relative $path [file normalize $item]]
2351    }
2352    lappend cmd [file tail $RCSRC]
2353    if {![file exists [file join $path [file tail $RCSRC]]]} {
2354      file copy -force $RCSRC [file join $path [file tail $RCSRC]]
2355    }
2356    if {![file exists [file join $path [file tail $RCMAN]]]} {
2357      file copy -force $RCMAN [file join $path [file tail $RCMAN]]
2358    }
2359    ::practcl::doexec {*}$cmd
2360    lappend OBJECTS $RSOBJ
2361  }
2362  puts "***"
2363  set cmd "$TCL(cc)"
2364  if {$debug} {
2365   append cmd " $TCL(cflags_debug)"
2366  } else {
2367   append cmd " $TCL(cflags_optimize)"
2368  }
2369  append cmd " $TCL(ld_flags)"
2370  if {$debug} {
2371   append cmd " $TCL(ldflags_debug)"
2372  } else {
2373   append cmd " $TCL(ldflags_optimize)"
2374  }
2375
2376  append cmd " $OBJECTS"
2377  append cmd " $EXTERN_OBJS"
2378  if {$debug && $os eq "windows"} {
2379    append cmd " -static"
2380    append cmd " -L${TCL(src_dir)}/win -ltcl86g"
2381    if {[$PROJECT define get static_tk]} {
2382      append cmd " -L${TK(src_dir)}/win -ltk86g"
2383    }
2384  } else {
2385    append cmd " $TCL(build_lib_spec)"
2386    if {[$PROJECT define get static_tk]} {
2387      append cmd  " $TK(build_lib_spec)"
2388    }
2389  }
2390  foreach obj $PKG_OBJS {
2391    append cmd " [$obj linker-products $config($obj)]"
2392  }
2393  set LIBS {}
2394  foreach item $TCL(libs) {
2395    if {[string range $item 0 1] eq "-l" && $item in $LIBS } continue
2396    lappend LIBS $item
2397  }
2398  if {[$PROJECT define get static_tk]} {
2399    foreach item $TK(libs) {
2400      if {[string range $item 0 1] eq "-l" && $item in $LIBS } continue
2401      lappend LIBS $item
2402    }
2403  }
2404  if {[info exists TCL(extra_libs)]} {
2405    foreach item $TCL(extra_libs) {
2406      if {[string range $item 0 1] eq "-l" && $item in $LIBS } continue
2407      lappend LIBS $item
2408    }
2409  }
2410  foreach obj $PKG_OBJS {
2411    puts [list Checking $obj for external dependencies]
2412    foreach item [$obj linker-external $config($obj)] {
2413      puts [list $obj adds $item]
2414      if {[string range $item 0 1] eq "-l" && $item in $LIBS } continue
2415      lappend LIBS $item
2416    }
2417  }
2418  append cmd " ${LIBS}"
2419  foreach obj $PKG_OBJS {
2420    puts [list Checking $obj for additional link items]
2421    foreach item [$obj linker-extra $config($obj)] {
2422      append cmd $item
2423    }
2424  }
2425  if {$debug && $os eq "windows"} {
2426    append cmd " -L${TCL(src_dir)}/win ${TCL(stub_lib_flag)}"
2427    if {[$PROJECT define get static_tk]} {
2428      append cmd " -L${TK(src_dir)}/win ${TK(stub_lib_flag)}"
2429    }
2430  } else {
2431    append cmd " $TCL(build_stub_lib_spec)"
2432    if {[$PROJECT define get static_tk]} {
2433      append cmd " $TK(build_stub_lib_spec)"
2434    }
2435  }
2436  if {[info exists TCL(cc_search_flags)]} {
2437    append cmd " $TCL(cc_search_flags)"
2438  }
2439  append cmd " -o $outfile "
2440  if {$os eq "windows"} {
2441    set LDFLAGS_CONSOLE {-mconsole -pipe -static-libgcc}
2442    set LDFLAGS_WINDOW  {-mwindows -pipe -static-libgcc}
2443    append cmd " $LDFLAGS_CONSOLE"
2444  }
2445  puts "LINK: $cmd"
2446  exec {*}[string map [list "\n" " " "  " " "] $cmd] >&@ stdout
2447}
2448
2449}
2450
2451###
2452# END: class toolset gcc.tcl
2453###
2454###
2455# START: class toolset msvc.tcl
2456###
2457::oo::class create ::practcl::toolset.msvc {
2458  superclass ::practcl::toolset
2459
2460  # MSVC always builds in the source directory
2461  method BuildDir {PWD} {
2462    set srcdir [my define get srcdir]
2463    return $srcdir
2464  }
2465
2466
2467  # Do nothing
2468  method make-autodetect {} {
2469  }
2470
2471  method make-clean {} {
2472    set PWD [pwd]
2473    set srcdir [my define get srcdir]
2474    cd $srcdir
2475    catch {::practcl::doexec nmake -f makefile.vc clean}
2476    cd $PWD
2477  }
2478
2479  method make-compile {} {
2480    set srcdir [my define get srcdir]
2481    if {[my define get static 1]} {
2482      puts "BUILDING Static $name $srcdir"
2483    } else {
2484      puts "BUILDING Dynamic $name $srcdir"
2485    }
2486    cd $srcdir
2487    if {[file exists [file join $srcdir make.tcl]]} {
2488      if {[my define get debug 0]} {
2489        ::practcl::domake.tcl $srcdir debug all
2490      } else {
2491        ::practcl::domake.tcl $srcdir all
2492      }
2493    } else {
2494      if {[file exists [file join $srcdir makefile.vc]]} {
2495        ::practcl::doexec nmake -f makefile.vc INSTALLDIR=[my <project> define get installdir]  {*}[my NmakeOpts] release
2496      } elseif {[file exists [file join $srcdir win makefile.vc]]} {
2497        cd [file join $srcdir win]
2498        ::practcl::doexec nmake -f makefile.vc INSTALLDIR=[my <project> define get installdir]  {*}[my NmakeOpts] release
2499      } else {
2500        error "No make.tcl or makefile.vc found for project $name"
2501      }
2502    }
2503  }
2504
2505  method make-install DEST {
2506    set PWD [pwd]
2507    set srcdir [my define get srcdir]
2508    cd $srcdir
2509    if {$DEST eq {}} {
2510      error "No destination given"
2511    }
2512    if {[my <project> define get LOCAL 0] || $DEST eq {}} {
2513      if {[file exists [file join $srcdir make.tcl]]} {
2514        # Practcl builds can inject right to where we need them
2515        puts "[self] Local Install (Practcl)"
2516        ::practcl::domake.tcl $srcdir install
2517      } else {
2518        puts "[self] Local Install (Nmake)"
2519        ::practcl::doexec nmake -f makefile.vc {*}[my NmakeOpts] install
2520      }
2521    } else {
2522      if {[file exists [file join $srcdir make.tcl]]} {
2523        # Practcl builds can inject right to where we need them
2524        puts "[self] VFS INSTALL $DEST (Practcl)"
2525        ::practcl::domake.tcl $srcdir install-package $DEST
2526      } else {
2527        puts "[self] VFS INSTALL $DEST"
2528        ::practcl::doexec nmake -f makefile.vc INSTALLDIR=$DEST {*}[my NmakeOpts] install
2529      }
2530    }
2531    cd $PWD
2532  }
2533
2534  # Detect what directory contains the Makefile template
2535  method MakeDir {srcdir} {
2536    set localsrcdir $srcdir
2537    if {[file exists [file join $srcdir generic]]} {
2538      my define add include_dir [file join $srcdir generic]
2539    }
2540    if {[file exists [file join $srcdir win]]} {
2541       my define add include_dir [file join $srcdir win]
2542    }
2543    if {[file exists [file join $srcdir makefile.vc]]} {
2544      set localsrcdir [file join $srcdir win]
2545    }
2546    return $localsrcdir
2547  }
2548
2549  method NmakeOpts {} {
2550    set opts {}
2551    set builddir [file normalize [my define get builddir]]
2552
2553    if {[my <project> define exists tclsrcdir]} {
2554      ###
2555      # On Windows we are probably running under MSYS, which doesn't deal with
2556      # spaces in filename well
2557      ###
2558      set TCLSRCDIR  [::practcl::file_relative [file normalize $builddir] [file normalize [file join $::CWD [my <project> define get tclsrcdir] ..]]]
2559      set TCLGENERIC [::practcl::file_relative [file normalize $builddir] [file normalize [file join $::CWD [my <project> define get tclsrcdir] .. generic]]]
2560      lappend opts TCLDIR=[file normalize $TCLSRCDIR]
2561      #--with-tclinclude=$TCLGENERIC
2562    }
2563    if {[my <project> define exists tksrcdir]} {
2564      set TKSRCDIR  [::practcl::file_relative [file normalize $builddir] [file normalize [file join $::CWD [my <project> define get tksrcdir] ..]]]
2565      set TKGENERIC [::practcl::file_relative [file normalize $builddir] [file normalize [file join $::CWD [my <project> define get tksrcdir] .. generic]]]
2566      #lappend opts --with-tk=$TKSRCDIR --with-tkinclude=$TKGENERIC
2567      lappend opts TKDIR=[file normalize $TKSRCDIR]
2568    }
2569    return $opts
2570  }
2571}
2572
2573###
2574# END: class toolset msvc.tcl
2575###
2576###
2577# START: class target.tcl
2578###
2579
2580::oo::class create ::practcl::make_obj {
2581  superclass ::practcl::metaclass
2582
2583  constructor {module_object name info {action_body {}}} {
2584    my variable define triggered domake
2585    set triggered 0
2586    set domake 0
2587    set define(name) $name
2588    set define(action) {}
2589    array set define $info
2590    my select
2591    my initialize
2592    foreach {stub obj} [$module_object child organs] {
2593      my graft $stub $obj
2594    }
2595    if {$action_body ne {}} {
2596      set define(action) $action_body
2597    }
2598  }
2599
2600  method do {} {
2601    my variable domake
2602    return $domake
2603  }
2604
2605  method check {} {
2606    my variable needs_make domake
2607    if {$domake} {
2608      return 1
2609    }
2610    if {[info exists needs_make]} {
2611      return $needs_make
2612    }
2613    set make_objects [my <module> make objects]
2614    set needs_make 0
2615    foreach item [my define get depends] {
2616      if {![dict exists $make_objects $item]} continue
2617      set depobj [dict get $make_objects $item]
2618      if {$depobj eq [self]} {
2619        puts "WARNING [self] depends on itself"
2620        continue
2621      }
2622      if {[$depobj check]} {
2623        set needs_make 1
2624      }
2625    }
2626    if {!$needs_make} {
2627      foreach filename [my output] {
2628        if {$filename ne {} && ![file exists $filename]} {
2629          set needs_make 1
2630        }
2631      }
2632    }
2633    return $needs_make
2634  }
2635
2636  method output {} {
2637    set result {}
2638    set filename [my define get filename]
2639    if {$filename ne {}} {
2640      lappend result $filename
2641    }
2642    foreach filename [my define get files] {
2643      if {$filename ne {}} {
2644        lappend result $filename
2645      }
2646    }
2647    return $result
2648  }
2649
2650  method reset {} {
2651    my variable triggered domake needs_make
2652    set triggerd 0
2653    set domake 0
2654    set needs_make 0
2655  }
2656
2657  method triggers {} {
2658    my variable triggered domake define
2659    if {$triggered} {
2660      return $domake
2661    }
2662    set triggered 1
2663    set make_objects [my <module> make objects]
2664
2665    foreach item [my define get depends] {
2666      if {![dict exists $make_objects $item]} continue
2667      set depobj [dict get $make_objects $item]
2668      if {$depobj eq [self]} {
2669        puts "WARNING [self] triggers itself"
2670        continue
2671      } else {
2672        set r [$depobj check]
2673        if {$r} {
2674          $depobj triggers
2675        }
2676      }
2677    }
2678    set domake 1
2679    my <module> make trigger {*}[my define get triggers]
2680  }
2681}
2682
2683###
2684# END: class target.tcl
2685###
2686###
2687# START: class object.tcl
2688###
2689::oo::class create ::practcl::object {
2690  superclass ::practcl::metaclass
2691
2692  constructor {parent args} {
2693    my variable links define
2694    set organs [$parent child organs]
2695    my graft {*}$organs
2696    array set define $organs
2697    array set define [$parent child define]
2698    array set links {}
2699    if {[llength $args]==1 && [file exists [lindex $args 0]]} {
2700      my define set filename [lindex $args 0]
2701      ::practcl::product select [self]
2702    } elseif {[llength $args] == 1} {
2703      set data  [uplevel 1 [list subst [lindex $args 0]]]
2704      array set define $data
2705      my select
2706    } else {
2707      array set define [uplevel 1 [list subst $args]]
2708      my select
2709    }
2710    my initialize
2711
2712  }
2713
2714  method child {method} {
2715    return {}
2716  }
2717
2718  method go {} {
2719    ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]]
2720    my variable links
2721    foreach {linktype objs} [array get links] {
2722      foreach obj $objs {
2723        $obj go
2724      }
2725    }
2726    ::practcl::debug [list /[self] [self method] [self class]]
2727  }
2728}
2729
2730###
2731# END: class object.tcl
2732###
2733###
2734# START: class dynamic.tcl
2735###
2736
2737###
2738# Dynamic blocks do not generate their own .c files,
2739# instead the contribute to the amalgamation
2740# of the main library file
2741###
2742::oo::class create ::practcl::dynamic {
2743
2744  ###
2745  # Parser functions
2746  ###
2747
2748  method cstructure {name definition {argdat {}}} {
2749    my variable cstruct
2750    dict set cstruct $name body $definition
2751    foreach {f v} $argdat {
2752      dict set cstruct $name $f $v
2753    }
2754    if {![dict exists $cstruct $name public]} {
2755      dict set cstruct $name public 1
2756    }
2757  }
2758
2759  method include header {
2760    my define add include $header
2761  }
2762
2763  method include_dir args {
2764    my define add include_dir {*}$args
2765  }
2766
2767  method include_directory args {
2768    my define add include_dir {*}$args
2769  }
2770
2771  method c_header body {
2772    my variable code
2773    ::practcl::cputs code(header) $body
2774  }
2775
2776  method c_code body {
2777    my variable code
2778    ::practcl::cputs code(funct) $body
2779  }
2780
2781  method c_function {header body {info {}}} {
2782    set header [string map "\t \  \n \ \ \  \ " $header]
2783    my variable code cfunct
2784    foreach regexp {
2785         {(.*) ([a-zA-Z_][a-zA-Z0-9_]*) *\((.*)\)}
2786         {(.*) (\x2a[a-zA-Z_][a-zA-Z0-9_]*) *\((.*)\)}
2787    } {
2788      if {[regexp $regexp $header all keywords funcname arglist]} {
2789        set dat [dict merge {export 0 extern 0 public 1 inline 0} $info]
2790        dict set dat header $header
2791        dict set dat body $body
2792        dict set dat keywords $keywords
2793        dict set dat arglist $arglist
2794        if {"IRM_INLINE" in $keywords || "CTHULHU_INLINE" in $keywords} {
2795          dict set dat public 1
2796          dict set dat extern 0
2797          dict set dat inline 1
2798        } else {
2799          if {"inline" in $keywords} {
2800            dict set dat inline 1
2801          }
2802          if {"STUB_EXPORT" in $keywords} {
2803            dict set dat extern 1
2804            dict set dat public 1
2805            dict set dat export 1
2806            dict set dat inline 0
2807          } elseif {"extern" in $keywords} {
2808            dict set dat extern 1
2809            dict set dat public 1
2810          } elseif {"static" in $keywords} {
2811            dict set dat public 0
2812          }
2813        }
2814        if {[dict get $dat inline] && [dict get $dat public]} {
2815          set header [string map {IRM_INLINE {} CTHULHU_INLINE {} static {} inline {} extern {}} [dict get $dat header]]
2816          dict set dat header "extern $header"
2817        }
2818        dict set cfunct $funcname $dat
2819        return
2820      }
2821    }
2822    puts "WARNING: NON CONFORMING FUNCTION DEFINITION: $headers $body"
2823    ::practcl::cputs code(header) "$header\;"
2824    # Could not parse that block as a function
2825    # append it verbatim to our c_implementation
2826    ::practcl::cputs code(funct) "$header [list $body]"
2827  }
2828
2829  method c_tcloomethod {name body {arginfo {}}} {
2830    my variable methods code
2831    foreach {f v} $arginfo {
2832      dict set methods $name $f $v
2833    }
2834    dict set methods $name body "Tcl_Object thisObject = Tcl_ObjectContextObject(objectContext); /* The current connection object */
2835$body"
2836  }
2837
2838  # Alias to classic name
2839  method cmethod {name body {arginfo {}}} {
2840    my variable methods code
2841    foreach {f v} $arginfo {
2842      dict set methods $name $f $v
2843    }
2844    dict set methods $name body "Tcl_Object thisObject = Tcl_ObjectContextObject(objectContext); /* The current connection object */
2845$body"
2846  }
2847
2848  method c_tclproc_nspace nspace {
2849    my variable code
2850    if {![info exists code(nspace)]} {
2851      set code(nspace) {}
2852    }
2853    if {$nspace ni $code(nspace)} {
2854      lappend code(nspace) $nspace
2855    }
2856  }
2857
2858  method c_tclcmd {name body {arginfo {}}} {
2859    my variable tclprocs code
2860
2861    foreach {f v} $arginfo {
2862      dict set tclprocs $name $f $v
2863    }
2864    dict set tclprocs $name body $body
2865  }
2866
2867  # Alias to classic name
2868  method c_tclproc_raw {name body {arginfo {}}} {
2869    my variable tclprocs code
2870
2871    foreach {f v} $arginfo {
2872      dict set tclprocs $name $f $v
2873    }
2874    dict set tclprocs $name body $body
2875  }
2876
2877  method tcltype {name argdat} {
2878    my variable tcltype
2879    foreach {f v} $argdat {
2880      dict set tcltype $name $f $v
2881    }
2882    if {![dict exists tcltype $name cname]} {
2883      dict set tcltype $name cname [string tolower $name]_tclobjtype
2884    }
2885    lappend map @NAME@ $name
2886    set info [dict get $tcltype $name]
2887    foreach {f v} $info {
2888      lappend map @[string toupper $f]@ $v
2889    }
2890    foreach {func fpat template} {
2891      freeproc         {@Name@Obj_freeIntRepProc}       {void @FNAME@(Tcl_Obj *objPtr)}
2892      dupproc          {@Name@Obj_dupIntRepProc}        {void @FNAME@(Tcl_Obj *srcPtr,Tcl_Obj *dupPtr)}
2893      updatestringproc {@Name@Obj_updateStringRepProc} {void @FNAME@(Tcl_Obj *objPtr)}
2894      setfromanyproc   {@Name@Obj_setFromAnyProc}       {int @FNAME@(Tcl_Interp *interp,Tcl_Obj *objPtr)}
2895    } {
2896      if {![dict exists $info $func]} {
2897        error "$name does not define $func"
2898      }
2899      set body [dict get $info $func]
2900      # We were given a function name to call
2901      if {[llength $body] eq 1} continue
2902      set fname [string map [list @Name@ [string totitle $name]] $fpat]
2903      my c_function [string map [list @FNAME@ $fname] $template] [string map $map $body]
2904      dict set tcltype $name $func $fname
2905    }
2906  }
2907
2908  ###
2909  # Module interactions
2910  ###
2911
2912
2913  method project-compile-products {} {
2914    set filename [my define get output_c]
2915    set result {}
2916    if {$filename ne {}} {
2917      ::practcl::debug [self] [self class] [self method] project-compile-products $filename
2918
2919      if {[my define exists ofile]} {
2920        set ofile [my define get ofile]
2921      } else {
2922        set ofile [my Ofile $filename]
2923        my define set ofile $ofile
2924      }
2925      lappend result $ofile [list cfile $filename extra [my define get extra] external [string is true -strict [my define get external]]]
2926    } else {
2927      set filename [my define get cfile]
2928      if {$filename ne {}} {
2929        ::practcl::debug [self] [self class] [self method] project-compile-products $filename
2930        if {[my define exists ofile]} {
2931          set ofile [my define get ofile]
2932        } else {
2933          set ofile [my Ofile $filename]
2934          my define set ofile $ofile
2935        }
2936        lappend result $ofile [list cfile $filename extra [my define get extra] external [string is true -strict [my define get external]]]
2937      }
2938    }
2939    foreach item [my link list subordinate] {
2940      lappend result {*}[$item project-compile-products]
2941    }
2942    return $result
2943  }
2944
2945
2946  method implement path {
2947    my go
2948    my Collate_Source $path
2949    if {[my define get output_c] eq {}} return
2950    set filename [file join $path [my define get output_c]]
2951    ::practcl::debug [self] [my define get filename] WANTS TO GENERATE $filename
2952    my define set cfile $filename
2953    set fout [open $filename w]
2954    puts $fout [my generate-c]
2955    if {[my define get initfunc] ne {}} {
2956      puts $fout "extern int DLLEXPORT [my define get initfunc]( Tcl_Interp *interp ) \x7B"
2957      puts $fout [my generate-loader-module]
2958      if {[my define get pkg_name] ne {}} {
2959        puts $fout "   Tcl_PkgProvide(interp, \"[my define get pkg_name]\", \"[my define get pkg_vers]\");"
2960      }
2961      puts $fout "  return TCL_OK\;"
2962      puts $fout "\x7D"
2963    }
2964    close $fout
2965  }
2966
2967
2968
2969  ###
2970  # Practcl internals
2971  ###
2972
2973  method initialize {} {
2974    set filename [my define get filename]
2975    if {$filename eq {}} {
2976      return
2977    }
2978    if {[my define get name] eq {}} {
2979      my define set name [file tail [file rootname $filename]]
2980    }
2981    if {[my define get localpath] eq {}} {
2982      my define set localpath [my <module> define get localpath]_[my define get name]
2983    }
2984    ::source $filename
2985  }
2986
2987  method linktype {} {
2988    return {subordinate product dynamic}
2989  }
2990
2991  method generate-cfile-constant {} {
2992    ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]]
2993    set result {}
2994    my variable code cstruct methods tcltype
2995    if {[info exists code(constant)]} {
2996      ::practcl::cputs result "/* [my define get filename] CONSTANT */"
2997      ::practcl::cputs result $code(constant)
2998    }
2999    if {[info exists cstruct]} {
3000      foreach {name info} $cstruct {
3001        set map {}
3002        lappend map @NAME@ $name
3003        lappend map @MACRO@ GET[string toupper $name]
3004
3005        if {[dict exists $info deleteproc]} {
3006          lappend map @DELETEPROC@ [dict get $info deleteproc]
3007        } else {
3008          lappend map @DELETEPROC@ NULL
3009        }
3010        if {[dict exists $info cloneproc]} {
3011          lappend map @CLONEPROC@ [dict get $info cloneproc]
3012        } else {
3013          lappend map @CLONEPROC@ NULL
3014        }
3015        ::practcl::cputs result [string map $map {
3016const static Tcl_ObjectMetadataType @NAME@DataType = {
3017  TCL_OO_METADATA_VERSION_CURRENT,
3018  "@NAME@",
3019  @DELETEPROC@,
3020  @CLONEPROC@
3021};
3022#define @MACRO@(OBJCONTEXT) (@NAME@ *) Tcl_ObjectGetMetadata(OBJCONTEXT,&@NAME@DataType)
3023}]
3024      }
3025    }
3026    if {[info exists tcltype]} {
3027      foreach {type info} $tcltype {
3028        dict with info {}
3029        ::practcl::cputs result "const Tcl_ObjType $cname = \{\n .name=\"$type\",\n .freeIntRepProc = &${freeproc},\n  .dupIntRepProc = &${dupproc},\n  .updateStringProc = &${updatestringproc},\n  .setFromAnyProc = &${setfromanyproc}\n\}\;"
3030      }
3031    }
3032
3033    if {[info exists methods]} {
3034      set mtypes {}
3035      foreach {name info} $methods {
3036        set callproc   [dict get $info callproc]
3037        set methodtype [dict get $info methodtype]
3038        if {$methodtype in $mtypes} continue
3039        lappend mtypes $methodtype
3040        ###
3041        # Build the data struct for this method
3042        ###
3043        ::practcl::cputs result "const static Tcl_MethodType $methodtype = \{"
3044        ::practcl::cputs result "  .version = TCL_OO_METADATA_VERSION_CURRENT,\n  .name = \"$name\",\n  .callProc = $callproc,"
3045        if {[dict exists $info deleteproc]} {
3046          set deleteproc [dict get $info deleteproc]
3047        } else {
3048          set deleteproc NULL
3049        }
3050        if {$deleteproc ni { {} NULL }} {
3051          ::practcl::cputs result "  .deleteProc = $deleteproc,"
3052        } else {
3053          ::practcl::cputs result "  .deleteProc = NULL,"
3054        }
3055        if {[dict exists $info cloneproc]} {
3056          set cloneproc [dict get $info cloneproc]
3057        } else {
3058          set cloneproc NULL
3059        }
3060        if {$cloneproc ni { {} NULL }} {
3061          ::practcl::cputs result "  .cloneProc = $cloneproc\n\}\;"
3062        } else {
3063          ::practcl::cputs result "  .cloneProc = NULL\n\}\;"
3064        }
3065        dict set methods $name methodtype $methodtype
3066      }
3067    }
3068    foreach obj [my link list product] {
3069      # Exclude products that will generate their own C files
3070      if {[$obj define get output_c] ne {}} continue
3071      ::practcl::cputs result [$obj generate-cfile-constant]
3072    }
3073    return $result
3074  }
3075
3076  method generate-cfile-header {} {
3077    ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]]
3078    my variable code cfunct cstruct methods tcltype tclprocs
3079    set result {}
3080    if {[info exists code(header)]} {
3081      ::practcl::cputs result $code(header)
3082    }
3083    ::practcl::debug [list cfunct [info exists cfunct]]
3084    if {[info exists cfunct]} {
3085      foreach {funcname info} $cfunct {
3086        if {[dict get $info public]} continue
3087        ::practcl::cputs result "[dict get $info header]\;"
3088      }
3089    }
3090    ::practcl::debug [list tclprocs [info exists tclprocs]]
3091    if {[info exists tclprocs]} {
3092      foreach {name info} $tclprocs {
3093        if {[dict exists $info header]} {
3094          ::practcl::cputs result "[dict get $info header]\;"
3095        }
3096      }
3097    }
3098    ::practcl::debug [list methods [info exists methods] [my define get cclass]]
3099    if {[info exists methods]} {
3100      set thisclass [my define get cclass]
3101      foreach {name info} $methods {
3102        if {[dict exists $info header]} {
3103          ::practcl::cputs result "[dict get $info header]\;"
3104        }
3105      }
3106      # Add the initializer wrapper for the class
3107      ::practcl::cputs result "static int ${thisclass}_OO_Init(Tcl_Interp *interp)\;"
3108    }
3109    foreach obj [my link list product] {
3110      # Exclude products that will generate their own C files
3111      if {[$obj define get output_c] ne {}} continue
3112      set dat [$obj generate-cfile-header]
3113      if {[string length [string trim $dat]]} {
3114        ::practcl::cputs result "/* BEGIN [$obj define get filename] generate-cfile-header */"
3115        ::practcl::cputs result $dat
3116        ::practcl::cputs result "/* END [$obj define get filename] generate-cfile-header */"
3117      }
3118    }
3119    return $result
3120  }
3121
3122  ###
3123  # Generate code that provides implements Tcl API
3124  # calls
3125  ###
3126  method generate-cfile-tclapi {} {
3127    ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]]
3128    my variable code methods tclprocs
3129    set result {}
3130    if {[info exists code(method)]} {
3131      ::practcl::cputs result $code(method)
3132    }
3133
3134    if {[info exists tclprocs]} {
3135      foreach {name info} $tclprocs {
3136        if {![dict exists $info body]} continue
3137        set callproc [dict get $info callproc]
3138        set header [dict get $info header]
3139        set body [dict get $info body]
3140        ::practcl::cputs result "/* Tcl Proc $name */"
3141        ::practcl::cputs result "${header} \{${body}\}"
3142      }
3143    }
3144
3145
3146    if {[info exists methods]} {
3147      set thisclass [my define get cclass]
3148      foreach {name info} $methods {
3149        if {![dict exists $info body]} continue
3150        set callproc [dict get $info callproc]
3151        set header [dict get $info header]
3152        set body [dict get $info body]
3153        ::practcl::cputs result "/* OO Method $thisclass $name */"
3154        ::practcl::cputs result "${header} \{${body}\}"
3155      }
3156      # Build the OO_Init function
3157      ::practcl::cputs result "/* Loader for $thisclass */"
3158      ::practcl::cputs result "static int ${thisclass}_OO_Init(Tcl_Interp *interp) \{"
3159      ::practcl::cputs result [string map [list @CCLASS@ $thisclass @TCLCLASS@ [my define get class]] {
3160  /*
3161  ** Build the "@TCLCLASS@" class
3162  */
3163  Tcl_Obj* nameObj;		/* Name of a class or method being looked up */
3164  Tcl_Object curClassObject;  /* Tcl_Object representing the current class */
3165  Tcl_Class curClass;		/* Tcl_Class representing the current class */
3166
3167  /*
3168   * Find the "@TCLCLASS@" class, and attach an 'init' method to it.
3169   */
3170
3171  nameObj = Tcl_NewStringObj("@TCLCLASS@", -1);
3172  Tcl_IncrRefCount(nameObj);
3173  if ((curClassObject = Tcl_GetObjectFromObj(interp, nameObj)) == NULL) {
3174      Tcl_DecrRefCount(nameObj);
3175      return TCL_ERROR;
3176  }
3177  Tcl_DecrRefCount(nameObj);
3178  curClass = Tcl_GetObjectAsClass(curClassObject);
3179}]
3180      if {[dict exists $methods constructor]} {
3181        set mtype [dict get $methods constructor methodtype]
3182        ::practcl::cputs result [string map [list @MTYPE@ $mtype] {
3183  /* Attach the constructor to the class */
3184  Tcl_ClassSetConstructor(interp, curClass, Tcl_NewMethod(interp, curClass, NULL, 1, &@MTYPE@, NULL));
3185    }]
3186      }
3187      foreach {name info} $methods {
3188        dict with info {}
3189        if {$name in {constructor destructor}} continue
3190        ::practcl::cputs result [string map [list @NAME@ $name @MTYPE@ $methodtype] {
3191  nameObj=Tcl_NewStringObj("@NAME@",-1);
3192  Tcl_NewMethod(interp, curClass, nameObj, 1, &@MTYPE@, (ClientData) NULL);
3193  Tcl_DecrRefCount(nameObj);
3194}]
3195        if {[dict exists $info aliases]} {
3196          foreach alias [dict get $info aliases] {
3197            if {[dict exists $methods $alias]} continue
3198            ::practcl::cputs result [string map [list @NAME@ $alias @MTYPE@ $methodtype] {
3199  nameObj=Tcl_NewStringObj("@NAME@",-1);
3200  Tcl_NewMethod(interp, curClass, nameObj, 1, &@MTYPE@, (ClientData) NULL);
3201  Tcl_DecrRefCount(nameObj);
3202}]
3203          }
3204        }
3205      }
3206      ::practcl::cputs result "  return TCL_OK\;\n\}\n"
3207    }
3208    foreach obj [my link list product] {
3209      # Exclude products that will generate their own C files
3210      if {[$obj define get output_c] ne {}} continue
3211      ::practcl::cputs result [$obj generate-cfile-tclapi]
3212    }
3213    return $result
3214  }
3215
3216  ###
3217  # Generate code that runs when the package/module is
3218  # initialized into the interpreter
3219  ###
3220  method generate-loader-module {} {
3221    ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]]
3222    set result {}
3223    my variable code methods tclprocs
3224    if {[info exists code(nspace)]} {
3225      ::practcl::cputs result "  \{\n    Tcl_Namespace *modPtr;"
3226      foreach nspace $code(nspace) {
3227        ::practcl::cputs result [string map [list @NSPACE@ $nspace] {
3228    modPtr=Tcl_FindNamespace(interp,"@NSPACE@",NULL,TCL_NAMESPACE_ONLY);
3229    if(!modPtr) {
3230      modPtr = Tcl_CreateNamespace(interp, "@NSPACE@", NULL, NULL);
3231    }
3232}]
3233      }
3234      ::practcl::cputs result "  \}"
3235    }
3236    if {[info exists code(tclinit)]} {
3237      ::practcl::cputs result $code(tclinit)
3238    }
3239    if {[info exists code(cinit)]} {
3240      ::practcl::cputs result $code(cinit)
3241    }
3242    if {[info exists code(initfuncts)]} {
3243      foreach func $code(initfuncts) {
3244        ::practcl::cputs result "  if (${func}(interp) != TCL_OK) return TCL_ERROR\;"
3245      }
3246    }
3247    if {[info exists tclprocs]} {
3248      foreach {name info} $tclprocs {
3249        set map [list @NAME@ $name @CALLPROC@ [dict get $info callproc]]
3250        ::practcl::cputs result [string map $map {  Tcl_CreateObjCommand(interp,"@NAME@",(Tcl_ObjCmdProc *)@CALLPROC@,NULL,NULL);}]
3251        if {[dict exists $info aliases]} {
3252          foreach alias [dict get $info aliases] {
3253            set map [list @NAME@ $alias @CALLPROC@ [dict get $info callproc]]
3254            ::practcl::cputs result [string map $map {  Tcl_CreateObjCommand(interp,"@NAME@",(Tcl_ObjCmdProc *)@CALLPROC@,NULL,NULL);}]
3255          }
3256        }
3257      }
3258    }
3259
3260    if {[info exists code(nspace)]} {
3261      ::practcl::cputs result "  \{\n    Tcl_Namespace *modPtr;"
3262      foreach nspace $code(nspace) {
3263        ::practcl::cputs result [string map [list @NSPACE@ $nspace] {
3264    modPtr=Tcl_FindNamespace(interp,"@NSPACE@",NULL,TCL_NAMESPACE_ONLY);
3265    Tcl_CreateEnsemble(interp, modPtr->fullName, modPtr, TCL_ENSEMBLE_PREFIX);
3266    Tcl_Export(interp, modPtr, "[a-z]*", 1);
3267}]
3268      }
3269      ::practcl::cputs result "  \}"
3270    }
3271    set result [::practcl::_tagblock $result c [my define get filename]]
3272    foreach obj [my link list product] {
3273      # Exclude products that will generate their own C files
3274      if {[$obj define get output_c] ne {}} {
3275        ::practcl::cputs result [$obj generate-loader-external]
3276      } else {
3277        ::practcl::cputs result [$obj generate-loader-module]
3278      }
3279    }
3280    return $result
3281  }
3282
3283  method Collate_Source CWD {
3284    my variable methods code cstruct tclprocs
3285    if {[info exists methods]} {
3286      ::practcl::debug [self] methods [my define get cclass]
3287      set thisclass [my define get cclass]
3288      foreach {name info} $methods {
3289        # Provide a callproc
3290        if {![dict exists $info callproc]} {
3291          set callproc [string map {____ _ ___ _ __ _} [string map {{ } _ : _} OOMethod_${thisclass}_${name}]]
3292          dict set methods $name callproc $callproc
3293        } else {
3294          set callproc [dict get $info callproc]
3295        }
3296        if {[dict exists $info body] && ![dict exists $info header]} {
3297          dict set methods $name header "static int ${callproc}(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext objectContext ,int objc ,Tcl_Obj *const *objv)"
3298        }
3299        if {![dict exists $info methodtype]} {
3300          set methodtype [string map {{ } _ : _} OOMethodType_${thisclass}_${name}]
3301          dict set methods $name methodtype $methodtype
3302        }
3303      }
3304      if {![info exists code(initfuncts)] || "${thisclass}_OO_Init" ni $code(initfuncts)} {
3305        lappend code(initfuncts) "${thisclass}_OO_Init"
3306      }
3307    }
3308    set thisnspace [my define get nspace]
3309
3310    if {[info exists tclprocs]} {
3311      ::practcl::debug [self] tclprocs [dict keys $tclprocs]
3312      foreach {name info} $tclprocs {
3313        if {![dict exists $info callproc]} {
3314          set callproc [string map {____ _ ___ _ __ _} [string map {{ } _ : _} TclCmd_${thisnspace}_${name}]]
3315          dict set tclprocs $name callproc $callproc
3316        } else {
3317          set callproc [dict get $info callproc]
3318        }
3319        if {[dict exists $info body] && ![dict exists $info header]} {
3320          dict set tclprocs $name header "static int ${callproc}(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv\[\])"
3321        }
3322      }
3323    }
3324  }
3325
3326  # Once an object marks itself as some
3327  # flavor of dynamic, stop trying to morph
3328  # it into something else
3329  method select {} {}
3330
3331}
3332
3333
3334
3335###
3336# END: class dynamic.tcl
3337###
3338###
3339# START: class product.tcl
3340###
3341
3342::oo::class create ::practcl::product {
3343
3344
3345  method code {section body} {
3346    my variable code
3347    ::practcl::cputs code($section) $body
3348  }
3349
3350  method Collate_Source CWD {}
3351
3352  method project-compile-products {} {
3353    set result {}
3354    noop {
3355    set filename [my define get filename]
3356    if {$filename ne {}} {
3357      ::practcl::debug [self] [self class] [self method] project-compile-products $filename
3358      if {[my define exists ofile]} {
3359        set ofile [my define get ofile]
3360      } else {
3361        set ofile [my Ofile $filename]
3362        my define set ofile $ofile
3363      }
3364      lappend result $ofile [list cfile $filename include [my define get include]  extra [my define get extra] external [string is true -strict [my define get external]] object [self]]
3365    }
3366    }
3367    foreach item [my link list subordinate] {
3368      lappend result {*}[$item project-compile-products]
3369    }
3370    return $result
3371  }
3372
3373  method generate-debug {{spaces {}}} {
3374    set result {}
3375    ::practcl::cputs result "$spaces[list [self] [list class [info object class [self]] filename [my define get filename]] links [my link list]]"
3376    foreach item [my link list subordinate] {
3377      practcl::cputs result [$item generate-debug "$spaces  "]
3378    }
3379    return $result
3380  }
3381
3382  method generate-cfile-constant {} {
3383    ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]]
3384    set result {}
3385    my variable code cstruct methods tcltype
3386    if {[info exists code(constant)]} {
3387      ::practcl::cputs result "/* [my define get filename] CONSTANT */"
3388      ::practcl::cputs result $code(constant)
3389    }
3390    foreach obj [my link list product] {
3391      # Exclude products that will generate their own C files
3392      if {[$obj define get output_c] ne {}} continue
3393      ::practcl::cputs result [$obj generate-cfile-constant]
3394    }
3395    return $result
3396  }
3397
3398  ###
3399  # Populate const static data structures
3400  ###
3401  method generate-cfile-public-structure {} {
3402    ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]]
3403    my variable code cstruct methods tcltype
3404    set result {}
3405    if {[info exists code(struct)]} {
3406      ::practcl::cputs result $code(struct)
3407    }
3408    foreach obj [my link list product] {
3409      # Exclude products that will generate their own C files
3410      if {[$obj define get output_c] ne {}} continue
3411      ::practcl::cputs result [$obj generate-cfile-public-structure]
3412    }
3413    return $result
3414  }
3415
3416  method generate-cfile-header {} {
3417    ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]]
3418    my variable code cfunct cstruct methods tcltype tclprocs
3419    set result {}
3420    if {[info exists code(header)]} {
3421      ::practcl::cputs result $code(header)
3422    }
3423    foreach obj [my link list product] {
3424      # Exclude products that will generate their own C files
3425      if {[$obj define get output_c] ne {}} continue
3426      set dat [$obj generate-cfile-header]
3427      if {[string length [string trim $dat]]} {
3428        ::practcl::cputs result "/* BEGIN [$obj define get filename] generate-cfile-header */"
3429        ::practcl::cputs result $dat
3430        ::practcl::cputs result "/* END [$obj define get filename] generate-cfile-header */"
3431      }
3432    }
3433    return $result
3434  }
3435
3436  method generate-cfile-global {} {
3437    ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]]
3438    my variable code cfunct cstruct methods tcltype tclprocs
3439    set result {}
3440    if {[info exists code(global)]} {
3441      ::practcl::cputs result $code(global)
3442    }
3443    foreach obj [my link list product] {
3444      # Exclude products that will generate their own C files
3445      if {[$obj define get output_c] ne {}} continue
3446      set dat [$obj generate-cfile-global]
3447      if {[string length [string trim $dat]]} {
3448        ::practcl::cputs result "/* BEGIN [$obj define get filename] generate-cfile-global */"
3449        ::practcl::cputs result $dat
3450        ::practcl::cputs result "/* END [$obj define get filename] generate-cfile-global */"
3451      }
3452    }
3453    return $result
3454  }
3455
3456  method generate-cfile-private-typedef {} {
3457    ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]]
3458    my variable code cstruct
3459    set result {}
3460    if {[info exists code(private-typedef)]} {
3461      ::practcl::cputs result $code(private-typedef)
3462    }
3463    if {[info exists cstruct]} {
3464      # Add defintion for native c data structures
3465      foreach {name info} $cstruct {
3466        if {[dict get $info public]==1} continue
3467        ::practcl::cputs result "typedef struct $name ${name}\;"
3468        if {[dict exists $info aliases]} {
3469          foreach n [dict get $info aliases] {
3470            ::practcl::cputs result "typedef struct $name ${n}\;"
3471          }
3472        }
3473      }
3474    }
3475    set result [::practcl::_tagblock $result c [my define get filename]]
3476    foreach mod [my link list product] {
3477      ::practcl::cputs result [$mod generate-cfile-private-typedef]
3478    }
3479    return $result
3480  }
3481
3482  method generate-cfile-private-structure {} {
3483    ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]]
3484    my variable code cstruct
3485    set result {}
3486    if {[info exists code(private-structure)]} {
3487      ::practcl::cputs result $code(private-structure)
3488    }
3489    if {[info exists cstruct]} {
3490      foreach {name info} $cstruct {
3491        if {[dict get $info public]==1} continue
3492        if {[dict exists $info comment]} {
3493          ::practcl::cputs result [dict get $info comment]
3494        }
3495        ::practcl::cputs result "struct $name \{[dict get $info body]\}\;"
3496      }
3497    }
3498    set result [::practcl::_tagblock $result c [my define get filename]]
3499    foreach mod [my link list product] {
3500      ::practcl::cputs result [$mod generate-cfile-private-structure]
3501    }
3502    return $result
3503  }
3504
3505
3506  ###
3507  # Generate code that provides subroutines called by
3508  # Tcl API methods
3509  ###
3510  method generate-cfile-functions {} {
3511    ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]]
3512    my variable code cfunct
3513    set result {}
3514    if {[info exists code(funct)]} {
3515      ::practcl::cputs result $code(funct)
3516    }
3517    if {[info exists cfunct]} {
3518      foreach {funcname info} $cfunct {
3519        ::practcl::cputs result "/* $funcname */"
3520        if {[dict get $info inline] && [dict get $info public]} {
3521          ::practcl::cputs result "\ninline [dict get $info header]\{[dict get $info body]\}"
3522        } else {
3523          ::practcl::cputs result "\n[dict get $info header]\{[dict get $info body]\}"
3524        }
3525      }
3526    }
3527    foreach obj [my link list product] {
3528      # Exclude products that will generate their own C files
3529      if {[$obj define get output_c] ne {}} {
3530        continue
3531      }
3532      ::practcl::cputs result [$obj generate-cfile-functions]
3533    }
3534    return $result
3535  }
3536
3537  ###
3538  # Generate code that provides implements Tcl API
3539  # calls
3540  ###
3541  method generate-cfile-tclapi {} {
3542    ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]]
3543    my variable code methods tclprocs
3544    set result {}
3545    if {[info exists code(method)]} {
3546      ::practcl::cputs result $code(method)
3547    }
3548    foreach obj [my link list product] {
3549      # Exclude products that will generate their own C files
3550      if {[$obj define get output_c] ne {}} continue
3551      ::practcl::cputs result [$obj generate-cfile-tclapi]
3552    }
3553    return $result
3554  }
3555
3556
3557  method generate-hfile-public-define {} {
3558    ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]]
3559    my variable code
3560    set result {}
3561    if {[info exists code(public-define)]} {
3562      ::practcl::cputs result $code(public-define)
3563    }
3564    set result [::practcl::_tagblock $result c [my define get filename]]
3565    foreach mod [my link list product] {
3566      ::practcl::cputs result [$mod generate-hfile-public-define]
3567    }
3568    return $result
3569  }
3570
3571  method generate-hfile-public-macro {} {
3572    ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]]
3573    my variable code
3574    set result {}
3575    if {[info exists code(public-macro)]} {
3576      ::practcl::cputs result $code(public-macro)
3577    }
3578    set result [::practcl::_tagblock $result c [my define get filename]]
3579    foreach mod [my link list product] {
3580      ::practcl::cputs result [$mod generate-hfile-public-macro]
3581    }
3582    return $result
3583  }
3584
3585  method generate-hfile-public-typedef {} {
3586    ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]]
3587    my variable code cstruct
3588    set result {}
3589    if {[info exists code(public-typedef)]} {
3590      ::practcl::cputs result $code(public-typedef)
3591    }
3592    if {[info exists cstruct]} {
3593      # Add defintion for native c data structures
3594      foreach {name info} $cstruct {
3595        if {[dict get $info public]==0} continue
3596        ::practcl::cputs result "typedef struct $name ${name}\;"
3597        if {[dict exists $info aliases]} {
3598          foreach n [dict get $info aliases] {
3599            ::practcl::cputs result "typedef struct $name ${n}\;"
3600          }
3601        }
3602      }
3603    }
3604    set result [::practcl::_tagblock $result c [my define get filename]]
3605    foreach mod [my link list product] {
3606      ::practcl::cputs result [$mod generate-hfile-public-typedef]
3607    }
3608    return $result
3609  }
3610
3611  method generate-hfile-public-structure {} {
3612    ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]]
3613    my variable code cstruct
3614    set result {}
3615    if {[info exists code(public-structure)]} {
3616      ::practcl::cputs result $code(public-structure)
3617    }
3618    if {[info exists cstruct]} {
3619      foreach {name info} $cstruct {
3620        if {[dict get $info public]==0} continue
3621        if {[dict exists $info comment]} {
3622          ::practcl::cputs result [dict get $info comment]
3623        }
3624        ::practcl::cputs result "struct $name \{[dict get $info body]\}\;"
3625      }
3626    }
3627    set result [::practcl::_tagblock $result c [my define get filename]]
3628    foreach mod [my link list product] {
3629      ::practcl::cputs result [$mod generate-hfile-public-structure]
3630    }
3631    return $result
3632  }
3633
3634  method generate-hfile-public-headers {} {
3635    ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]]
3636    my variable code tcltype
3637    set result {}
3638    if {[info exists code(public-header)]} {
3639      ::practcl::cputs result $code(public-header)
3640    }
3641    if {[info exists tcltype]} {
3642      foreach {type info} $tcltype {
3643        if {![dict exists $info cname]} {
3644          set cname [string tolower ${type}]_tclobjtype
3645          dict set tcltype $type cname $cname
3646        } else {
3647          set cname [dict get $info cname]
3648        }
3649        ::practcl::cputs result "extern const Tcl_ObjType $cname\;"
3650      }
3651    }
3652    if {[info exists code(public)]} {
3653      ::practcl::cputs result $code(public)
3654    }
3655    set result [::practcl::_tagblock $result c [my define get filename]]
3656    foreach mod [my link list product] {
3657      ::practcl::cputs result [$mod generate-hfile-public-headers]
3658    }
3659    return $result
3660  }
3661
3662  method generate-hfile-public-function {} {
3663    ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]]
3664    my variable code cfunct tcltype
3665    set result {}
3666
3667    if {[my define get initfunc] ne {}} {
3668      ::practcl::cputs result "int [my define get initfunc](Tcl_Interp *interp);"
3669    }
3670    if {[info exists cfunct]} {
3671      foreach {funcname info} $cfunct {
3672        if {![dict get $info public]} continue
3673        ::practcl::cputs result "[dict get $info header]\;"
3674      }
3675    }
3676    set result [::practcl::_tagblock $result c [my define get filename]]
3677    foreach mod [my link list product] {
3678      ::practcl::cputs result [$mod generate-hfile-public-function]
3679    }
3680    return $result
3681  }
3682
3683  method generate-hfile-public-includes {} {
3684    ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]]
3685    set includes {}
3686    foreach item [my define get public-include] {
3687      if {$item ni $includes} {
3688        lappend includes $item
3689      }
3690    }
3691    foreach mod [my link list product] {
3692      foreach item [$mod generate-hfile-public-includes] {
3693        if {$item ni $includes} {
3694          lappend includes $item
3695        }
3696      }
3697    }
3698    return $includes
3699  }
3700
3701  method generate-hfile-public-verbatim {} {
3702    ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]]
3703    set includes {}
3704    foreach item [my define get public-verbatim] {
3705      if {$item ni $includes} {
3706        lappend includes $item
3707      }
3708    }
3709    foreach mod [my link list subordinate] {
3710      foreach item [$mod generate-hfile-public-verbatim] {
3711        if {$item ni $includes} {
3712          lappend includes $item
3713        }
3714      }
3715    }
3716    return $includes
3717  }
3718
3719  method generate-loader-external {} {
3720    if {[my define get initfunc] eq {}} {
3721      return "/*  [my define get filename] declared not initfunc */"
3722    }
3723    return "  if([my define get initfunc](interp)) return TCL_ERROR\;"
3724  }
3725
3726  method generate-loader-module {} {
3727    ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]]
3728    my variable code
3729    set result {}
3730    if {[info exists code(cinit)]} {
3731      ::practcl::cputs result $code(cinit)
3732    }
3733    if {[my define get initfunc] ne {}} {
3734      ::practcl::cputs result "  if([my define get initfunc](interp)!=TCL_OK) return TCL_ERROR\;"
3735    }
3736    set result [::practcl::_tagblock $result c [my define get filename]]
3737    foreach item [my link list product] {
3738      if {[$item define get output_c] ne {}} {
3739        ::practcl::cputs result [$item generate-loader-external]
3740      } else {
3741        ::practcl::cputs result [$item generate-loader-module]
3742      }
3743    }
3744    return $result
3745  }
3746
3747  method generate-stub-function {} {
3748    ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]]
3749    my variable code cfunct tcltype
3750    set result {}
3751    foreach mod [my link list product] {
3752      foreach {funct def} [$mod generate-stub-function] {
3753        dict set result $funct $def
3754      }
3755    }
3756    if {[info exists cfunct]} {
3757      foreach {funcname info} $cfunct {
3758        if {![dict get $info export]} continue
3759        dict set result $funcname [dict get $info header]
3760      }
3761    }
3762    return $result
3763  }
3764
3765
3766  method IncludeAdd {headervar args} {
3767    upvar 1 $headervar headers
3768    foreach inc $args {
3769      if {[string index $inc 0] ni {< \"}} {
3770        set inc "\"$inc\""
3771      }
3772      if {$inc ni $headers} {
3773        lappend headers $inc
3774      }
3775    }
3776  }
3777
3778  method generate-tcl-loader {} {
3779    set result {}
3780    set PKGINIT [my define get pkginit]
3781    set PKG_NAME [my define get name [my define get pkg_name]]
3782    set PKG_VERSION [my define get pkg_vers [my define get version]]
3783    if {[string is true [my define get SHARED_BUILD 0]]} {
3784      set LIBFILE [my define get libfile]
3785      ::practcl::cputs result [string map \
3786        [list @LIBFILE@ $LIBFILE @PKGINIT@ $PKGINIT @PKG_NAME@ $PKG_NAME @PKG_VERSION@ $PKG_VERSION] {
3787# Shared Library Style
3788load [file join [file dirname [file join [pwd] [info script]]] @LIBFILE@] @PKGINIT@
3789package provide @PKG_NAME@ @PKG_VERSION@
3790}]
3791    } else {
3792      ::practcl::cputs result [string map \
3793      [list @PKGINIT@ $PKGINIT @PKG_NAME@ $PKG_NAME @PKG_VERSION@ $PKG_VERSION] {
3794# Tclkit Style
3795load {} @PKGINIT@
3796package provide @PKG_NAME@ @PKG_VERSION@
3797}]
3798    }
3799    return $result
3800  }
3801
3802  ###
3803  # This methods generates any Tcl script file
3804  # which is required to pre-initialize the C library
3805  ###
3806  method generate-tcl-pre {} {
3807    ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]]
3808    set result {}
3809    my variable code
3810    if {[info exists code(tcl)]} {
3811      set result [::practcl::_tagblock $code(tcl) tcl [my define get filename]]
3812    }
3813    if {[info exists code(tcl-pre)]} {
3814      set result [::practcl::_tagblock $code(tcl) tcl [my define get filename]]
3815    }
3816    foreach mod [my link list product] {
3817      ::practcl::cputs result [$mod generate-tcl-pre]
3818    }
3819    return $result
3820  }
3821
3822  method generate-tcl-post {} {
3823    ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]]
3824    set result {}
3825    my variable code
3826    if {[info exists code(tcl-post)]} {
3827      set result [::practcl::_tagblock $code(tcl-post) tcl [my define get filename]]
3828    }
3829    foreach mod [my link list product] {
3830      ::practcl::cputs result [$mod generate-tcl-post]
3831    }
3832    return $result
3833  }
3834
3835
3836  method linktype {} {
3837    return {subordinate product}
3838  }
3839
3840  method Ofile filename {
3841    set lpath [my <module> define get localpath]
3842    if {$lpath eq {}} {
3843      set lpath [my <module> define get name]
3844    }
3845    return ${lpath}_[file rootname [file tail $filename]]
3846  }
3847
3848  ###
3849  # Methods called by the master project
3850  ###
3851
3852  method project-static-packages {} {
3853    set result [my define get static_packages]
3854    set initfunc [my define get initfunc]
3855    if {$initfunc ne {}} {
3856      set pkg_name [my define get pkg_name]
3857      if {$pkg_name ne {}} {
3858        dict set result $pkg_name initfunc $initfunc
3859        dict set result $pkg_name version [my define get version [my define get pkg_vers]]
3860        dict set result $pkg_name autoload [my define get autoload 0]
3861      }
3862    }
3863    foreach item [my link list subordinate] {
3864      foreach {pkg info} [$item project-static-packages] {
3865        dict set result $pkg $info
3866      }
3867    }
3868    return $result
3869  }
3870
3871  ###
3872  # Methods called by the toolset
3873  ###
3874
3875  method toolset-include-directory {} {
3876    ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]]
3877    set result [my define get include_dir]
3878    foreach obj [my link list product] {
3879      foreach path [$obj toolset-include-directory] {
3880        lappend result $path
3881      }
3882    }
3883    return $result
3884  }
3885
3886  method target {method args} {
3887    switch $method {
3888      is_unix { return [expr {$::tcl_platform(platform) eq "unix"}] }
3889    }
3890  }
3891
3892}
3893
3894oo::objdefine ::practcl::product {
3895  method select {object} {
3896    set class [$object define get class]
3897    set mixin [$object define get product]
3898    if {$class eq {} && $mixin eq {}} {
3899      set filename [$object define get filename]
3900      if {$filename ne {} && [file exists $filename]} {
3901        switch [file extension $filename] {
3902          .tcl {
3903            set mixin ::practcl::product.dynamic
3904          }
3905          .h {
3906            set mixin ::practcl::product.cheader
3907          }
3908          .c {
3909            set mixin ::practcl::product.csource
3910          }
3911          .ini {
3912            switch [file tail $filename] {
3913              module.ini {
3914                set class ::practcl::module
3915              }
3916              library.ini {
3917                set class ::practcl::subproject
3918              }
3919            }
3920          }
3921          .so -
3922          .dll -
3923          .dylib -
3924          .a {
3925            set mixin ::practcl::product.clibrary
3926          }
3927        }
3928      }
3929    }
3930    if {$class ne {}} {
3931      $object morph $class
3932    }
3933    if {$mixin ne {}} {
3934      $object mixin product $mixin
3935    }
3936  }
3937}
3938
3939###
3940# Flesh out several trivial varieties of product
3941###
3942::oo::class create ::practcl::product.cheader {
3943  superclass ::practcl::product
3944
3945  method project-compile-products {} {}
3946  method generate-loader-module {} {}
3947}
3948
3949::oo::class create ::practcl::product.csource {
3950  superclass ::practcl::product
3951
3952  method project-compile-products {} {
3953    set result {}
3954    set filename [my define get filename]
3955    if {$filename ne {}} {
3956      ::practcl::debug [self] [self class] [self method] project-compile-products $filename
3957      if {[my define exists ofile]} {
3958        set ofile [my define get ofile]
3959      } else {
3960        set ofile [my Ofile $filename]
3961        my define set ofile $ofile
3962      }
3963      lappend result $ofile [list cfile $filename extra [my define get extra] external [string is true -strict [my define get external]] object [self]]
3964    }
3965    foreach item [my link list subordinate] {
3966      lappend result {*}[$item project-compile-products]
3967    }
3968    return $result
3969  }
3970}
3971
3972::oo::class create ::practcl::product.clibrary {
3973  superclass ::practcl::product
3974
3975  method linker-products {configdict} {
3976    return [my define get filename]
3977  }
3978
3979}
3980
3981::oo::class create ::practcl::product.dynamic {
3982  superclass ::practcl::dynamic ::practcl::product
3983
3984  method initialize {} {
3985    set filename [my define get filename]
3986    if {$filename eq {}} {
3987      return
3988    }
3989    if {[my define get name] eq {}} {
3990      my define set name [file tail [file rootname $filename]]
3991    }
3992    if {[my define get localpath] eq {}} {
3993      my define set localpath [my <module> define get localpath]_[my define get name]
3994    }
3995    # Future Development:
3996    # Scan source file to see if it is encoded in criticl or practcl notation
3997    #set thisline {}
3998    #foreach line [split [::practcl::cat $filename] \n] {
3999    #
4000    #}
4001    ::source $filename
4002    if {[my define get output_c] ne {}} {
4003      # Turn into a module if we have an output_c file
4004      my morph ::practcl::module
4005    }
4006  }
4007}
4008
4009::oo::class create ::practcl::product.critcl {
4010  superclass ::practcl::dynamic ::practcl::product
4011}
4012
4013
4014###
4015# END: class product.tcl
4016###
4017###
4018# START: class module.tcl
4019###
4020
4021###
4022# In the end, all C code must be loaded into a module
4023# This will either be a dynamically loaded library implementing
4024# a tcl extension, or a compiled in segment of a custom shell/app
4025###
4026::oo::class create ::practcl::module {
4027  superclass ::practcl::object ::practcl::product.dynamic
4028
4029  method _MorphPatterns {} {
4030    return {{@name@} {::practcl::module.@name@} ::practcl::module}
4031  }
4032
4033  method add args {
4034    my variable links
4035    set object [::practcl::object new [self] {*}$args]
4036    foreach linktype [$object linktype] {
4037      lappend links($linktype) $object
4038    }
4039    return $object
4040  }
4041
4042
4043  method install-headers args {}
4044
4045  ###
4046  # Target handling
4047  ###
4048  method make {command args} {
4049    my variable make_object
4050    if {![info exists make_object]} {
4051      set make_object {}
4052    }
4053    switch $command {
4054      pkginfo {
4055        ###
4056        # Build local variables needed for install
4057        ###
4058        package require platform
4059        set result {}
4060        set dat [my define dump]
4061        set PKG_DIR [dict get $dat name][dict get $dat version]
4062        dict set result PKG_DIR $PKG_DIR
4063        dict with dat {}
4064        if {![info exists DESTDIR]} {
4065          set DESTDIR {}
4066        }
4067        dict set result profile [::platform::identify]
4068        dict set result os $::tcl_platform(os)
4069        dict set result platform $::tcl_platform(platform)
4070        foreach {field value} $dat {
4071          switch $field {
4072            includedir -
4073            mandir -
4074            datadir -
4075            libdir -
4076            libfile -
4077            name -
4078            output_tcl -
4079            version -
4080            authors -
4081            license -
4082            requires {
4083              dict set result $field $value
4084            }
4085            TEA_PLATFORM {
4086              dict set result platform $value
4087            }
4088            TEACUP_OS {
4089              dict set result os $value
4090            }
4091            TEACUP_PROFILE {
4092              dict set result profile $value
4093            }
4094            TEACUP_ZIPFILE {
4095              dict set result zipfile $value
4096            }
4097          }
4098        }
4099        if {![dict exists $result zipfile]} {
4100          dict set result zipfile "[dict get $result name]-[dict get $result version]-[dict get $result profile].zip"
4101        }
4102        return $result
4103      }
4104      objects {
4105        return $make_object
4106      }
4107      object {
4108        set name [lindex $args 0]
4109        if {[dict exists $make_object $name]} {
4110          return [dict get $make_object $name]
4111        }
4112        return {}
4113      }
4114      reset {
4115        foreach {name obj} $make_object {
4116          $obj reset
4117        }
4118      }
4119      trigger {
4120        foreach {name obj} $make_object {
4121          if {$name in $args} {
4122            $obj triggers
4123          }
4124        }
4125      }
4126      depends {
4127        foreach {name obj} $make_object {
4128          if {$name in $args} {
4129            $obj check
4130          }
4131        }
4132      }
4133      filename {
4134        set name [lindex $args 0]
4135        if {[dict exists $make_object $name]} {
4136          return [[dict get $make_object $name] define get filename]
4137        }
4138      }
4139      task -
4140      target -
4141      add {
4142        set name [lindex $args 0]
4143        set info [uplevel #0 [list subst [lindex $args 1]]]
4144        set body [lindex $args 2]
4145
4146        set nspace [namespace current]
4147        if {[dict exist $make_object $name]} {
4148          set obj [dict get $$make_object $name]
4149        } else {
4150          set obj [::practcl::make_obj new [self] $name $info $body]
4151          dict set make_object $name $obj
4152          dict set target_make $name 0
4153          dict set target_trigger $name 0
4154        }
4155        if {[dict exists $info aliases]} {
4156          foreach item [dict get $info aliases] {
4157            if {![dict exists $make_object $item]} {
4158              dict set make_object $item $obj
4159            }
4160          }
4161        }
4162        return $obj
4163      }
4164      todo {
4165         foreach {name obj} $make_object {
4166          if {[$obj do]} {
4167            lappend result $name
4168          }
4169        }
4170      }
4171      do {
4172        global CWD SRCDIR project SANDBOX
4173        foreach {name obj} $make_object {
4174          if {[$obj do]} {
4175            eval [$obj define get action]
4176          }
4177        }
4178      }
4179    }
4180  }
4181
4182  method child which {
4183    switch $which {
4184      organs {
4185        return [list project [my define get project] module [self]]
4186      }
4187    }
4188  }
4189
4190 ###
4191  # This methods generates the contents of an amalgamated .c file
4192  # which implements the loader for a batch of tools
4193  ###
4194  method generate-c {} {
4195    ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]]
4196    set result {
4197/* This file was generated by practcl */
4198    }
4199    set includes {}
4200
4201    foreach mod [my link list product] {
4202      # Signal modules to formulate final implementation
4203      $mod go
4204    }
4205    set headers {}
4206
4207    my IncludeAdd headers <tcl.h> <tclOO.h>
4208    if {[my define get tk 0]} {
4209      my IncludeAdd headers <tk.h>
4210    }
4211    if {[my define get output_h] ne {}} {
4212      my IncludeAdd headers [my define get output_h]
4213    }
4214    my IncludeAdd headers {*}[my define get include]
4215
4216    foreach mod [my link list dynamic] {
4217      my IncludeAdd headers {*}[$mod define get include]
4218    }
4219    foreach inc $headers {
4220      ::practcl::cputs result "#include $inc"
4221    }
4222    foreach {method} {
4223      generate-cfile-header
4224      generate-cfile-private-typedef
4225      generate-cfile-private-structure
4226      generate-cfile-public-structure
4227      generate-cfile-constant
4228      generate-cfile-global
4229      generate-cfile-functions
4230      generate-cfile-tclapi
4231    } {
4232      set dat [my $method]
4233      if {[string length [string trim $dat]]} {
4234        ::practcl::cputs result "/* BEGIN $method [my define get filename] */"
4235        ::practcl::cputs result $dat
4236        ::practcl::cputs result "/* END $method [my define get filename] */"
4237      }
4238    }
4239    ::practcl::debug [list /[self] [self method] [self class] -- [my define get filename] [info object class [self]]]
4240    return $result
4241  }
4242
4243
4244  ###
4245  # This methods generates the contents of an amalgamated .h file
4246  # which describes the public API of this module
4247  ###
4248  method generate-h {} {
4249    ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]]
4250    set result {}
4251    set includes [my generate-hfile-public-includes]
4252    foreach inc $includes {
4253      if {[string index $inc 0] ni {< \"}} {
4254        ::practcl::cputs result "#include \"$inc\""
4255      } else {
4256        ::practcl::cputs result "#include $inc"
4257      }
4258    }
4259
4260    foreach method {
4261      generate-hfile-public-define
4262      generate-hfile-public-macro
4263      generate-hfile-public-typedef
4264      generate-hfile-public-structure
4265    } {
4266      ::practcl::cputs result "/* BEGIN SECTION $method */"
4267      ::practcl::cputs result [my $method]
4268      ::practcl::cputs result "/* END SECTION $method */"
4269    }
4270
4271    foreach file [my generate-hfile-public-verbatim] {
4272      ::practcl::cputs result "/* BEGIN $file */"
4273      ::practcl::cputs result [::practcl::cat $file]
4274      ::practcl::cputs result "/* END $file */"
4275    }
4276
4277    foreach method {
4278      generate-hfile-public-headers
4279      generate-hfile-public-function
4280    } {
4281      ::practcl::cputs result "/* BEGIN SECTION $method */"
4282      ::practcl::cputs result [my $method]
4283      ::practcl::cputs result "/* END SECTION $method */"
4284    }
4285    return $result
4286  }
4287
4288  method generate-loader {} {
4289    ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]]
4290    set result {}
4291    if {[my define get initfunc] eq {}} return
4292    ::practcl::cputs result  "
4293extern int DLLEXPORT [my define get initfunc]( Tcl_Interp *interp ) \{"
4294    ::practcl::cputs result  {
4295  /* Initialise the stubs tables. */
4296  #ifdef USE_TCL_STUBS
4297    if (Tcl_InitStubs(interp, "8.6", 0)==NULL) return TCL_ERROR;
4298    if (TclOOInitializeStubs(interp, "1.0") == NULL) return TCL_ERROR;
4299}
4300    if {[my define get tk 0]} {
4301      ::practcl::cputs result  {    if (Tk_InitStubs(interp, "8.6", 0)==NULL) return TCL_ERROR;}
4302    }
4303    ::practcl::cputs result {  #endif}
4304    set TCLINIT [my generate-tcl-pre]
4305    if {[string length [string trim $TCLINIT]]} {
4306      ::practcl::cputs result "  if(interp) {\nif(Tcl_Eval(interp,[::practcl::tcl_to_c $TCLINIT])) return TCL_ERROR;\n  }"
4307    }
4308    ::practcl::cputs result [my generate-loader-module]
4309
4310    set TCLINIT [my generate-tcl-post]
4311    if {[string length [string trim $TCLINIT]]} {
4312      ::practcl::cputs result "  if(interp) {\nif(Tcl_Eval(interp,[::practcl::tcl_to_c $TCLINIT])) return TCL_ERROR;\n }"
4313    }
4314    if {[my define exists pkg_name]} {
4315      ::practcl::cputs result  "    if (Tcl_PkgProvide(interp, \"[my define get pkg_name [my define get name]]\" , \"[my define get pkg_vers [my define get version]]\" )) return TCL_ERROR\;"
4316    }
4317    ::practcl::cputs result  "  return TCL_OK\;\n\}\n"
4318    return $result
4319  }
4320  method initialize {} {
4321    set filename [my define get filename]
4322    if {$filename eq {}} {
4323      return
4324    }
4325    if {[my define get name] eq {}} {
4326      my define set name [file tail [file dirname $filename]]
4327    }
4328    if {[my define get localpath] eq {}} {
4329      my define set localpath [my <project> define get name]_[my define get name]
4330    }
4331    my graft module [self]
4332    ::practcl::debug [self] SOURCE $filename
4333    my source $filename
4334  }
4335
4336  method implement path {
4337    my go
4338    my Collate_Source $path
4339    set errs {}
4340    foreach item [my link list dynamic] {
4341      if {[catch {$item implement $path} err errdat]} {
4342        lappend errs "Skipped $item: [$item define get filename] $err"
4343        if {[dict exists $errdat -errorinfo]} {
4344          lappend errs [dict get $errdat -errorinfo]
4345        } else {
4346          lappend errs $errdat
4347        }
4348      }
4349    }
4350    foreach item [my link list module] {
4351      if {[catch {$item implement $path} err errdat]} {
4352        lappend errs "Skipped $item: [$item define get filename] $err"
4353        if {[dict exists $errdat -errorinfo]} {
4354          lappend errs [dict get $errdat -errorinfo]
4355        } else {
4356          lappend errs $errdat
4357        }
4358      }
4359    }
4360    if {[llength $errs]} {
4361      set logfile [file join $::CWD practcl.log]
4362      ::practcl::log $logfile "*** ERRORS ***"
4363      foreach {item trace} $errs {
4364        ::practcl::log $logfile "###\n# ERROR\n###\n$item"
4365       ::practcl::log $logfile "###\n# TRACE\n###\n$trace"
4366      }
4367      ::practcl::log $logfile "*** DEBUG INFO ***"
4368      ::practcl::log $logfile $::DEBUG_INFO
4369      puts stderr "Errors saved to $logfile"
4370      exit 1
4371    }
4372    ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]]
4373    set filename [my define get output_c]
4374    if {$filename eq {}} {
4375      ::practcl::debug [list /[self] [self method] [self class]]
4376      return
4377    }
4378    set cout [open [file join $path [file rootname $filename].c] w]
4379    puts $cout [subst {/*
4380** This file is generated by the [info script] script
4381** any changes will be overwritten the next time it is run
4382*/}]
4383    puts $cout [my generate-c]
4384    puts $cout [my generate-loader]
4385    close $cout
4386    ::practcl::debug [list /[self] [self method] [self class]]
4387  }
4388
4389  method linktype {} {
4390    return {subordinate product dynamic module}
4391  }
4392}
4393
4394###
4395# END: class module.tcl
4396###
4397###
4398# START: class project baseclass.tcl
4399###
4400
4401::oo::class create ::practcl::project {
4402  superclass ::practcl::module
4403
4404  method _MorphPatterns {} {
4405    return {{@name@} {::practcl::@name@} {::practcl::project.@name@} {::practcl::project}}
4406  }
4407
4408  constructor args {
4409    my variable define
4410    if {[llength $args] == 1} {
4411      set rawcontents [lindex $args 0]
4412    } else {
4413      set rawcontents $args
4414    }
4415    if {[catch {uplevel 1 [list subst $rawcontents]} contents]} {
4416      set contents $rawcontents
4417    }
4418    ###
4419    # The first instance of ::practcl::project (or its descendents)
4420    # registers itself as the ::practcl::MAIN. If a project other
4421    # than ::practcl::LOCAL is created, odds are that was the one
4422    # the developer intended to be the main project
4423    ###
4424    if {$::practcl::MAIN eq "::practcl::LOCAL"} {
4425      set ::practcl::MAIN [self]
4426    }
4427    # DEFS fields need to be passed unchanged and unsubstituted
4428    # as we need to preserve their escape characters
4429    foreach field {TCL_DEFS DEFS TK_DEFS} {
4430      if {[dict exists $rawcontents $field]} {
4431        dict set contents $field [dict get $rawcontents $field]
4432      }
4433    }
4434    my graft module [self]
4435    array set define $contents
4436    ::practcl::toolset select [self]
4437    my initialize
4438  }
4439
4440  method add_object object {
4441    my link object $object
4442  }
4443
4444  method add_project {pkg info {oodefine {}}} {
4445    ::practcl::debug [self] add_project $pkg $info
4446    set os [my define get TEACUP_OS]
4447    if {$os eq {}} {
4448      set os [::practcl::os]
4449      my define set os $os
4450    }
4451    set fossilinfo [list download [my define get download] tag trunk sandbox [my define get sandbox]]
4452    if {[dict exists $info os] && ($os ni [dict get $info os])} return
4453    # Select which tag to use here.
4454    # For production builds: tag-release
4455    set profile [my define get profile release]:
4456    if {[dict exists $info profile $profile]} {
4457      dict set info tag [dict get $info profile $profile]
4458    }
4459    dict set info USEMSVC [my define get USEMSVC 0]
4460    dict set info debug [my define get debug 0]
4461    set obj [namespace current]::PROJECT.$pkg
4462    if {[info command $obj] eq {}} {
4463      set obj [::practcl::subproject create $obj [self] [dict merge $fossilinfo [list name $pkg pkg_name $pkg static 0 class subproject.binary] $info]]
4464    }
4465    my link object $obj
4466    oo::objdefine $obj $oodefine
4467    $obj define set masterpath $::CWD
4468    $obj go
4469    return $obj
4470  }
4471
4472  method add_tool {pkg info {oodefine {}}} {
4473    ::practcl::debug [self] add_tool $pkg $info
4474    set info [dict merge [::practcl::local_os] $info]
4475
4476    set os [dict get $info TEACUP_OS]
4477    set fossilinfo [list download [my define get download] tag trunk sandbox [my define get sandbox]]
4478    if {[dict exists $info os] && ($os ni [dict get $info os])} return
4479    # Select which tag to use here.
4480    # For production builds: tag-release
4481    set profile [my define get profile release]:
4482    if {[dict exists $info profile $profile]} {
4483      dict set info tag [dict get $info profile $profile]
4484    }
4485    set obj ::practcl::OBJECT::TOOL.$pkg
4486    if {[info command $obj] eq {}} {
4487      set obj [::practcl::subproject create $obj [self] [dict merge $fossilinfo [list name $pkg pkg_name $pkg static 0] $info]]
4488    }
4489    my link add tool $obj
4490    oo::objdefine $obj $oodefine
4491    $obj define set masterpath $::CWD
4492    $obj go
4493    return $obj
4494  }
4495
4496  method build-tclcore {} {
4497    set os [my define get TEACUP_OS]
4498    set tcl_config_opts [::practcl::platform::tcl_core_options $os]
4499    set tk_config_opts  [::practcl::platform::tk_core_options $os]
4500
4501    lappend tcl_config_opts --prefix [my define get prefix] --exec-prefix [my define get prefix]
4502    set tclobj [my tclcore]
4503    if {[my define get debug 0]} {
4504      $tclobj define set debug 1
4505      lappend tcl_config_opts --enable-symbols=true
4506    }
4507    $tclobj define set config_opts $tcl_config_opts
4508    $tclobj go
4509    $tclobj compile
4510
4511    set _TclSrcDir [$tclobj define get localsrcdir]
4512    my define set tclsrcdir $_TclSrcDir
4513
4514    set tkobj [my tkcore]
4515    lappend tk_config_opts --with-tcl=[::practcl::file_relative [$tkobj define get builddir]  [$tclobj define get builddir]]
4516    if {[my define get debug 0]} {
4517      $tkobj define set debug 1
4518      lappend tk_config_opts --enable-symbols=true
4519    }
4520    $tkobj define set config_opts $tk_config_opts
4521    $tkobj compile
4522  }
4523
4524  method child which {
4525    switch $which {
4526      organs {
4527	# A library can be a project, it can be a module. Any
4528	# subordinate modules will indicate their existance
4529        return [list project [self] module [self]]
4530      }
4531    }
4532  }
4533
4534  method linktype {} {
4535    return project
4536  }
4537
4538
4539  # Exercise the methods of a sub-object
4540  method project {pkg args} {
4541    set obj [namespace current]::PROJECT.$pkg
4542    if {[llength $args]==0} {
4543      return $obj
4544    }
4545    ${obj} {*}$args
4546  }
4547
4548
4549  method tclcore {} {
4550    if {[info commands [set obj [my organ tclcore]]] ne {}} {
4551      return $obj
4552    }
4553    if {[info commands [set obj [my project TCLCORE]]] ne {}} {
4554      my graft tclcore $obj
4555      return $obj
4556    }
4557    if {[info commands [set obj [my project tcl]]] ne {}} {
4558      my graft tclcore $obj
4559      return $obj
4560    }
4561    if {[info commands [set obj [my tool tcl]]] ne {}} {
4562      my graft tclcore $obj
4563      return $obj
4564    }
4565    # Provide a fallback
4566    set obj [my add_tool tcl {
4567      tag release class subproject.core
4568      fossil_url http://core.tcl.tk/tcl
4569    }]
4570    my graft tclcore $obj
4571    return $obj
4572  }
4573
4574  method tkcore {} {
4575    if {[set obj [my organ tkcore]] ne {}} {
4576      return $obj
4577    }
4578    if {[set obj [my project tk]] ne {}} {
4579      my graft tkcore $obj
4580      return $obj
4581    }
4582    if {[set obj [my tool tk]] ne {}} {
4583      my graft tkcore $obj
4584      return $obj
4585    }
4586    # Provide a fallback
4587    set obj [my add_tool tk {
4588      tag release class tool.core
4589      fossil_url http://core.tcl.tk/tk
4590    }]
4591    my graft tkcore $obj
4592    return $obj
4593  }
4594
4595  method tool {pkg args} {
4596    set obj ::practcl::OBJECT::TOOL.$pkg
4597    if {[llength $args]==0} {
4598      return $obj
4599    }
4600    ${obj} {*}$args
4601  }
4602}
4603
4604###
4605# END: class project baseclass.tcl
4606###
4607###
4608# START: class project library.tcl
4609###
4610
4611::oo::class create ::practcl::library {
4612  superclass ::practcl::project
4613
4614
4615  method clean {PATH} {
4616    set objext [my define get OBJEXT o]
4617    foreach {ofile info} [my project-compile-products] {
4618      if {[file exists [file join $PATH objs $ofile].${objext}]} {
4619        file delete [file join $PATH objs $ofile].${objext}
4620      }
4621    }
4622    foreach ofile [glob -nocomplain [file join $PATH *.${objext}]] {
4623      file delete $ofile
4624    }
4625    foreach ofile [glob -nocomplain [file join $PATH objs *]] {
4626      file delete $ofile
4627    }
4628    set libfile [my define get libfile]
4629    if {[file exists [file join $PATH $libfile]]} {
4630      file delete [file join $PATH $libfile]
4631    }
4632    my implement $PATH
4633  }
4634
4635  method project-compile-products {} {
4636    set result {}
4637    foreach item [my link list subordinate] {
4638      lappend result {*}[$item project-compile-products]
4639    }
4640    set filename [my define get output_c]
4641    if {$filename ne {}} {
4642      ::practcl::debug [self] [self class] [self method] project-compile-products $filename
4643      set ofile [file rootname [file tail $filename]]_main
4644      lappend result $ofile [list cfile $filename extra [my define get extra] external [string is true -strict [my define get external]]]
4645    }
4646    return $result
4647  }
4648
4649
4650  method go {} {
4651    ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]]
4652    set name [my define getnull name]
4653    if {$name eq {}} {
4654      set name generic
4655      my define name generic
4656    }
4657    if {[my define get tk] eq {@TEA_TK_EXTENSION@}} {
4658      my define set tk 0
4659    }
4660    set output_c [my define getnull output_c]
4661    if {$output_c eq {}} {
4662      set output_c [file rootname $name].c
4663      my define set output_c $output_c
4664    }
4665    set output_h [my define getnull output_h]
4666    if {$output_h eq {}} {
4667      set output_h [file rootname $output_c].h
4668      my define set output_h $output_h
4669    }
4670    set output_tcl [my define getnull output_tcl]
4671    #if {$output_tcl eq {}} {
4672    #  set output_tcl [file rootname $output_c].tcl
4673    #  my define set output_tcl $output_tcl
4674    #}
4675    #set output_mk [my define getnull output_mk]
4676    #if {$output_mk eq {}} {
4677    #  set output_mk [file rootname $output_c].mk
4678    #  my define set output_mk $output_mk
4679    #}
4680    set initfunc [my define getnull initfunc]
4681    if {$initfunc eq {}} {
4682      set initfunc [string totitle $name]_Init
4683      my define set initfunc $initfunc
4684    }
4685    set output_decls [my define getnull output_decls]
4686    if {$output_decls eq {}} {
4687      set output_decls [file rootname $output_c].decls
4688      my define set output_decls $output_decls
4689    }
4690    my variable links
4691    foreach {linktype objs} [array get links] {
4692      foreach obj $objs {
4693        $obj go
4694      }
4695    }
4696    ::practcl::debug [list /[self] [self method] [self class] -- [my define get filename] [info object class [self]]]
4697  }
4698
4699
4700  method generate-decls {pkgname path} {
4701    ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]]
4702    set outfile [file join $path/$pkgname.decls]
4703
4704    ###
4705    # Build the decls file
4706    ## #
4707    set fout [open $outfile w]
4708    puts $fout [subst {###
4709  # $outfile
4710  #
4711  # This file was generated by [info script]
4712  ###
4713
4714library $pkgname
4715interface $pkgname
4716}]
4717
4718    ###
4719    # Generate list of functions
4720    ###
4721    set stubfuncts [my generate-stub-function]
4722    set thisline {}
4723    set functcount 0
4724    foreach {func header} $stubfuncts {
4725      puts $fout [list declare [incr functcount] $header]
4726    }
4727    puts $fout [list export "int [my define get initfunc](Tcl_Inter *interp)"]
4728    puts $fout [list export "char *[string totitle [my define get name]]_InitStubs(Tcl_Inter *interp, char *version, int exact)"]
4729
4730    close $fout
4731
4732    ###
4733    # Build [package]Decls.h
4734    ###
4735    set hout [open [file join $path ${pkgname}Decls.h] w]
4736    close $hout
4737
4738    set cout [open [file join $path ${pkgname}StubInit.c] w]
4739    puts $cout [string map [list %pkgname% $pkgname %PkgName% [string totitle $pkgname]] {
4740#ifndef USE_TCL_STUBS
4741#define USE_TCL_STUBS
4742#endif
4743#undef USE_TCL_STUB_PROCS
4744
4745#include "tcl.h"
4746#include "%pkgname%.h"
4747
4748/*
4749** Ensure that Tdom_InitStubs is built as an exported symbol.  The other stub
4750** functions should be built as non-exported symbols.
4751*/
4752
4753#undef TCL_STORAGE_CLASS
4754#define TCL_STORAGE_CLASS DLLEXPORT
4755
4756%PkgName%Stubs *%pkgname%StubsPtr;
4757
4758 /*
4759 **----------------------------------------------------------------------
4760 **
4761 **  %PkgName%_InitStubs --
4762 **
4763 **        Checks that the correct version of %PkgName% is loaded and that it
4764 **        supports stubs. It then initialises the stub table pointers.
4765 **
4766 **  Results:
4767 **        The actual version of %PkgName% that satisfies the request, or
4768 **        NULL to indicate that an error occurred.
4769 **
4770 **  Side effects:
4771 **        Sets the stub table pointers.
4772 **
4773 **----------------------------------------------------------------------
4774 */
4775
4776char *
4777%PkgName%_InitStubs (Tcl_Interp *interp, char *version, int exact)
4778{
4779  char *actualVersion;
4780  actualVersion = Tcl_PkgRequireEx(interp, "%pkgname%", version, exact,(ClientData *) &%pkgname%StubsPtr);
4781  if (!actualVersion) {
4782    return NULL;
4783  }
4784  if (!%pkgname%StubsPtr) {
4785    Tcl_SetResult(interp,"This implementation of %PkgName% does not support stubs",TCL_STATIC);
4786    return NULL;
4787  }
4788  return actualVersion;
4789}
4790}]
4791    close $cout
4792  }
4793
4794  method implement path {
4795    my go
4796    my Collate_Source $path
4797    set errs {}
4798    foreach item [my link list dynamic] {
4799      if {[catch {$item implement $path} err errdat]} {
4800        lappend errs "Skipped $item: [$item define get filename] $err"
4801        if {[dict exists $errdat -errorinfo]} {
4802          lappend errs [dict get $errdat -errorinfo]
4803        } else {
4804          lappend errs $errdat
4805        }
4806      }
4807    }
4808    foreach item [my link list module] {
4809      if {[catch {$item implement $path} err errdat]} {
4810        lappend errs "Skipped $item: [$item define get filename] $err"
4811        if {[dict exists $errdat -errorinfo]} {
4812          lappend errs [dict get $errdat -errorinfo]
4813        } else {
4814          lappend errs $errdat
4815        }
4816      }
4817    }
4818    if {[llength $errs]} {
4819      set logfile [file join $::CWD practcl.log]
4820      ::practcl::log $logfile "*** ERRORS ***"
4821      foreach {item trace} $errs {
4822        ::practcl::log $logfile "###\n# ERROR\n###$item"
4823        ::practcl::log $logfile "###\n# TRACE\n###$trace"
4824      }
4825      ::practcl::log $logfile "*** DEBUG INFO ***"
4826      ::practcl::log $logfile $::DEBUG_INFO
4827      puts stderr "Errors saved to $logfile"
4828      exit 1
4829    }
4830    set cout [open [file join $path [my define get output_c]] w]
4831    puts $cout [subst {/*
4832** This file is generated by the [info script] script
4833** any changes will be overwritten the next time it is run
4834*/}]
4835    puts $cout [my generate-c]
4836    puts $cout [my generate-loader]
4837    close $cout
4838
4839    set macro HAVE_[string toupper [file rootname [my define get output_h]]]_H
4840    set hout [open [file join $path [my define get output_h]] w]
4841    puts $hout [subst {/*
4842** This file is generated by the [info script] script
4843** any changes will be overwritten the next time it is run
4844*/}]
4845    puts $hout "#ifndef ${macro}"
4846    puts $hout "#define ${macro} 1"
4847    puts $hout [my generate-h]
4848    puts $hout "#endif"
4849    close $hout
4850
4851    set output_tcl [my define get output_tcl]
4852    if {$output_tcl ne {}} {
4853      set tclout [open [file join $path [my define get output_tcl]] w]
4854      puts $tclout "###
4855# This file is generated by the [info script] script
4856# any changes will be overwritten the next time it is run
4857###"
4858      puts $tclout [my generate-tcl-pre]
4859      puts $tclout [my generate-tcl-loader]
4860      puts $tclout [my generate-tcl-post]
4861      close $tclout
4862    }
4863  }
4864
4865  # Backward compadible call
4866  method generate-make path {
4867    my build-Makefile $path [self]
4868  }
4869
4870  method linktype {} {
4871    return library
4872  }
4873
4874  # Create a "package ifneeded"
4875  # Args are a list of aliases for which this package will answer to
4876  method package-ifneeded {args} {
4877    set result {}
4878    set name [my define get pkg_name [my define get name]]
4879    set version [my define get pkg_vers [my define get version]]
4880    if {$version eq {}} {
4881      set version 0.1a
4882    }
4883    set output_tcl [my define get output_tcl]
4884    if {$output_tcl ne {}} {
4885      set script "\[list source \[file join \$dir $output_tcl\]\]"
4886    } elseif {[string is true -strict [my define get SHARED_BUILD]]} {
4887      set script "\[list load \[file join \$dir [my define get libfile]\] $name\]"
4888    } else {
4889      # Provide a null passthrough
4890      set script "\[list package provide $name $version\]"
4891    }
4892    set result "package ifneeded [list $name] [list $version] $script"
4893    foreach alias $args {
4894      set script "package require $name $version \; package provide $alias $version"
4895      append result \n\n [list package ifneeded $alias $version $script]
4896    }
4897    return $result
4898  }
4899
4900
4901  method shared_library {{filename {}}} {
4902    set name [string tolower [my define get name [my define get pkg_name]]]
4903    set NAME [string toupper $name]
4904    set version [my define get version [my define get pkg_vers]]
4905    set map {}
4906    lappend map %LIBRARY_NAME% $name
4907    lappend map %LIBRARY_VERSION% $version
4908    lappend map %LIBRARY_VERSION_NODOTS% [string map {. {}} $version]
4909    lappend map %LIBRARY_PREFIX% [my define getnull libprefix]
4910    set outfile [string map $map [my define get PRACTCL_NAME_LIBRARY]][my define get SHLIB_SUFFIX]
4911    return $outfile
4912  }
4913
4914  method static_library {{filename {}}} {
4915    set name [string tolower [my define get name [my define get pkg_name]]]
4916    set NAME [string toupper $name]
4917    set version [my define get version [my define get pkg_vers]]
4918    set map {}
4919    lappend map %LIBRARY_NAME% $name
4920    lappend map %LIBRARY_VERSION% $version
4921    lappend map %LIBRARY_VERSION_NODOTS% [string map {. {}} $version]
4922    lappend map %LIBRARY_PREFIX% [my define getnull libprefix]
4923    set outfile [string map $map [my define get PRACTCL_NAME_LIBRARY]].a
4924    return $outfile
4925  }
4926}
4927
4928###
4929# END: class project library.tcl
4930###
4931###
4932# START: class project tclkit.tcl
4933###
4934
4935
4936::oo::class create ::practcl::tclkit {
4937  superclass ::practcl::library
4938
4939  method build-tclkit_main {PROJECT PKG_OBJS} {
4940    ###
4941    # Build static package list
4942    ###
4943    set statpkglist {}
4944    foreach cobj [list {*}${PKG_OBJS} $PROJECT] {
4945      foreach {pkg info} [$cobj project-static-packages] {
4946        dict set statpkglist $pkg $info
4947      }
4948    }
4949    foreach {ofile info} [${PROJECT} project-compile-products] {
4950      if {![dict exists $info object]} continue
4951      set cobj [dict get $info object]
4952      foreach {pkg info} [$cobj project-static-packages] {
4953        dict set statpkglist $pkg $info
4954      }
4955    }
4956
4957    set result {}
4958    $PROJECT include {<tcl.h>}
4959    $PROJECT include {"tclInt.h"}
4960    $PROJECT include {"tclFileSystem.h"}
4961    $PROJECT include {<assert.h>}
4962    $PROJECT include {<stdio.h>}
4963    $PROJECT include {<stdlib.h>}
4964    $PROJECT include {<string.h>}
4965    $PROJECT include {<math.h>}
4966
4967    $PROJECT code header {
4968#ifndef MODULE_SCOPE
4969#   define MODULE_SCOPE extern
4970#endif
4971
4972/*
4973** Provide a dummy Tcl_InitStubs if we are using this as a static
4974** library.
4975*/
4976#ifndef USE_TCL_STUBS
4977# undef  Tcl_InitStubs
4978# define Tcl_InitStubs(a,b,c) TCL_VERSION
4979#endif
4980#define STATIC_BUILD 1
4981#undef USE_TCL_STUBS
4982
4983/* Make sure the stubbed variants of those are never used. */
4984#undef Tcl_ObjSetVar2
4985#undef Tcl_NewStringObj
4986#undef Tk_Init
4987#undef Tk_MainEx
4988#undef Tk_SafeInit
4989}
4990
4991    # Build an area of the file for #define directives and
4992    # function declarations
4993    set define {}
4994    set mainhook   [$PROJECT define get TCL_LOCAL_MAIN_HOOK Tclkit_MainHook]
4995    set mainfunc   [$PROJECT define get TCL_LOCAL_APPINIT Tclkit_AppInit]
4996    set mainscript [$PROJECT define get main.tcl main.tcl]
4997    set vfsroot    [$PROJECT define get vfsroot "[$PROJECT define get ZIPFS_VOLUME]app"]
4998    set vfs_main "${vfsroot}/${mainscript}"
4999
5000    set map {}
5001    foreach var {
5002      vfsroot mainhook mainfunc vfs_main
5003    } {
5004      dict set map %${var}% [set $var]
5005    }
5006    set preinitscript {
5007set ::odie(boot_vfs) %vfsroot%
5008set ::SRCDIR $::odie(boot_vfs)
5009if {[file exists [file join %vfsroot% tcl_library init.tcl]]} {
5010  set ::tcl_library [file join %vfsroot% tcl_library]
5011  set ::auto_path {}
5012}
5013if {[file exists [file join %vfsroot% tk_library tk.tcl]]} {
5014  set ::tk_library [file join %vfsroot% tk_library]
5015}
5016} ; # Preinitscript
5017
5018    set zvfsboot {
5019/*
5020 * %mainhook% --
5021 * Performs the argument munging for the shell
5022 */
5023  }
5024    ::practcl::cputs zvfsboot {
5025  CONST char *archive;
5026  Tcl_FindExecutable(*argv[0]);
5027  archive=Tcl_GetNameOfExecutable();
5028}
5029    # We have to initialize the virtual filesystem before calling
5030    # Tcl_Init().  Otherwise, Tcl_Init() will not be able to find
5031    # its startup script files.
5032    if {![$PROJECT define get tip_430 0]} {
5033      # Add declarations of functions that tip430 puts in the stub files
5034      $PROJECT code public-header {
5035int TclZipfs_Init(Tcl_Interp *interp);
5036int TclZipfs_Mount(
5037    Tcl_Interp *interp,
5038    const char *mntpt,
5039    const char *zipname,
5040    const char *passwd
5041);
5042int TclZipfs_Mount_Buffer(
5043    Tcl_Interp *interp,
5044    const char *mntpt,
5045    unsigned char *data,
5046    size_t datalen,
5047    int copy
5048);
5049}
5050      ::practcl::cputs zvfsboot {  TclZipfs_Init(NULL);}
5051    }
5052    ::practcl::cputs zvfsboot "  if(!TclZipfs_Mount(NULL, \"app\", archive, NULL)) \x7B "
5053    ::practcl::cputs zvfsboot {
5054      Tcl_Obj *vfsinitscript;
5055      vfsinitscript=Tcl_NewStringObj("%vfs_main%",-1);
5056      Tcl_IncrRefCount(vfsinitscript);
5057      if(Tcl_FSAccess(vfsinitscript,F_OK)==0) {
5058        /* Startup script should be set before calling Tcl_AppInit */
5059        Tcl_SetStartupScript(vfsinitscript,NULL);
5060      }
5061    }
5062    ::practcl::cputs zvfsboot "    TclSetPreInitScript([::practcl::tcl_to_c $preinitscript])\;"
5063    ::practcl::cputs zvfsboot "  \x7D else \x7B"
5064    ::practcl::cputs zvfsboot "    TclSetPreInitScript([::practcl::tcl_to_c {
5065foreach path {../tcl} {
5066  set p  [file join $path library init.tcl]
5067  if {[file exists [file join $path library init.tcl]]} {
5068    set ::tcl_library [file normalize [file join $path library]]
5069    break
5070  }
5071}
5072foreach path {
5073  ../tk
5074} {
5075  if {[file exists [file join $path library tk.tcl]]} {
5076    set ::tk_library [file normalize [file join $path library]]
5077    break
5078  }
5079}
5080}])\;"
5081    ::practcl::cputs zvfsboot "  \x7D"
5082    ::practcl::cputs zvfsboot "  return TCL_OK;"
5083
5084    if {[$PROJECT define get TEACUP_OS] eq "windows"} {
5085      set header {int %mainhook%(int *argc, TCHAR ***argv)}
5086    } else {
5087      set header {int %mainhook%(int *argc, char ***argv)}
5088    }
5089    $PROJECT c_function  [string map $map $header] [string map $map $zvfsboot]
5090
5091    practcl::cputs appinit "int %mainfunc%(Tcl_Interp *interp) \x7B"
5092
5093  # Build AppInit()
5094  set appinit {}
5095  practcl::cputs appinit {
5096  if ((Tcl_Init)(interp) == TCL_ERROR) {
5097      return TCL_ERROR;
5098  }
5099
5100}
5101    if {![$PROJECT define get tip_430 0]} {
5102      ::practcl::cputs appinit {  TclZipfs_Init(interp);}
5103    }
5104    set main_init_script {}
5105
5106    foreach {statpkg info} $statpkglist {
5107      set initfunc {}
5108      if {[dict exists $info initfunc]} {
5109        set initfunc [dict get $info initfunc]
5110      }
5111      if {$initfunc eq {}} {
5112        set initfunc [string totitle ${statpkg}]_Init
5113      }
5114      if {![dict exists $info version]} {
5115        error "$statpkg HAS NO VERSION"
5116      }
5117      # We employ a NULL to prevent the package system from thinking the
5118      # package is actually loaded into the interpreter
5119      $PROJECT code header "extern Tcl_PackageInitProc $initfunc\;\n"
5120      set script [list package ifneeded $statpkg [dict get $info version] [list ::load {} $statpkg]]
5121      append main_init_script \n [list set ::kitpkg(${statpkg}) $script]
5122      if {[dict get $info autoload]} {
5123        ::practcl::cputs appinit "  if(${initfunc}(interp)) return TCL_ERROR\;"
5124        ::practcl::cputs appinit "  Tcl_StaticPackage(interp,\"$statpkg\",$initfunc,NULL)\;"
5125      } else {
5126        ::practcl::cputs appinit "\n  Tcl_StaticPackage(NULL,\"$statpkg\",$initfunc,NULL)\;"
5127        append main_init_script \n $script
5128      }
5129    }
5130    append main_init_script \n {
5131if {[file exists [file join $::SRCDIR packages.tcl]]} {
5132  #In a wrapped exe, we don't go out to the environment
5133  set dir $::SRCDIR
5134  source [file join $::SRCDIR packages.tcl]
5135}
5136# Specify a user-specific startup file to invoke if the application
5137# is run interactively.  Typically the startup file is "~/.apprc"
5138# where "app" is the name of the application.  If this line is deleted
5139# then no user-specific startup file will be run under any conditions.
5140}
5141    append main_init_script \n [list set tcl_rcFileName [$PROJECT define get tcl_rcFileName ~/.tclshrc]]
5142    practcl::cputs appinit "  Tcl_Eval(interp,[::practcl::tcl_to_c  $main_init_script]);"
5143    practcl::cputs appinit {  return TCL_OK;}
5144    $PROJECT c_function [string map $map "int %mainfunc%(Tcl_Interp *interp)"] [string map $map $appinit]
5145  }
5146
5147  method Collate_Source CWD {
5148    next $CWD
5149    set name [my define get name]
5150    # Assume a static shell
5151    if {[my define exists SHARED_BUILD]} {
5152      my define set SHARED_BUILD 0
5153    }
5154    if {![my define exists TCL_LOCAL_APPINIT]} {
5155      my define set TCL_LOCAL_APPINIT Tclkit_AppInit
5156    }
5157    if {![my define exists TCL_LOCAL_MAIN_HOOK]} {
5158      my define set TCL_LOCAL_MAIN_HOOK Tclkit_MainHook
5159    }
5160    set PROJECT [self]
5161    set os [$PROJECT define get TEACUP_OS]
5162    if {[my define get SHARED_BUILD]} {
5163      puts [list BUILDING TCLSH FOR OS $os]
5164    } else {
5165      puts [list BUILDING KIT FOR OS $os]
5166    }
5167    set TCLOBJ [$PROJECT tclcore]
5168    ::practcl::toolset select $TCLOBJ
5169
5170    set TCLSRCDIR [$TCLOBJ define get srcdir]
5171    set PKG_OBJS {}
5172    foreach item [$PROJECT link list core.library] {
5173      if {[string is true [$item define get static]]} {
5174        lappend PKG_OBJS $item
5175      }
5176    }
5177    foreach item [$PROJECT link list package] {
5178      if {[string is true [$item define get static]]} {
5179        lappend PKG_OBJS $item
5180      }
5181    }
5182    # Arrange to build an main.c that utilizes TCL_LOCAL_APPINIT and TCL_LOCAL_MAIN_HOOK
5183    if {$os eq "windows"} {
5184      set PLATFORM_SRC_DIR win
5185      if {[my define get SHARED_BUILD]} {
5186        my add class csource filename [file join $TCLSRCDIR win tclWinReg.c] initfunc Registry_Init pkg_name registry pkg_vers 1.3.1 autoload 1
5187        my add class csource filename [file join $TCLSRCDIR win tclWinDde.c] initfunc Dde_Init pkg_name dde pkg_vers 1.4.0 autoload 1
5188      }
5189      my add class csource ofile [my define get name]_appinit.o filename [file join $TCLSRCDIR win tclAppInit.c] extra [list -DTCL_LOCAL_MAIN_HOOK=[my define get TCL_LOCAL_MAIN_HOOK Tclkit_MainHook] -DTCL_LOCAL_APPINIT=[my define get TCL_LOCAL_APPINIT Tclkit_AppInit]]
5190    } else {
5191      set PLATFORM_SRC_DIR unix
5192      my add class csource ofile [my define get name]_appinit.o filename [file join $TCLSRCDIR unix tclAppInit.c] extra [list -DTCL_LOCAL_MAIN_HOOK=[my define get TCL_LOCAL_MAIN_HOOK Tclkit_MainHook] -DTCL_LOCAL_APPINIT=[my define get TCL_LOCAL_APPINIT Tclkit_AppInit]]
5193    }
5194
5195    if {[my define get SHARED_BUILD]} {
5196      ###
5197      # Add local static Zlib implementation
5198      ###
5199      set cdir [file join $TCLSRCDIR compat zlib]
5200      foreach file {
5201        adler32.c compress.c crc32.c
5202        deflate.c infback.c inffast.c
5203        inflate.c inftrees.c trees.c
5204        uncompr.c zutil.c
5205      } {
5206        my add [file join $cdir $file]
5207      }
5208    }
5209    ###
5210    # Pre 8.7, Tcl doesn't include a Zipfs implementation
5211    # in the core. Grab the one from odielib
5212    ###
5213    set zipfs [file join $TCLSRCDIR generic tclZipfs.c]
5214    if {![$PROJECT define exists ZIPFS_VOLUME]} {
5215      $PROJECT define set ZIPFS_VOLUME "zipfs:/"
5216    }
5217    $PROJECT code header "#define ZIPFS_VOLUME \"[$PROJECT define get ZIPFS_VOLUME]\""
5218    if {[file exists $zipfs]} {
5219      $TCLOBJ define set tip_430 1
5220      my define set tip_430 1
5221    } else {
5222      # The Tclconfig project maintains a mirror of the version
5223      # released with the Tcl core
5224      my define set tip_430 0
5225      ::practcl::LOCAL tool tclconfig unpack
5226      set COMPATSRCROOT [::practcl::LOCAL tool tclconfig define get srcdir]
5227      my add class csource ofile tclZipfs.o filename [file join $COMPATSRCROOT compat tclZipfs.c] extra -I[::practcl::file_relative $CWD [file join $TCLSRCDIR compat zlib contrib minizip]]
5228    }
5229
5230    my define add include_dir [file join $TCLSRCDIR generic]
5231    my define add include_dir [file join $TCLSRCDIR $PLATFORM_SRC_DIR]
5232    # This file will implement TCL_LOCAL_APPINIT and TCL_LOCAL_MAIN_HOOK
5233    my build-tclkit_main $PROJECT $PKG_OBJS
5234  }
5235
5236  ## Wrap an executable
5237  #
5238  method wrap {PWD exename vfspath args} {
5239    cd $PWD
5240    if {![file exists $vfspath]} {
5241      file mkdir $vfspath
5242    }
5243    foreach item [my link list core.library] {
5244      set name  [$item define get name]
5245      set libsrcdir [$item define get srcdir]
5246      if {[file exists [file join $libsrcdir library]]} {
5247        ::practcl::copyDir [file join $libsrcdir library] [file join $vfspath ${name}_library]
5248      }
5249    }
5250    # Assume the user will populate the VFS path
5251    #if {[my define get installdir] ne {}} {
5252    #  ::practcl::copyDir [file join [my define get installdir] [string trimleft [my define get prefix] /] lib] [file join $vfspath lib]
5253    #}
5254    foreach arg $args {
5255       ::practcl::copyDir $arg $vfspath
5256    }
5257
5258    set fout [open [file join $vfspath packages.tcl] w]
5259    puts $fout [string map [list %platform% [my define get TEACUP_PROFILE]] {set ::tcl_teapot_profile {%platform%}}]
5260    puts $fout {
5261set ::PKGIDXFILE [info script]
5262set dir [file dirname $::PKGIDXFILE]
5263if {$::tcl_platform(platform) eq "windows"} {
5264  set ::g(HOME) [file join [file normalize $::env(LOCALAPPDATA)] tcl]
5265} else {
5266  set ::g(HOME) [file normalize ~/tcl]
5267}
5268set ::tcl_teapot [file join $::g(HOME) teapot $::tcl_teapot_profile]
5269lappend ::auto_path $::tcl_teapot
5270}
5271    puts $fout [list proc installDir [info args ::practcl::installDir] [info body ::practcl::installDir]]
5272    set buffer [::practcl::pkgindex_path $vfspath]
5273    puts $fout $buffer
5274    puts $fout {
5275# Advertise statically linked packages
5276foreach {pkg script} [array get ::kitpkg] {
5277  eval $script
5278}
5279}
5280    puts $fout {
5281###
5282# Cache binary packages distributed as dynamic libraries in a known location
5283###
5284foreach teapath [glob -nocomplain [file join $dir teapot $::tcl_teapot_profile *]] {
5285  set pkg [file tail $teapath]
5286  set pkginstall [file join $::tcl_teapot $pkg]
5287  if {![file exists $pkginstall]} {
5288    installDir $teapath $pkginstall
5289  }
5290}
5291}
5292    close $fout
5293
5294    set EXEEXT [my define get EXEEXT]
5295    set tclkit_bare [my define get tclkit_bare]
5296    ::practcl::mkzip ${exename}${EXEEXT} $tclkit_bare $vfspath
5297    if { [my define get TEACUP_OS] ne "windows" } {
5298      file attributes ${exename}${EXEEXT} -permissions a+x
5299    }
5300  }
5301}
5302
5303###
5304# END: class project tclkit.tcl
5305###
5306###
5307# START: class distro baseclass.tcl
5308###
5309
5310###
5311# Standalone class to manage code distribution
5312# This class is intended to be mixed into another class
5313# (Thus the lack of ancestors)
5314###
5315oo::class create ::practcl::distribution {
5316
5317  method scm_info {} {
5318    return {
5319      scm  None
5320      hash {}
5321      maxdate {}
5322      tags {}
5323      isodate {}
5324    }
5325  }
5326
5327  method DistroMixIn {} {
5328    my define set scm none
5329  }
5330
5331  method Sandbox {} {
5332    if {[my define exists sandbox]} {
5333      return [my define get sandbox]
5334    }
5335    if {[my organ project] ni {::noop {}}} {
5336      set sandbox [my <project> define get sandbox]
5337      if {$sandbox ne {}} {
5338        my define set sandbox $sandbox
5339        return $sandbox
5340      }
5341    }
5342    set sandbox [file normalize [file join $::CWD ..]]
5343    my define set sandbox $sandbox
5344    return $sandbox
5345  }
5346
5347  method SrcDir {} {
5348    set pkg [my define get name]
5349    if {[my define exists srcdir]} {
5350      return [my define get srcdir]
5351    }
5352    set sandbox [my Sandbox]
5353    set srcdir [file join [my Sandbox] $pkg]
5354    my define set srcdir $srcdir
5355    return $srcdir
5356  }
5357
5358  method ScmTag    {} {}
5359  method ScmClone  {} {}
5360  method ScmUnpack {} {}
5361  method ScmUpdate {} {}
5362
5363  method Unpack {} {
5364    set srcdir [my SrcDir]
5365    if {[file exists $srcdir]} {
5366      return
5367    }
5368    set pkg [my define get name]
5369    if {[my define exists download]} {
5370      # Utilize a staged download
5371      set download [my define get download]
5372      if {[file exists [file join $download $pkg.zip]]} {
5373        ::practcl::tcllib_require zipfile::decode
5374        ::zipfile::decode::unzipfile [file join $download $pkg.zip] $srcdir
5375        return
5376      }
5377    }
5378    my ScmUnpack
5379  }
5380}
5381
5382oo::objdefine ::practcl::distribution {
5383
5384  method Sandbox {object} {
5385    if {[$object define exists sandbox]} {
5386      return [$object define get sandbox]
5387    }
5388    if {[$object organ project] ni {::noop {}}} {
5389      set sandbox [$object <project> define get sandbox]
5390      if {$sandbox ne {}} {
5391        $object define set sandbox $sandbox
5392        return $sandbox
5393      }
5394    }
5395    set pkg [$object define get name]
5396    set sandbox [file normalize [file join $::CWD ..]]
5397    $object define set sandbox $sandbox
5398    return $sandbox
5399  }
5400
5401  method select object {
5402    if {[$object define exists scm]} {
5403      return [$object define get scm]
5404    }
5405
5406    set pkg [$object define get name]
5407    if {[$object define get srcdir] ne {}} {
5408      set srcdir [$object define get srcdir]
5409    } else {
5410      set srcdir [file join [my Sandbox $object] $pkg]
5411      $object define set srcdir $srcdir
5412    }
5413
5414    set classprefix ::practcl::distribution.
5415    if {[file exists $srcdir]} {
5416      foreach class [::info commands ${classprefix}*] {
5417        if {[$class claim_path $srcdir]} {
5418          $object mixin distribution $class
5419          $object define set scm [string range $class [string length ::practcl::distribution.] end]
5420          return [$object define get scm]
5421        }
5422      }
5423    }
5424    foreach class [::info commands ${classprefix}*] {
5425      if {[$class claim_object $object]} {
5426        $object mixin distribution $class
5427        $object define set scm [string range $class [string length ::practcl::distribution.] end]
5428        return [$object define get scm]
5429      }
5430    }
5431    if {[$object define get scm] eq {} && [$object define exists file_url]} {
5432      set class ::practcl::distribution.snapshot
5433      $object define set scm snapshot
5434      $object mixin distribution $class
5435      return [$object define get scm]
5436    }
5437    error "Cannot determine source distribution method"
5438  }
5439
5440  method claim_path path {
5441    return false
5442  }
5443  method claim_object object {
5444    return false
5445  }
5446}
5447
5448###
5449# END: class distro baseclass.tcl
5450###
5451###
5452# START: class distro snapshot.tcl
5453###
5454
5455oo::class create ::practcl::distribution.snapshot {
5456  superclass ::practcl::distribution
5457
5458  method ScmUnpack {} {
5459    set srcdir [my SrcDir]
5460    if {[file exists [file join $srcdir .download]]} {
5461      return 0
5462    }
5463    set dpath [::practcl::LOCAL define get download]
5464    set url [my define get file_url]
5465    set fname [file tail $url]
5466    set archive [file join $dpath $fname]
5467    if {![file exists $archive]} {
5468      ::http::wget $url $archive
5469    }
5470    set CWD [pwd]
5471    switch [file extension $fname] {
5472      .zip {
5473        # Zipfile
5474
5475      }
5476      .tar {
5477        ::practcl::tcllib_require tar
5478      }
5479      .tgz -
5480      .gz {
5481        # Tarball
5482        ::practcl::tcllib_require tcl::transform::zlib
5483        ::practcl::tcllib_require tar
5484        set fh [::open $archive]
5485        fconfigure $fh -encoding binary -translation lf -eofchar {}
5486        ::tcl::transform::zlib $fh
5487      }
5488    }
5489    set fosdb [my ScmClone]
5490    set tag [my ScmTag]
5491    file mkdir $srcdir
5492    ::practcl::fossil $srcdir open $fosdb $tag
5493    return 1
5494  }
5495}
5496
5497oo::objdefine ::practcl::distribution.snapshot {
5498  method claim_path path {
5499    if {[file exists [file join $path .download]]} {
5500      return true
5501    }
5502    return false
5503  }
5504  method claim_object object {
5505    return false
5506  }
5507}
5508
5509###
5510# END: class distro snapshot.tcl
5511###
5512###
5513# START: class distro fossil.tcl
5514###
5515
5516oo::class create ::practcl::distribution.fossil {
5517  superclass ::practcl::distribution
5518
5519  method scm_info {} {
5520    set info [next]
5521    dict set info scm fossil
5522    foreach {field value} [::practcl::fossil_status [my define get srcdir]] {
5523      dict set info $field $value
5524    }
5525    return $info
5526  }
5527
5528  # Clone the source
5529  method ScmClone  {} {
5530    set srcdir [my SrcDir]
5531    if {[file exists [file join $srcdir .fslckout]]} {
5532      return
5533    }
5534    if {[file exists [file join $srcdir _FOSSIL_]]} {
5535      return
5536    }
5537    if {![::info exists ::practcl::fossil_dbs]} {
5538      # Get a list of local fossil databases
5539      set ::practcl::fossil_dbs [exec fossil all list]
5540    }
5541    set pkg [my define get name]
5542    # Return an already downloaded fossil repo
5543    foreach line [split $::practcl::fossil_dbs \n] {
5544      set line [string trim $line]
5545      if {[file rootname [file tail $line]] eq $pkg} {
5546        return $line
5547      }
5548    }
5549    set download [::practcl::LOCAL define get download]
5550    set fosdb [file join $download $pkg.fos]
5551    if {[file exists $fosdb]} {
5552      return $fosdb
5553    }
5554
5555    file mkdir [file join $download fossil]
5556    set fosdb [file join $download fossil $pkg.fos]
5557    if {[file exists $fosdb]} {
5558      return $fosdb
5559    }
5560
5561    set cloned 0
5562    # Attempt to clone from a local network mirror
5563    if {[::practcl::LOCAL define exists fossil_mirror]} {
5564      set localmirror [::practcl::LOCAL define get fossil_mirror]
5565      catch {
5566        ::practcl::doexec fossil clone $localmirror/$pkg $fosdb
5567        set cloned 1
5568      }
5569      if {$cloned} {
5570        return $fosdb
5571      }
5572    }
5573    # Attempt to clone from the canonical source
5574    if {[my define get fossil_url] ne {}} {
5575      catch {
5576        ::practcl::doexec fossil clone [my define get fossil_url] $fosdb
5577        set cloned 1
5578      }
5579      if {$cloned} {
5580        return $fosdb
5581      }
5582    }
5583    # Fall back to the fossil mirror on the island of misfit toys
5584    ::practcl::doexec fossil clone http://fossil.etoyoc.com/fossil/$pkg $fosdb
5585    return $fosdb
5586  }
5587
5588  method ScmTag {} {
5589    if {[my define exists scm_tag]} {
5590      return [my define get scm_tag]
5591    }
5592    if {[my define exists tag]} {
5593      set tag [my define get tag]
5594    } else {
5595      set tag trunk
5596    }
5597    my define set scm_tag $tag
5598    return $tag
5599  }
5600
5601  method ScmUnpack {} {
5602    set srcdir [my SrcDir]
5603    if {[file exists [file join $srcdir .fslckout]]} {
5604      return 0
5605    }
5606    if {[file exists [file join $srcdir _FOSSIL_]]} {
5607      return 0
5608    }
5609    set CWD [pwd]
5610    set fosdb [my ScmClone]
5611    set tag [my ScmTag]
5612    file mkdir $srcdir
5613    ::practcl::fossil $srcdir open $fosdb $tag
5614    return 1
5615  }
5616
5617  method ScmUpdate {} {
5618    if {[my ScmUnpack]} {
5619      return
5620    }
5621    set srcdir [my SrcDir]
5622    set tag [my ScmTag]
5623    ::practcl::fossil $srcdir update $tag
5624  }
5625}
5626
5627oo::objdefine ::practcl::distribution.fossil {
5628
5629  # Check for markers in the source root
5630  method claim_path path {
5631    if {[file exists [file join $path .fslckout]]} {
5632      return true
5633    }
5634    if {[file exists [file join $path _FOSSIL_]]} {
5635      return true
5636    }
5637    return false
5638  }
5639
5640  # Check for markers in the metadata
5641  method claim_object obj {
5642    set path [$obj define get srcdir]
5643    if {[my claim_path $path]} {
5644      return true
5645    }
5646    if {[$obj define get fossil_url] ne {}} {
5647      return true
5648    }
5649    return false
5650  }
5651}
5652
5653###
5654# END: class distro fossil.tcl
5655###
5656###
5657# START: class distro git.tcl
5658###
5659
5660
5661oo::class create ::practcl::distribution.git {
5662  superclass ::practcl::distribution
5663
5664  method ScmTag {} {
5665    if {[my define exists scm_tag]} {
5666      return [my define get scm_tag]
5667    }
5668    if {[my define exists tag]} {
5669      set tag [my define get tag]
5670    } else {
5671      set tag master
5672    }
5673    my define set scm_tag $tag
5674    return $tag
5675  }
5676
5677  method ScmUnpack {} {
5678    set srcdir [my SrcDir]
5679    if {[file exists [file join $srcdir .git]]} {
5680      return 0
5681    }
5682    set CWD [pwd]
5683    set tag [my ScmTag]
5684    set pkg [my define get name]
5685    if {[my define exists git_url]} {
5686      ::practcl::doexec git clone --branch $tag [my define get git_url] $srcdir
5687    } else {
5688      ::practcl::doexec git clone --branch $tag https://github.com/eviltwinskippy/$pkg $srcdir
5689    }
5690    return 1
5691  }
5692
5693  method ScmUpdate {} {
5694    if {[my ScmUnpack]} {
5695      return
5696    }
5697    set CWD [pwd]
5698    set srcdir [my SrcDir]
5699    set tag [my ScmTag]
5700    ::practcl::doexec_in $srcdir git pull
5701    cd $CWD
5702  }
5703
5704}
5705oo::objdefine ::practcl::distribution.git {
5706  method claim_path path {
5707   if {[file exists [file join $path .git]]} {
5708      return true
5709    }
5710    return false
5711  }
5712  method claim_object obj {
5713    set path [$obj define get srcdir]
5714    if {[my claim_path $path]} {
5715      return true
5716    }
5717    if {[$obj define get git_url] ne {}} {
5718      return true
5719    }
5720    return false
5721  }
5722}
5723
5724###
5725# END: class distro git.tcl
5726###
5727###
5728# START: class subproject baseclass.tcl
5729###
5730oo::class create ::practcl::subproject {
5731  superclass ::practcl::module
5732
5733  method _MorphPatterns {} {
5734    return {{::practcl::subproject.@name@} {::practcl::@name@} {@name@} {::practcl::subproject}}
5735  }
5736
5737
5738  method BuildDir {PWD} {
5739    return [my define get srcdir]
5740  }
5741
5742  method child which {
5743    switch $which {
5744      organs {
5745	# A library can be a project, it can be a module. Any
5746	# subordinate modules will indicate their existance
5747        return [list project [self] module [self]]
5748      }
5749    }
5750  }
5751
5752  method compile {} {}
5753
5754
5755  method go {} {
5756    ::practcl::distribution select [self]
5757    set name [my define get name]
5758    my define set builddir [my BuildDir [my define get masterpath]]
5759    my define set builddir [my BuildDir [my define get masterpath]]
5760    my sources
5761  }
5762
5763  # Install project into the local build system
5764  method install args {}
5765
5766  method linktype {} {
5767    return {subordinate package}
5768  }
5769
5770  method linker-products {configdict} {}
5771
5772  method linker-external {configdict} {
5773    if {[dict exists $configdict PRACTCL_PKG_LIBS]} {
5774      return [dict get $configdict PRACTCL_PKG_LIBS]
5775    }
5776    if {[dict exists $configdict LIBS]} {
5777      return [dict get $configdict LIBS]
5778    }
5779  }
5780
5781  method linker-extra {configdict} {
5782    if {[dict exists $configdict PRACTCL_LINKER_EXTRA]} {
5783      return [dict get $configdict PRACTCL_LINKER_EXTRA]
5784    }
5785    return {}
5786  }
5787
5788  ###
5789  # Methods for packages/tools that can be downloaded
5790  # possibly built and used internally by this Practcl
5791  # process
5792  ###
5793
5794  ###
5795  # Load the facility into the interpreter
5796  ###
5797  method env-bootstrap {} {
5798    set pkg [my define get pkg_name [my define get name]]
5799    package require $pkg
5800  }
5801
5802  ###
5803  # Return a file path that exec can call
5804  ###
5805  method env-exec {} {}
5806
5807  ###
5808  # Install the tool into the local environment
5809  ###
5810  method env-install {} {
5811    my unpack
5812  }
5813
5814  ###
5815  # Do whatever is necessary to get the tool
5816  # into the local environment
5817  ###
5818  method env-load {} {
5819    my variable loaded
5820    if {[info exists loaded]} {
5821      return 0
5822    }
5823    if {![my env-present]} {
5824      my env-install
5825    }
5826    my env-bootstrap
5827    set loaded 1
5828  }
5829
5830  ###
5831  # Check if tool is available for load/already loaded
5832  ###
5833  method env-present {} {
5834    set pkg [my define get pkg_name [my define get name]]
5835    if {[catch [list package require $pkg]]} {
5836      return 0
5837    }
5838    return 1
5839  }
5840
5841  method sources {} {}
5842
5843  method update {} {
5844    my ScmUpdate
5845  }
5846
5847  method unpack {} {
5848    ::practcl::distribution select [self]
5849    my Unpack
5850    ::practcl::toolset select [self]
5851  }
5852}
5853
5854###
5855# Trivial implementations
5856###
5857
5858
5859###
5860# A project which the kit compiles and integrates
5861# the source for itself
5862###
5863oo::class create ::practcl::subproject.source {
5864  superclass ::practcl::subproject ::practcl::library
5865
5866  method env-bootstrap {} {
5867    set LibraryRoot [file join [my define get srcdir] [my define get module_root modules]]
5868    if {[file exists $LibraryRoot] && $LibraryRoot ni $::auto_path} {
5869      set ::auto_path [linsert $::auto_path 0 $LibraryRoot]
5870    }
5871  }
5872
5873  method env-present {} {
5874    set path [my define get srcdir]
5875    return [file exists $path]
5876  }
5877
5878  method linktype {} {
5879    return {subordinate package source}
5880  }
5881
5882}
5883
5884# a copy from the teapot
5885oo::class create ::practcl::subproject.teapot {
5886  superclass ::practcl::subproject
5887
5888  method env-bootstrap {} {
5889    set pkg [my define get pkg_name [my define get name]]
5890    package require $pkg
5891  }
5892
5893  method env-install {} {
5894    set pkg [my define get pkg_name [my define get name]]
5895    set download [my <project> define get download]
5896    my unpack
5897    set prefix [string trimleft [my <project> define get prefix] /]
5898    ::practcl::tcllib_require zipfile::decode
5899    ::zipfile::decode::unzipfile [file join $download $pkg.zip] [file join $prefix lib $pkg]
5900  }
5901
5902  method env-present {} {
5903    set pkg [my define get pkg_name [my define get name]]
5904    if {[catch [list package require $pkg]]} {
5905      return 0
5906    }
5907    return 1
5908  }
5909
5910  method install DEST {
5911    set pkg [my define get pkg_name [my define get name]]
5912    set download [my <project> define get download]
5913    my unpack
5914    set prefix [string trimleft [my <project> define get prefix] /]
5915    ::practcl::tcllib_require zipfile::decode
5916    ::zipfile::decode::unzipfile [file join $download $pkg.zip] [file join $DEST $prefix lib $pkg]
5917  }
5918}
5919
5920oo::class create ::practcl::subproject.kettle {
5921  superclass ::practcl::subproject
5922
5923  method kettle {path args} {
5924    my variable kettle
5925    if {![info exists kettle]} {
5926      ::practcl::LOCAL tool kettle env-load
5927      set kettle [file join [::practcl::LOCAL tool kettle define get srcdir] kettle]
5928    }
5929    set srcdir [my SourceRoot]
5930    ::practcl::dotclexec $kettle -f [file join $srcdir build.tcl] {*}$args
5931  }
5932
5933  method install DEST {
5934    my kettle reinstall --prefix $DEST
5935  }
5936}
5937
5938oo::class create ::practcl::subproject.critcl {
5939  superclass ::practcl::subproject
5940
5941  method install DEST {
5942    my critcl -pkg [my define get name]
5943    set srcdir [my SourceRoot]
5944    ::practcl::copyDir [file join $srcdir [my define get name]] [file join $DEST lib [my define get name]]
5945  }
5946}
5947
5948
5949oo::class create ::practcl::subproject.sak {
5950  superclass ::practcl::subproject
5951
5952  method env-bootstrap {} {
5953    set LibraryRoot [file join [my define get srcdir] [my define get module_root modules]]
5954    if {[file exists $LibraryRoot] && $LibraryRoot ni $::auto_path} {
5955      set ::auto_path [linsert $::auto_path 0 $LibraryRoot]
5956    }
5957  }
5958
5959  method env-install {} {
5960    ###
5961    # Handle teapot installs
5962    ###
5963    set pkg [my define get pkg_name [my define get name]]
5964    my unpack
5965    set prefix [my <project> define get prefix [file normalize [file join ~ tcl]]]
5966    set srcdir [my define get srcdir]
5967    ::practcl::dotclexec [file join $srcdir installer.tcl] \
5968      -apps -app-path [file join $prefix apps] \
5969      -html -html-path [file join $prefix doc html $pkg] \
5970      -pkg-path [file join $prefix lib $pkg]  \
5971      -no-nroff -no-wait -no-gui
5972  }
5973
5974  method env-present {} {
5975    set path [my define get srcdir]
5976    return [file exists $path]
5977  }
5978
5979  method install DEST {
5980    ###
5981    # Handle teapot installs
5982    ###
5983    set pkg [my define get pkg_name [my define get name]]
5984    my unpack
5985    set prefix [string trimleft [my <project> define get prefix] /]
5986    set srcdir [my define get srcdir]
5987    ::practcl::dotclexec [file join $srcdir installer.tcl] \
5988      -pkg-path [file join $DEST $prefix lib $pkg]  \
5989      -no-examples -no-html -no-nroff \
5990      -no-wait -no-gui -no-apps
5991  }
5992}
5993
5994###
5995# END: class subproject baseclass.tcl
5996###
5997###
5998# START: class subproject binary.tcl
5999###
6000
6001###
6002# A binary package
6003###
6004oo::class create ::practcl::subproject.binary {
6005  superclass ::practcl::subproject
6006
6007  method clean {} {
6008    set builddir [file normalize [my define get builddir]]
6009    if {![file exists $builddir]} return
6010    if {[file exists [file join $builddir make.tcl]]} {
6011      ::practcl::domake.tcl $builddir clean
6012    } else {
6013      catch {::practcl::domake $builddir clean}
6014    }
6015  }
6016
6017 method env-install {} {
6018    ###
6019    # Handle tea installs
6020    ###
6021    set pkg [my define get pkg_name [my define get name]]
6022    set os [::practcl::local_os]
6023    my define set os $os
6024    my unpack
6025    set prefix [my <project> define get prefix [file normalize [file join ~ tcl]]]
6026    set srcdir [my define get srcdir]
6027    lappend options --prefix $prefix --exec-prefix $prefix
6028    my define set config_opts $options
6029    my go
6030    my clean
6031    my compile
6032    my make-install {}
6033  }
6034
6035  method project-compile-products {} {}
6036
6037  method ComputeInstall {} {
6038    if {[my define exists install]} {
6039      switch [my define get install] {
6040        static {
6041          my define set static 1
6042          my define set autoload 0
6043        }
6044        static-autoload {
6045          my define set static 1
6046          my define set autoload 1
6047        }
6048        vfs {
6049          my define set static 0
6050          my define set autoload 0
6051          my define set vfsinstall 1
6052        }
6053        null {
6054          my define set static 0
6055          my define set autoload 0
6056          my define set vfsinstall 0
6057        }
6058        default {
6059
6060        }
6061      }
6062    }
6063  }
6064
6065  method go {} {
6066    next
6067    ::practcl::distribution select [self]
6068    my ComputeInstall
6069    my define set builddir [my BuildDir [my define get masterpath]]
6070  }
6071
6072  method linker-products {configdict} {
6073    if {![my define get static 0]} {
6074      return {}
6075    }
6076    set srcdir [my define get builddir]
6077    if {[dict exists $configdict libfile]} {
6078      return " [file join $srcdir [dict get $configdict libfile]]"
6079    }
6080  }
6081
6082  method project-static-packages {} {
6083    if {![my define get static 0]} {
6084      return {}
6085    }
6086    set result [my define get static_packages]
6087    set statpkg  [my define get static_pkg]
6088    set initfunc [my define get initfunc]
6089    if {$initfunc ne {}} {
6090      set pkg_name [my define get pkg_name]
6091      if {$pkg_name ne {}} {
6092        dict set result $pkg_name initfunc $initfunc
6093        set version [my define get version]
6094        if {$version eq {}} {
6095          my unpack
6096          set info [my read_configuration]
6097          set version [dict get $info version]
6098          set pl {}
6099          if {[dict exists $info patch_level]} {
6100            set pl [dict get $info patch_level]
6101            append version $pl
6102          }
6103          my define set version $version
6104        }
6105        dict set result $pkg_name version $version
6106        dict set result $pkg_name autoload [my define get autoload 0]
6107      }
6108    }
6109    foreach item [my link list subordinate] {
6110      foreach {pkg info} [$item project-static-packages] {
6111        dict set result $pkg $info
6112      }
6113    }
6114    return $result
6115  }
6116
6117  method BuildDir {PWD} {
6118    set name [my define get name]
6119    set debug [my define get debug 0]
6120    if {[my <project> define get LOCAL 0]} {
6121      return [my define get builddir [file join $PWD local $name]]
6122    }
6123    if {$debug} {
6124      return [my define get builddir [file join $PWD debug $name]]
6125    } else {
6126      return [my define get builddir [file join $PWD pkg $name]]
6127    }
6128  }
6129
6130  method compile {} {
6131    set name [my define get name]
6132    set PWD $::CWD
6133    cd $PWD
6134    my unpack
6135    set srcdir [file normalize [my SrcDir]]
6136    set localsrcdir [my MakeDir $srcdir]
6137    my define set localsrcdir $localsrcdir
6138    my Collate_Source $PWD
6139    ###
6140    # Build a starter VFS for both Tcl and wish
6141    ###
6142    set srcdir [my define get srcdir]
6143    if {[my define get static 1]} {
6144      puts "BUILDING Static $name $srcdir"
6145    } else {
6146      puts "BUILDING Dynamic $name $srcdir"
6147    }
6148    my make-compile
6149    cd $PWD
6150  }
6151
6152  method Configure {} {
6153    cd $::CWD
6154    my unpack
6155    ::practcl::toolset select [self]
6156    set srcdir [file normalize [my define get srcdir]]
6157    set builddir [file normalize [my define get builddir]]
6158    file mkdir $builddir
6159    my make-autodetect
6160  }
6161
6162  method install DEST {
6163    set PWD [pwd]
6164    set PREFIX  [my <project> define get prefix]
6165    ###
6166    # Handle teapot installs
6167    ###
6168    set pkg [my define get pkg_name [my define get name]]
6169    if {[my <project> define get teapot] ne {}} {
6170      set TEAPOT [my <project> define get teapot]
6171      set found 0
6172      foreach ver [my define get pkg_vers [my define get version]] {
6173        set teapath [file join $TEAPOT $pkg$ver]
6174        if {[file exists $teapath]} {
6175          set dest  [file join $DEST [string trimleft $PREFIX /] lib [file tail $teapath]]
6176          ::practcl::copyDir $teapath $dest
6177          return
6178        }
6179      }
6180    }
6181    my compile
6182    my make-install $DEST
6183    cd $PWD
6184  }
6185}
6186
6187oo::class create ::practcl::subproject.tea {
6188  superclass ::practcl::subproject.binary
6189
6190}
6191
6192oo::class create ::practcl::subproject.library {
6193  superclass ::practcl::subproject.binary ::practcl::library
6194  method install DEST {
6195    my compile
6196  }
6197}
6198
6199# An external library
6200oo::class create ::practcl::subproject.external {
6201  superclass ::practcl::subproject.binary
6202  method install DEST {
6203    my compile
6204  }
6205}
6206
6207###
6208# END: class subproject binary.tcl
6209###
6210###
6211# START: class subproject core.tcl
6212###
6213
6214oo::class create ::practcl::subproject.core {
6215  superclass ::practcl::subproject.binary
6216
6217  method env-bootstrap {} {}
6218
6219  method env-present {} {
6220    set PREFIX [my <project> define get prefix]
6221    set name [my define get name]
6222    set fname [file join $PREFIX lib ${name}Config.sh]
6223    return [file exists $fname]
6224  }
6225
6226  method env-install {} {
6227    my unpack
6228    set os [::practcl::local_os]
6229
6230    set prefix [my <project> define get prefix [file normalize [file join ~ tcl]]]
6231    lappend options --prefix $prefix --exec-prefix $prefix
6232    my define set config_opts $options
6233    puts [list [self] OS [dict get $os TEACUP_OS] options $options]
6234    my go
6235    my compile
6236    my make-install {}
6237  }
6238
6239  method go {} {
6240    my define set core_binary 1
6241    next
6242  }
6243
6244  method linktype {} {
6245    return {subordinate core.library}
6246  }
6247}
6248
6249###
6250# END: class subproject core.tcl
6251###
6252###
6253# START: class tool.tcl
6254###
6255###
6256# Create an object to represent the local environment
6257###
6258set ::practcl::MAIN ::practcl::LOCAL
6259# Defer the creation of the ::practcl::LOCAL object until it is called
6260# in order to allow packages to
6261set ::auto_index(::practcl::LOCAL) {
6262  ::practcl::project create ::practcl::LOCAL
6263  ::practcl::LOCAL define set [::practcl::local_os]
6264  ::practcl::LOCAL define set LOCAL 1
6265
6266  # Until something better comes along, use ::practcl::LOCAL
6267  # as our main project
6268  # Add tclconfig as a project of record
6269  ::practcl::LOCAL add_tool tclconfig {
6270    name tclconfig tag practcl class subproject.source fossil_url http://core.tcl.tk/tclconfig
6271  }
6272  # Add tcllib as a project of record
6273  ::practcl::LOCAL add_tool tcllib {
6274    tag trunk class sak fossil_url http://core.tcl.tk/tcllib
6275  }
6276  ::practcl::LOCAL add_tool kettle {
6277    tag trunk class sak fossil_url http://fossil.etoyoc.com/fossil/kettle
6278  }
6279  ::practcl::LOCAL add_tool tclvfs {
6280    tag trunk class tea
6281    fossil_url http://fossil.etoyoc.com/fossil/tclvfs
6282  }
6283  ::practcl::LOCAL add_tool critcl {
6284    tag master class subproject.binary
6285    git_url http://github.com/andreas-kupries/critcl
6286    modules lib
6287  } {
6288    method env-bootstrap {} {
6289      package require critcl::app
6290    }
6291    method env-install {} {
6292      my unpack
6293      set prefix [my <project> define get prefix [file join [file normalize ~] tcl]]
6294      set srcdir [my define get srcdir]
6295      ::practcl::dotclexec [file join $srcdir build.tcl] install [file join $prefix lib]
6296    }
6297  }
6298  ::practcl::LOCAL add_tool odie {
6299    tag trunk class subproject.source
6300    fossil_url http://fossil.etoyoc.com/fossil/odie
6301  }
6302  ::practcl::LOCAL add_tool tcl {
6303    tag release class subproject.core
6304    fossil_url http://core.tcl.tk/tcl
6305  }
6306  ::practcl::LOCAL add_tool tk {
6307    tag release class subproject.core
6308    fossil_url http://core.tcl.tk/tcl
6309  }
6310  ::practcl::LOCAL add_tool sqlite {
6311    tag practcl
6312    class subproject.tea
6313    pkg_name sqlite3
6314    fossil_url http://fossil.etoyoc.com/fossil/sqlite
6315  }
6316}
6317
6318###
6319# END: class tool.tcl
6320###
6321
6322namespace eval ::practcl {
6323  namespace export *
6324}
6325
6326