---- '''New stuff is organized into subpages...''' * [Matthias Hoffmann - Tcl-Code-Snippets - tcom & wmi - Examples] * [Matthias Hoffmann - Other Utilities] ---- '''globx: Extended globbing, non-recursively walking through directory-trees''' proc globx {startDir {search *} {cb ""}} { set dirStack [list [file normalize $startDir]] set files {} set fc 0 while {[llength $dirStack]} { set newStack {} foreach dir $dirStack { set fn [glob -noc -typ f -dir $dir -- $search] set fh [glob -noc -typ {f hidden} -dir $dir -- $search] if {[string equal $cb ""]} { eval lappend files $fn $fh } else { foreach f [concat $fn $fh] { incr fc uplevel [list $cb $f] } } set dn [glob -noc -typ d -dir $dir *] set dh [glob -noc -typ {d hidden} -dir $dir *] eval lappend newStack $dn $dh } set dirStack $newStack update } if {[string equal $cb ""]} { return [lsort $files] } else { return $fc } } '''Examples:''' '''''Without a callback, directly returning the filenames as a list:''''' puts [globx c:/winnt] puts [globx c:/winnt *.dll] '''''Returning the filenames unsorted name-by-name via callback:''''' proc callback file { puts $file } puts [globx c:/winnt * callback]; # will return the number of files read This is to save memory! ---- '''readprof: Reading profiles with custom''' '''''commands''''' '''via a slave interpreter''' package provide readprof 1.0 namespace eval readprof {} #---------------------------------------------------------------------------------- # prof - filename of the profile # cmds - allowed 'commands' in the profile as a list where each element is {cmdName defVal} # returns: cmdName Value cmdName Value [...] _errorMsg ( empty if ok) # proc readprof::readprof1 {prof cmds} { catch { set id [interp create -safe] # maximum security in the slave: deleting all availabe commands! interp eval $id { foreach cmd [info commands] { if {$cmd != {rename} && $cmd != {if} && $cmd != {info}} { rename $cmd {} } } rename if {}; rename info {}; rename rename {} } array set temp $cmds proc set$id {key args} { upvar 1 temp myArr; set myArr($key) [join $args] } # defining aliases in the slave for each available profile-'command' # and mapping of each command to the set$id procedure foreach {cmd default} $cmds { interp alias $id $cmd {} readprof::set$id $cmd; # arg [...] } # 'invoking/executing' the profile $id invokehidden source $prof # clean-up interp delete $id rename set$id {} } rc set temp(_errorMsg) $rc return [array get temp] } '''Example:''' package require readprof # preparing the available profile commands and defaults of a hypothetical profile array set info { tempDir d:/temp runIntervall 5000 notify xyz@abc.de } # reading the profile array set info [readprof::readprof1 profile.rc [array get info]] parray info; # will now return: tempDir -> c:/temp runIntervall -> 2000 notify xyz@abc.de '''''simple profile-file profile.rc''''' tempDir c:/temp runIntervall 2000 ---- '''ffcn: Implementation of the Win32-API-Call''' '''''FindFirstChangeNotification()''''' Note: * Not yet very robust due to the lack of '''catch'''es * Not yet translated to the english language * Blocking the tcl program (eventloop) * See also http://support.microsoft.com/default.aspx?scid=kb;EN-US;188321 ################################################################################ # Modul: ffcn.tcl # Stand: 11.03.2004 # Zweck: Mapping von Win32-API-Calls: 'FindFirstChangeNotification' # 'FindCloseChangeNotification' # 'WaitForSingleObject' # Autor: (C) M.Hoffmann, M��¤rz 2004 # Siehe: # API-Deklaration (Original Win32): # http://msdn.microsoft.com/library/default.asp?url=/library/en-us/fileio/base/findfirstchangenotification.asp # FFIDL: # http://mini.net/tcl/1197, http://www.elf.org/ffidl/ # API-Deklarationen in PB: # DECLARE FUNCTION FindFirstChangeNotification LIB "KERNEL32.DLL" ALIAS # "FindFirstChangeNotificationA" (lpPathName AS ASCIIZ, # BYVAL bWatchSubtree AS LONG, # BYVAL dwNotifyFilter AS DWORD) AS DWORD # DECLARE FUNCTION FindCloseChangeNotification LIB "KERNEL32.DLL" ALIAS # "FindCloseChangeNotification" (BYVAL hChangeHandle AS DWORD) AS LONG # DECLARE FUNCTION WaitForSingleObject LIB "KERNEL32.DLL" ALIAS # "WaitForSingleObject" (BYVAL hHandle AS DWORD, # BYVAL dwMilliseconds AS DWORD) AS DWORD # FILE_NOTIFY_CHANGE_FILE_NAME = 0x00000001 default # FILE_NOTIFY_CHANGE_DIR_NAME = 0x00000002 default # FILE_NOTIFY_CHANGE_ATTRIBUTES = 0x00000004 default # FILE_NOTIFY_CHANGE_SIZE = 0x00000008 default # FILE_NOTIFY_CHANGE_LAST_WRITE = 0x00000010 default # FILE_NOTIFY_CHANGE_LAST_ACCESS= 0x00000020 # FILE_NOTIFY_CHANGE_CREATION = 0x00000040 default # FILE_NOTIFY_CHANGE_SECURITY = 0x00000100 # INVALID_HANDLE_VALUE = 0xffffffff # INFINITE = 0xffffffff # Datentypen: # http://www.a-m-i.de/tips/strings/strings.php # http://homepages.fh-giessen.de/~hg6661/vorlesungen/systemschnittstellen/ # script/win/datentypen.php # Offen: Namespace,RoboDOCu,Konstanten implementieren,Catch f��¼r ffidl::callout, # Abbruchm��¶glichkeit,nicht blockierende Variante,gleich die tats��¤chlichen # ����nderungen zur��¼ckliefern (glob vorher/nachher;intersect liefern) ################################################################################ package provide ffcn 1.0 package require Ffidl 0.5 ffidl::callout dll_ffcn {pointer-utf8 long long} long \ [ffidl::symbol kernel32.dll FindFirstChangeNotificationA] ffidl::callout dll_fccn {long} long \ [ffidl::symbol kernel32.dll FindCloseChangeNotification] ffidl::callout dll_wfso {long long} long \ [ffidl::symbol kernel32.dll WaitForSingleObject] # Dieser Call wartet (wohl blockierend), bis eine ����nderung im Verzeichnis auftritt proc waitChange {pathName {includeSubDirs 0} {notifyFilter 0x5F}} { # ����berwachung einleiten if {[catch {dll_ffcn $pathName $includeSubDirs $notifyFilter} h] || $h == -1} { return -code error "FindFirstChangeNotification() gescheitert ($h)" } # puts $h # Achtung: das folgende blockiert vermutlich Tcl-Eventloop! # ����berwachung starten (momentan OHNE CATCH) set r [dll_wfso $h 0xffffffff] # ����berwachung beenden (momentan OHNE CATCH) set r [dll_fccn $h] return {} } ################################################################################ '''Example:''' package require ffcn # because of the Win32-API-Call waitForSingleObject(), the following call blocks # the whole program; I haven't found a solution for this yet... # If a file in e:/demodir is created, deleted etc., the call returns: # waitChange e:/demodir A 'tcl-only' alternative for tracking directory-changes using a polling-method (so the after ''ms''-Value should not be to small because of cpu-load-aspects!): proc watchDirChange {dir intv {script {}} {lastMTime {}}} { set nowMTime [file mtime $dir] if [string eq $lastMTime ""] { set lastMTime $nowMTime } elseif {$nowMTime != $lastMTime} { # synchronous execution, so no other after event may fire in between catch {uplevel #0 $script} set lastMTime $nowMTime } after $intv [list watchDirChange $dir $intv $script $lastMTime] } watchDirChange e:/work 5000 { puts stdout {Directory 'e:/work' changed!} } vwait forever ---- '''netsend: sending short messages (''''''''Popups'''''''') across the Windows-Network''' '''Note:''' * These messages apear on nt, w2k, xp-clients if the ''messenger service'' is started * On Win 3.x 9.x, the winpopup.exe-program must be loaded * On MS-DOS LAN-Manager clients, a similar program can be loaded * Because of the chaos in microsoft-APIs and some incompatability between os- and network-client versions and internal message-handling and capabilities, sending and receiving network-popups is not a reliable method to deliver important information: some users receive, some users don't, others incedently close the popup window and so on... * Messages can be send to a particular user, workstation, all Message Names (*) or a Domain (in other words: to adressable ''Netbios-Messagenames'') package provide netsend 1.0 package require Ffidl 0.5 ffidl::callout dll_netSend {pointer-utf16 pointer-utf16 pointer-utf16 pointer-utf16 long} long \ [ffidl::symbol netapi32.dll NetMessageBufferSend] proc netSend {dest mesg {srv {}}} { set from $::tcl_platform(user) # or: # set from [info host] return [dll_netSend $srv $dest $from $mesg [expr [string length $mesg]*2]] } '''Example:''' package require netsend 1.0 puts [netSend hoffmann "This is a Testmessage"] ---- '''bgexec: launches processes in background, catches output via fileevent-handler''' ################################################################################### # Modul : bgexec1.tcl # # Date : 14.11.2003 # # Purpose : Process execution in background # # Todo : NAMESPACE; see Sourcecode; STDERR-Catching does not work? (Win) # ################################################################################### package provide bgexec 1.0 #=============================================================================== # Launches the specified 'prog'ram. The userdefined 'readHandler' will be called # through the generic fileeventhandler with STDOUT and STDERR-data from the # process appended. pCount receives the number of called processes. # Returnes the file event handle from 'open...'. # ToDo: # - handling of hanging processes (timeout) # proc bgExec {prog readHandler pCount} { upvar #0 $pCount myCount if ![string length [auto_execok [lindex $prog 0]]] { return -code error "program '$prog' not found!" } if [catch {open "|$prog 2>@ stdout" r} pH] { return -code error "program '$prog' not started: '$pH'" } if ![info exists myCount] { set myCount 1 } else { incr myCount } fconfigure $pH -blocking 0 fileevent $pH readable [list bgExecGenericHandler $pH $pCount $readHandler] return $pH } proc bgExecGenericHandler {chan pCount readHandler} { # Attention: Execution in global context! upvar #0 $pCount myCount if {[eof $chan]} { catch {close $chan}; # deregistering handler (see Practical Progr. p.229) incr myCount -1 } elseif {[gets $chan line] != -1} { # we are not blocked (manpage gets, Practical Progr. p.233) $readHandler $line } } '''Example:''' An example proc ''delayout.tcl'', which will be run three times simultaneously in the background: after 5000 puts "Output to STDOUT" puts stderr "Output to STDERR" The mainproc ''bgexec_test.tcl'' which launches the example proc ''delayout.tcl'': proc putsx what { puts ">>>$what<<<" } package require bgexec set h1 [bgExec $argv putsx pCount]; # starting the 1st instance... set h2 [bgExec $argv putsx pCount]; # starting the 2nd instance... set h3 [bgExec $argv putsx pCount]; # starting the 3rd instance.... # Eventloop is required to process the fileevents while {$pCount} { # pCount falls to zero if all processes have finished update } Start everything: tclsh bgexec_test.tcl tclsh delayout.tcl ---- '''A simple ADSI-Example using [tcom]:''' proc logEvent {evtType args} { # ohne Fehlernachricht catch { set wsh [::tcom::ref createobject "WScript.Shell"] $wsh LogEvent $evtType "[regsub -all {\n} $args { - }]" } } '''One more complicated example: return the available Windows-NT- and ADS-Domains and Workgroups as a list:''' proc GetDomains {} { set ret {} if [catch {::tcom::ref getobject "WinNT:"} d] then { return -code error " failed: $d" } else { ::tcom::foreach domain $d { if ![catch {::tcom::ref getobject [$domain ADsPath],domain}] { set ct (Domain) } else { set ct (Workgroup) } lappend ret [list [$domain Name] $ct] } } return $ret } '''And another one: get the''' '''''groups''''' '''of a given container (that is, a Domain or Workgroup):''' proc GetGroups {container {contype domain}} { set ret {} # get Domain-/Computerobject if [catch {::tcom::ref getobject "WinNT://$container,$contype"} g] then { return -code error " failed: $g" } ::tcom::foreach m $g { # instead of IF one can use a -filter here... if {[$m Class] == "Group"} { lappend ret [$m Name] } } return $ret } (''contype'' can be ''domain'' or ''computer'') '''And finally get the users within such a group:''' (...to be done...) ---- Reminder: * time to split this page into subpages to keep an overview of what's going on... * execX - Simplifying the execution of .EXEs which are inside of Starkits/Starpacks * More [ADSI]-Examples here ---- HAve you considered submitting these for inclusion in [tcllib]? M.H.: '''no''', I think I haven't yet reached the required level of tcl-knowledge ... ---- [Category Package]