---- '''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 - Tcl-Code-Snippets - tclhttpd and cgi-related] * [Matthias Hoffmann - Tcl-Code-Snippets - wikit-related] * [Matthias Hoffmann - Tcl-Code-Snippets - misc routines] * [Matthias Hoffmann - Other Utilities] * [Matthias Hoffmann - PhotoPrinter] * [Matthias Hoffmann - Ideen] * [Matthias Hoffmann - Thoughts And Ideas] ---- ---- '''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}} { rename $cmd {} } } rename if {}; 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 See [Matthias Hoffmann - Tcl-Code-Snippets - Misc - Readprof] for a new, more complete but not yet translated version of readprof. ---- '''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 # 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 * Another (yet undocumented) alternative, using [winutils], is mentioned here: http://wiki.tcl.tk/2631. * And another one using WMI (waiting to be adapted to tcom) is here: http://www.microsoft.com/resources/documentation/windows/2000/server/scriptguide/en-us/sas_fil_overview.mspx! * And with version 0.6 of [twapi] [http://twapi.sourceforge.net], there seems to be there, what I've been missing until now....: '''twapi::begin|cancel_filesystem_monitor''', which works simple with callback-procs! But, in contrast of available "high-level" (laugh!) Microsoft-calls, it's again up to the programer to determine ''what the actual changes in the filesystem really are...'' To see how that task can be done, see [Matthias Hoffmann - Other Utilities - Dirwatcher]. ---- '''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 " 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... - 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]