Version 49 of Matthias Hoffmann

New stuff is organized into subpages...

Matthias Hoffmann - Tcl-Code-Snippets - tcom & wmi - Examples
Matthias Hoffmann - Tcl-Code-Snippets - Starkit/pack-related (if not already on this unorganized page...)
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 *]
                    foreach newDir [concat $dn $dh] {
                        set theDir [file tail $newDir]
                        if {[string equal $theDir "."] || [string equal $theDir ".."]} {
                            # Don't push this dir! Otherwise we enter an endless loop
                        } else {
                           lappend newStack $newDir
                        }
                    }
 # Was:             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!

ECS: I had to include some lines to test for "." and ".." otherwise the routine loops. MH: On my platform (W2k, Tcl 8.4.6), the original routine does not loop; the glob command never returns '..' and '.'. Which platform did you test the code on? ECS: Debian Linux: Linux babylon 2.4.26-ow2 #1 Fri Jul 9 15:19:06 BRT 2004 i686 GNU/Linux TCL is 8.4.7 (samething happens with 8.4.6). In any case it is better to be safe than sorry :-)

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 <rc> (<rc> 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       [email protected]
 }
 # reading the profile
 array set info [readprof::readprof1 profile.rc [array get info]]
 parray info; # will now return:

 tempDir -> c:/temp
 runIntervall -> 2000
 notify [email protected]

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 catches
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

Another (yet undocumented) alternative, using winutils, is mentioned here: http://wiki.tcl.tk/2631

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)
         uplevel [list $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

Remarks: unfortunally, STDERR-CATCHing with 2>@ does't seems to work with Windows 2000.....

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 "<getobject 'WinNT:'> 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 "<getobject 'WinNT://$container,$contype'> 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... - in progress meanwhile
More ADSI-Examples

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

Version 49 of Matthias Hoffmann - Tcl-Code-Snippets