Version 71 of Matthias Hoffmann - Tcl-Code-Snippets

Updated 2006-04-12 09:40:42

New stuff is organized into subpages...


ffcn: Implementation of the Win32-API-Call FindFirstChangeNotification()

Note:

 ################################################################################
 # 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
 #   URL homepages.fh-giessen.de/~hg6661/vorlesungen/systemschnittstellen no longer avail
 #          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 too 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

See Matthias Hoffmann - Tcl-Code-Snippets - Misc - Bgexec for a new, less buggy but not yet translated version of bgexec.

Remarks: unfortunally, STDERR-CATCHing with 2>@ does't seems to work with Windows 2000...... For 8.4.7 and above, there is or will be a fix, see http://www.tcl.tk/cgi-bin/tct/tip/202.html .


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