/[tcldrop]/tcldrop/modules/core.tcl
ViewVC logotype

Diff of /tcldrop/modules/core.tcl

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.26 by fireegl, Mon Dec 1 01:59:51 2003 UTC revision 1.27 by fireegl, Mon Dec 1 08:06:54 2003 UTC
# Line 203  proc ::tcldrop::LogFile {levels channel Line 203  proc ::tcldrop::LogFile {levels channel
203  # Use * for all channels, or - to specify that it's global-only.  # Use * for all channels, or - to specify that it's global-only.
204  proc putloglev {levels channel text} {  proc putloglev {levels channel text} {
205          # Call all of the LOG binds here:          # Call all of the LOG binds here:
         # This bind type was created in order to log to files and to consoles without being tied to those functions/modules directly.  
206          foreach b [binds log] {          foreach b [binds log] {
207                  foreach {type flags mask count proc} $b {}                  foreach {type flags mask count proc} $b {}
208                  if {[::tcldrop::CheckFlags $flags $levels] && [string match -nocase $mask $channel]} {                  if {[::tcldrop::CheckFlags $flags $levels] && [string match -nocase $mask $channel]} {
# Line 291  proc ::tcldrop::bind {type flags mask pr Line 290  proc ::tcldrop::bind {type flags mask pr
290          # FixMe: This should check a list of registered bind types before accepting the bind.          # FixMe: This should check a list of registered bind types before accepting the bind.
291          # Note: + or * means "anybody".  And - means "nobody".          # Note: + or * means "anybody".  And - means "nobody".
292          switch -- $flags {          switch -- $flags {
293                  {-} - {+} - {*} - {-|-} - {*|*} { set flags {+|+} }                  {-} - {+} - {*} - {-|-} - {*|*} { array set options [list flags {+|+}] }
294                  {default} { if {![string match {*|*} $flags]} { set flags "$flags|-" } }                  {default} { if {![string match {*|*} $flags]} { array set options [list flags "$flags|-"] } }
295          }          }
296          variable Binds          variable Binds
297          set Binds($type,$options(-priority),$proc,$mask) [array get options]          set Binds($type,$options(-priority),$proc,$mask) [array get options]
# Line 553  proc loadmodule {module {version {}}} { Line 552  proc loadmodule {module {version {}}} {
552                  # Note, the reason for importing the commands to both the tcldrop                  # Note, the reason for importing the commands to both the tcldrop
553                  # and the global namespace is so that in case we're not running                  # and the global namespace is so that in case we're not running
554                  # in our own interp we won't disturb what's already there.                  # in our own interp we won't disturb what's already there.
                 # FixMe: All modules need to be changed to use (for example):  
                 #        ::tcldrop::bind  
                 #        Instead of:  
                 #        bind  
                 #        That goes for ALL *core* tcldrop commands.  
555    
556                  # Load the corresponding .lang file:                  # Load the corresponding .lang file:
557                  if {[addlang $::lang $module]} {                  if {[addlang $::lang $module]} {
# Line 565  proc loadmodule {module {version {}}} { Line 559  proc loadmodule {module {version {}}} {
559                  } else {                  } else {
560                          catch { putlog "[format $::tcldrop::lang(0x210) $module]" }                          catch { putlog "[format $::tcldrop::lang(0x210) $module]" }
561                  }                  }
562                    foreach b [binds load] {
563                            foreach {type flags mask count proc} $b {}
564                            if {[string match -nocase $mask $module]} {
565                                    if {[catch { $proc $module } err]} {
566                                            putlog "Error in $proc: $err"
567                                            puterrlog "$::errorInfo"
568                                    }
569                                    ::tcldrop::countbind $type $mask $proc
570                            }
571                    }
572          }          }
573  }  }
574    
# Line 572  proc loadmodule {module {version {}}} { Line 576  proc loadmodule {module {version {}}} {
576  proc checkmodule {module {version {}}} { loadmodule $module $version }  proc checkmodule {module {version {}}} { loadmodule $module $version }
577    
578  proc unloadmodule {module} { set out {}  proc unloadmodule {module} { set out {}
         # FixMe: create a new bind called "unloadmod" or something,  
         #        so that modules can know when they're about to be unloaded.  
         #        They should return 0 if it's ok to continue with the rest of this proc.  
         #        If they return 1 then we shouldn't unload them (likely because they're required)  
579          if {[catch { namespace forget "tcldrop::${module}::*" }]} {          if {[catch { namespace forget "tcldrop::${module}::*" }]} {
580                  set out [format $::tcldrop::lang(0x207)]                  set out [format $::tcldrop::lang(0x207)]
581          } else {          } else {
582                  putlog "[format $::tcldrop::lang(0x206)] $module"                  putlog "[format $::tcldrop::lang(0x206)] $module"
   
583          }          }
584          package forget "tcldrop-$module"          package forget "tcldrop-$module"
585            foreach b [binds unld] {
586                    foreach {type flags mask count proc} $b {}
587                    if {[string match -nocase $mask $module]} {
588                            if {[catch { $proc $module } err]} {
589                                    putlog "Error in $proc: $err"
590                                    puterrlog "$::errorInfo"
591                            }
592                            ::tcldrop::countbind $type $mask $proc
593                    }
594            }
595          set out          set out
596  }  }
597    

Legend:
Removed from v.1.26  
changed lines
  Added in v.1.27

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26