Posted to tcl by stevel at Sun Jan 13 04:33:15 GMT 2008view raw

  1. #
  2. # Critcl - build C extensions on-the-fly
  3. #
  4. # Copyright (c) 2001-2007 Jean-Claude Wippler
  5. # Copyright (c) 2002-2007 Steve Landers
  6. #
  7. # See http://wiki.tcl.tk/critcl
  8. #
  9. # This is the Critcl runtime that loads the appropriate
  10. # shared library when a package is requested
  11. #
  12.  
  13. namespace eval ::critcl2 {
  14.  
  15. proc loadlib {dir package version mapping args} {
  16. global tcl_platform
  17. set path [file join $dir [::critcl::platform $mapping]]
  18. set ext [info sharedlibextension]
  19. set lib [file join $path $package$ext]
  20. set provide [list]
  21. if {[llength $args]} {
  22. set preload [file join $path preload$ext]
  23. foreach p $args {
  24. set prelib [file join $path $p$ext]
  25. if {[file readable $preload] && [file readable $prelib]} {
  26. lappend provide [list load $preload]
  27. lappend provide [list ::critcl2::preload $prelib]
  28. }
  29. }
  30. }
  31. lappend provide [list load $lib $package]
  32. foreach t [glob -nocomplain [file join $dir Tcl *.tcl]] {
  33. lappend provide [list source $t]
  34. }
  35. lappend provide "package provide $package $version"
  36. package ifneeded $package $version [join $provide "; "]
  37. package ifneeded critcl 0.0 \
  38. "package provide critcl 0.0; [list source [file join $dir critcl.tcl]]"
  39. }
  40.  
  41. # ::critcl2::precopy is only used on Windows when preloading out of a
  42. # VFS that doesn't support direct loading (usually, a Starkit)
  43. # - we preserve the dll name so that dependencies are satisfied
  44. # - critcl2::preload is defined in critcl/lib/critcl/critcl_c/preload.c
  45.  
  46. proc precopy {dll} {
  47. global env
  48. if {[info exists env(TEMP)]} {
  49. set dir $env(TEMP)
  50. } elseif {[info exists env(TMP)]} {
  51. set dir $env(TMP)
  52. } elseif {[info exists ~]} {
  53. set dir ~
  54. } else {
  55. set dir .
  56. }
  57. set dir [file join $dir TCL[pid]]
  58. set i 0
  59. while {[file exists $dir]} {
  60. append dir [incr i]
  61. }
  62. set new [file join $dir [file tail $dll]]
  63. file mkdir $dir
  64. file copy $dll $new
  65. return $new
  66. }
  67. }
  68.  
  69. namespace eval ::critcl {
  70. # a version of critcl::platform that applies the platform mapping
  71. proc platform {{mapping ""}} {
  72. set platform [::platform::generic]
  73. set version $::tcl_platform(osVersion)
  74. if {[string match "macosx-*" $platform]} {
  75. # "normalize" the osVersion to match OSX release numbers
  76. set v [split $version .]
  77. set v1 [lindex $v 0]
  78. set v2 [lindex $v 1]
  79. incr v1 -4
  80. set version 10.$v1.$v2
  81. }
  82. foreach {config map} $mapping {
  83. if {[string match $config $platform]} {
  84. set minver [lindex $map 1]
  85. if {[package vcompare $version $minver] != -1} {
  86. set platform [lindex $map 0]
  87. break
  88. }
  89. }
  90. }
  91. return $platform
  92. }
  93.  
  94. }