Jump to content
chain

Unload a TCL Script

Recommended Posts

  • Administrators
# Script: unloadtcl.tcl
# Version: 1.1
# Author: Wingman <Wingman@WINGDesign.de>

# Description: This scripts allows you to load/unload tcl scripts via
# partyline.

# DCC Commands:
# .loadtcl <scriptname>
# .unloadtcl <scriptname>
# .viewtcls <loaded/all>

# Updates:
# 1.1 (16. Nov 99) added .viewtcls all, settings for dir, pattern, automaticlly
#     rehash/restart, now .loadtcl notifies loaded tcls and don't let you load 
#     the same tcl twice. Also fixed some unbind bugs.

# Known bugs:
# it can't unbind bindings, which are set via foreach e.g. userinfo.tcl

# Settings:

# 0 = no rehash/restart, 1 = rehash, 2 = restart
set ul(refresh) 1
set ul(dir) "scripts"
set ul(pattern) "*.tcl"

# Bindings:
bind dcc n unloadtcl dcc:unloadtcl
bind dcc n loadtcl dcc:loadtcl
bind dcc n viewtcls dcc:viewtcls 

# Procedures - You don't have to edit anything below.

proc ul:get_scripts {} {
  global config
  set loaded_scripts ""
  set file [open $config r]
  while {![eof $file]} {
    set line [gets $file]
    if {[string match "source*" $line]} {
      set script "[string range $line 15 end]"
      if {[string match "/" $script]} {
        set script [lindex [split $script /] [incr [llength [split $script /]] -1]]
        set path [string range $line 0 [string length $script]]
      }
      append loaded_scripts "$script "
    }
  }
  close $file
  return $loaded_scripts
}

proc dcc:loadtcl { hand idx arg } {
  global config ul
  if {[llength $arg] < 1} {
    putdcc $idx "Usage: .loadtcl <scriptname>"
    return
  } 
  if {![file exists scripts/$arg]} {
    putdcc $idx "Can't find tcl $arg."
    return
  }
  if {[lsearch "[ul:get_scripts]" $arg] != -1} {
    putdcc $idx "Tcl script already loaded: $arg"
    return
  }
  set file [open $config a+]
  puts $file "source scripts/$arg"
  close $file
  putdcc $idx "Done. $arg successfully loaded."
  if {$ul(refresh) == 1} { 
    rehash
  } elseif {$ul(refresh) == 2} {
    restart
  } {
    putdcc $idx "Now do a .rehash or .restart."
  }
  return 1
}

proc dcc:unloadtcl { hand idx arg } {
  global config ul 
  if {[llength $arg] < 1} {
    putdcc $idx "Usage: .unloadtcl <scriptname>"
    putdcc $idx "       try '.viewtcls loaded' for a list of loaded scripts"
    return 
  }
  if {![file exists scripts/$arg]} {
    putdcc $idx "Can't find tcl: $arg."
    return
  }
  set file [open $config r]
  while {![eof $file]} {
    set line [gets $file]
    if {![string match "source scripts/$arg *" $line] && ![string match "source scripts/$arg" $line]} {
      lappend content $line
    } {
      set foo 1
    }
  }
  close $file
  if {![info exists foo]} {
    putdcc $idx "Can't find loaded tcl: $arg."
    return
  }
  set file [open $config w]
  foreach line $content { puts $file $line }
  close $file
  set ubc_success 0
  set ubc_failed 0
  set proc_success 0
  set proc_failed 0
  set file [open scripts/$arg r]
  while {![eof $file]} {
    set line [gets $file]
    if {([string match "* bind *" $line] || [string match "bind *" $line]) && ![string match "*#*" $line]} {
      set foo1  [lindex $line 1]
      if {[string match "*\$*" $foo1]} {
        set varname [lindex [split $foo1 \$] 1]
	if {[string match "*(*" $varname]} {
	  global [lindex [split $varname (] 0]
	} {
	  global $varname
	}
	set foo1 [set $varname]
      }
      set foo2 [lindex $line 2]
      if {[string match "*\$*" $foo2]} {
	if {[llength [split $foo2 |]] == 2} {
	  set gflag [lindex [split $foo2 |] 0]
	  set cflag [lindex [split $foo2 |] 1]
	  if {[string index $gflag 0] == "\$"} {
 	    global [string trimleft $gflag $]
	    set foo2 "[set [string trimleft $gflag $]]"
	  } {
	    set foo2 "$gflag"
	  }
	  if {[string index $cflag 1] == "\$"} {
	    global [string trimleft $cflag $]
	    append foo2 "|[set [string trimleft $cflag $]]"
	  } {
	    append foo2 "|$cflag"
	  }
	} elseif {[llength [split $foo2 &]] == 2} {
          set gflag [lindex [split $foo2 &] 0]
          set cflag [lindex [split $foo2 &] 1]
          if {[string index $gflag 0] == "\$"} {
            global [string trimleft $gflag $]
            set foo2 "[set [string trimleft $gflag $]]"
          } {
            set foo2 "$gflag"
          }
          if {[string index $cflag 1] == "\$"} {
            global [string trimleft $cflag $]
            append foo2 "&[set [string trimleft $cflag $]]"
          } {
            append foo2 "&$cflag"
          }
	} else {
          set varname [lindex [split $foo2 "\$"] 1]
          if {[string match "*(*" $varname]} {
            global [lindex [split $varname (] 0]
          } {
            global $varname
	  }
	  set foo2 [set $varname]
	}
      }
      set foo3 [lindex $line 3]
      if {[string match "*\$*" $foo3]} {
        set varname [lindex [split $foo3 \$] 1]
        if {[string match "*(*" $varname]} {
	  global [lindex [split $varname (] 0]
	} {
          global $varname
	}
	set foo3 [set $varname]
      }
      set foo4 [lindex $line 4]
      catch { unbind $foo1 $foo2 $foo3 $foo4 } error
      if {[string match "TCL error:*" $error]} {
        putdcc $idx " *** error, while executing: unbind $foo1 $foo2 $foo3 $foo4"
	putdcc $idx "     msg: $error"
	incr ubc_failed
      } {
        incr ubc_success
      }
    }
    if {[string match "*proc *\{*\}*\{*" $line]} {
      set procname [lindex [lindex [split $line \{] 0] 1]
      catch { rename $procname "" } error
      if {[string match "TCL error:*" $error]} {
        putdcc $idx " *** error while executing: rename $procname \"\""
	putdcc $idx "     msg: $error"
	incr proc_failed
      } {
        incr proc_success
      }
    }
  }
  close $file
  putdcc $idx "All Done. Showing report:"
  putdcc $idx "  Unbinded $ubc_success commands."
  if {$ubc_failed > 0} {
    putdcc $idx "   * failed: $ubc_failed commands."
  }
  putdcc $idx "  Deleted $proc_success procedures."
  if {$proc_failed > 0} {
    putdcc $idx "   * failed: $proc_failed procedures."
  }
  if {$ul(refresh) == 1} {
    rehash
  } elseif {$ul(refresh) == 2} {
    restart
  } {
    putdcc $idx "I recommend to do an rehash or better a .restart!"
  }
  return 1
}

proc dcc:viewtcls { hand idx arg } {
  global ul
  set loaded_scripts [ul:get_scripts]
  if {[string tolower $arg] == "loaded"} {  
    putlog "#$hand# viewtcls $arg"
    if {![info exists loaded_scripts]} {
      putdcc $idx "No tcls loaded."
    } {
      putdcc $idx "List of loaded tcls:"
      foreach script $loaded_scripts {
        putdcc $idx " $script"
      }
    }
    return
  } elseif {[string tolower $arg] == "all"} {
    catch { glob $ul(dir)/$ul(pattern) } tclfiles
    if {[lrange "$tclfiles" 0 4] == "no files matched glob pattern"} {
      putdcc $idx "Can't find any tcl ($ul(pattern)) script in $ul(dir)."
      return 1
    }
    foreach script $tclfiles {
      if {[lsearch -exact "$loaded_scripts" [string range $script [expr [string length $ul(dir)]+1] end]] == -1} {
        putdcc $idx "  [string range $script [expr [string length $ul(dir)]+1] end]"
      } {
        putdcc $idx "  [string range $script [expr [string length $ul(dir)]+1] end] (loaded)"
      }
    }
    return 1
  }
putdcc $idx "Usage: .viewtcls <loaded/all>"
return
}

#putlog "UnloadTCL v1.1 by Wingman loaded."

 

Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

Guest
Reply to this topic...

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

Loading...


×
×
  • Create New...