Where: http://elf.org/ffidl/
 Description: Extension which allows pure Tcl extensions to invoke shared
        library functions without glue.
        Available for Linux, Windows and Mac OS X.
        Currently at version 0.6 .
 Updated: ??/2006
 Contact: mailto:rec@elf.org (Roger E. Critchlow Jr.)

 [http://www.categorifiedcoder.info/tcltk/ffidl/ffidl-0.6.1-darwin-9-univ.tar.gz]  SOURCE
 [http://www.tcl.tk/starkits/ffidl0.6.1_ub.tgz]  MacOS Universal Binary  (tested on Leopard)

 To give you an impression about the use of ffidl,
 look at the following C and TCL-declarations:
 --- file foo.h: ---
 int foo_init( int adr, int log );
 int foo_done( void );
 int foo_info( FOO_INFO *infoPtr ); /* FOO_INFO is a structure */
 int foo_open( const char *port );
 --- file foo.tcl: ---
 load ffidl05.dll
 set DLL foo.dll
 ffidl::callout foo_init {int int} int  [ffidl::symbol $DLL foo_init]
 ffidl::callout foo_done {} int   [ffidl::symbol $DLL foo_done]
 ffidl::callout foo_info {pointer-var} int [ffidl::symbol $DLL foo_info]
 ffidl::callout foo_open {pointer-utf8} int [ffidl::symbol $DLL foo_open]

 #Rolf Schroedter
 #German Aerospace Center
 #Institute of Space Sensor Technology and Planetary Exploration

 load ffidl05.dll

 ffidl::callout dll_FindWindow       {pointer-utf8 pointer-utf8} int     [ffidl::symbol user32.dll FindWindowA]
 ffidl::callout dll_FindWindowTitle  {int pointer-utf8} int              [ffidl::symbol user32.dll FindWindowA]
 ffidl::callout dll_FindWindowClass  {pointer-utf8 int} int              [ffidl::symbol user32.dll FindWindowA]
 ffidl::callout dll_SetWindowPos     {int int int int int int int} int   [ffidl::symbol user32.dll SetWindowPos]
 ffidl::callout dll_SystemParametersInfo {int int pointer int} int       [ffidl::symbol user32.dll SystemParametersInfoA]

 proc FindWindow { class title } {
    if { [string length $class] == 0 } {
        dll_FindWindowTitle 0 $title
    } elseif { [string length $title] == 0 } {
        dll_FindWindowClass $class 0
    } else {
        dll_FindWindow $class $title
    }
 }
 proc SetWindowPos { hwnd after x y cx cy {flags 0} } {
    array set VAL {TOP 0 BOTTOM 1 TOPMOST -1 NOTOPMOST -2}
    set iAfter $VAL([string toupper $after])
    dll_SetWindowPos $hwnd $iAfter $x $y $cx $cy $flags
 }
 proc SetupScreenSaver { bool } {
    dll_SystemParametersInfo 97 $bool 0 0   ;# SPI_SCREENSAVERRUNNING=97
 }
 proc exit? {} {
    set answer [tk_messageBox -message "Really quit?" -type yesno -icon question]
    switch -- $answer {
        yes {
            SetupScreenSaver 0
            exit
        }
        no {}
    }
 }
 proc ScreenSaver {win} {
    set size(X) [winfo screenwidth .]
    set size(Y) [winfo screenheight .]

    toplevel $win
    wm title $win "TclScreenSaver"     ;# to find the window

    wm overrideredirect $win true
    $win configure -relief flat -bd 0
    $win configure -cursor hand2    ;# Ohne cursor ???

    update idletasks                ;# virtually display $win, allows window to be found
    set hwnd [FindWindow "" "TclScreenSaver"]
    set res1 [SetWindowPos $hwnd TOPMOST 0 0 $size(X) $size(Y)]   ;# ever makes full screen
    set res2 [SetupScreenSaver 1]

    canvas $win.c -background yellow -width $size(X) -height $size(Y) -relief flat -bd 0
    pack $win.c -expand yes -fill both

    focus -force $win

    bind $win <Key> exit?
    bind $win <Motion> {}
 }

 wm withdraw .
 ScreenSaver .scr

 load lib/ffidl05.dll
 ffidl::callout dll_SetFocus {int} int [ffidl::symbol user32.dll SetFocus]
 proc GrabFocus {args} {dll_SetFocus [winfo id .]}

 bind . <Button> +GrabFocus

 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]
      #  (only these two alternatives seems to work...)
      return [dll_netSend $srv $dest $from $mesg [expr [string length $mesg]*2]]
 }

ffidl::callout dll_ExpandEnvironmentStringsForUser \
    {int pointer-utf16  pointer-utf16 long} int \
    [ffidl::symbol Userenv.dll ExpandEnvironmentStringsForUserW]

proc {ExpandEnvironmentStringsForUser} {WPath} {
    set TclPath [string repeat \u0000 300]
    if [dll_ExpandEnvironmentStringsForUser 0 $WPath $TclPath 300] {
        set ix [string first \u0000 $TclPath]
        if {$ix > 0} {
            return [string range $TclPath 0 [expr {$ix - 1}]]
        } else {
            return {}
        }
    } else {
        return {}
    }
}

 ExpandEnvironmentStringsForUser {%ProgramFiles%\windows media player\wmplayer.exe}

 C:\Program Files\windows media player\wmplayer.exe

• updates for 2005 versions of libffi & ffcall
• TEA 3.2 buildsystem, testsuite
• support for Tcl 8.4, TclpDlopen, Tcl_WideInt
• fixes for 64bit LP64
• callouts & callbacks are created/used relative to current namespace (for unqualified names)
• addition of [ffidl::stubsymbol] for Tcl/Tk symbol resolution via stubs tables
• callbacks can be called anytime, not just from inside call-outs (using Tcl_BackgroundError to report errors)

• amd64-linux1
• alpha-linux1
• x86-linux1
• x86-linux2
• x86-solaris1
• x86-freebsd1
• x86-netbsd1

• sparc-solaris1

• x86-openbsd1
• ppc-osx1
• ppc-osx2

 #!/bin/sh
 #
 # Let's ffidl with Carbon HotKeys!
 #
 # Copyright (c) 2005, Daniel A. Steffen <das@users.sourceforge.net>
 # BSD License: c.f. <http://www.opensource.org/licenses/bsd-license>
 #
 #\
 exec wish $0 "$@"

 package require Tk
 package require Ffidl

 namespace eval carbon {

     ::ffidl::typedef EventHotKeyID {unsigned long} uint32
     ::ffidl::typedef EventTypeSpec uint32 uint32
     ::ffidl::typedef EventTargetRef pointer
     ::ffidl::typedef OSStatus sint32

     ::ffidl::callout RegisterEventHotKey {uint32 uint32 EventHotKeyID EventTargetRef \
                                           uint32 pointer-var} OSStatus \
             [::ffidl::symbol Carbon.framework/Carbon RegisterEventHotKey]

     ::ffidl::callout GetApplicationEventTarget {} EventTargetRef \
             [::ffidl::symbol Carbon.framework/Carbon GetApplicationEventTarget]

     ::ffidl::callout InstallEventHandler {EventTargetRef pointer-proc uint32 pointer-byte \
                                           pointer pointer-var} OSStatus \
             [::ffidl::symbol Carbon.framework/Carbon InstallEventHandler]

     ::ffidl::callout XKeysymToKeycode {pointer {unsigned long}} {unsigned long} \
             [::ffidl::stubsymbol tk intXLibStubs 35]; #XKeysymToKeycode

     ::ffidl::callout TkStringToKeysym {pointer-utf8} {unsigned long} \
             [::ffidl::stubsymbol tk intStubs 86]; #TkStringToKeysym
 }

 proc hotkeyHandler {handlerCallRef event userData} {
     .l configure -bg red
     after 200 .l configure -bg blue
     return 0
 }

 proc installHotKey {key} {
     labelframe .l -width 100 -height 100 -bg blue
     pack .l

     ::ffidl::callback hotkeyHandler {pointer pointer pointer} OSStatus

     set EventHandlerRef [binary format I 0]
     set res [carbon::InstallEventHandler [carbon::GetApplicationEventTarget] hotkeyHandler 1 \
         [binary format a4I keyb 5] 0 EventHandlerRef]
     if {$res} {puts stderr "InstallEventHandler failed: $res"; exit -1}

     set keycode [expr {[carbon::XKeysymToKeycode 0 [carbon::TkStringToKeysym $key]]>>16}]
     set modifiers [expr {1 << 8 | 1 << 9}]; #Cmd-Shift
     #set modifiers [expr {1 << 8}]; #Cmd

     set EventHotKeyRef [binary format I 0]
     set res [carbon::RegisterEventHotKey  $keycode $modifiers [binary format a4I wish 1] \
         [carbon::GetApplicationEventTarget] 0 EventHotKeyRef]
     if {$res} {puts stderr "RegisterEventHotKey failed: $res"; exit -1}
 }

 installHotKey A

 package require Tk
 package require Ffidl 0.6

 ::ffidl::callout CPSSetProcessName {pointer-byte pointer-utf8} sint32 \
         [::ffidl::symbol /System/Library/Frameworks/ApplicationServices.framework/Frameworks/CoreGraphics.framework/CoreGraphics CPSSetProcessName]
 CPSSetProcessName [binary format I2 {0 2}] "MyCoolApp"

 ::ffidl::callout ShowHideProcess {pointer-byte int} sint32 [::ffidl::symbol Carbon.framework/Carbon ShowHideProcess]
 ShowHideProcess [binary format I2 {0 2}] 1; #Show
 ShowHideProcess [binary format I2 {0 2}] 0; #Hide

 #!/bin/sh
 #
 # Set the Dock Tile from a png file with Ffidl
 #
 # Copyright (c) 2005, Daniel A. Steffen <das@users.sourceforge.net>
 # BSD License: c.f. <http://www.opensource.org/licenses/bsd-license>
 #
 #\
 exec wish $0 "$@"

 package require Tk
 package require Ffidl

 namespace eval carbon {
     proc api {name argl ret lib} {::ffidl::callout $name $argl $ret \
         [::ffidl::symbol $lib.framework/$lib $name]}
     proc type {name type} {::ffidl::typedef $name $type}
     proc const {name args} {variable {}; eval set [list ($name)] $args}

     type OSStatus sint32
     type bool int
     type CFURLRef pointer
     type CGDataProviderRef pointer
     type CGImageRef pointer
     type CGColorRenderingIntent int
     const kCGRenderingIntentDefault 0

     api CFURLCreateFromFileSystemRepresentation {pointer pointer-utf8 \
             int bool} CFURLRef CoreFoundation
     api CFRelease {pointer} void CoreFoundation
     api CGDataProviderCreateWithURL {CFURLRef} CGDataProviderRef \
             ApplicationServices
     api CGImageCreateWithPNGDataProvider {CGDataProviderRef pointer \
             bool CGColorRenderingIntent} CGImageRef ApplicationServices
     api SetApplicationDockTileImage {CGImageRef} OSStatus Carbon

     proc setDockTileToPNG {pngFile} {
         if {[file exists $pngFile]} {
             set url [CFURLCreateFromFileSystemRepresentation 0 $pngFile \
                     [string bytelength $pngFile] 0]
             if {$url} {
                 set dp [CGDataProviderCreateWithURL $url]
                 if {$dp} {
                     set img [CGImageCreateWithPNGDataProvider $dp 0 1 \
                             [const kCGRenderingIntentDefault]]
                     if {$img} {
                         SetApplicationDockTileImage $img
                         CFRelease $img
                     }
                     CFRelease $dp
                 }
                 CFRelease $url
             }
         }
     }
 }

 carbon::setDockTileToPNG test.png

 #!/bin/sh
 #
 # Ffidling CFLocale
 #
 # Copyright (c) 2005, Daniel A. Steffen <das@users.sourceforge.net>
 # BSD License: c.f. <http://www.opensource.org/licenses/bsd-license>
 #
 #\
 exec tclsh $0 "$@"

 package require Ffidl 0.6

 namespace eval corefoundation {
     proc api {name argl ret} {::ffidl::callout $name $argl $ret \
         [::ffidl::symbol CoreFoundation.framework/CoreFoundation $name]}
     api CFLocaleCopyCurrent {} pointer
     api CFLocaleGetIdentifier pointer pointer
     api CFStringGetLength pointer sint32
     ::ffidl::typedef CFRange sint32 sint32
     api CFStringGetCharacters {pointer CFRange pointer-var} void
     api CFRelease pointer void

     proc getLocaleIdentifier {} {
         set cfloc [CFLocaleCopyCurrent]
         set cfstr [CFLocaleGetIdentifier $cfloc]
         set len [CFStringGetLength $cfstr]
         set buf [binary format x[expr {2*$len}]]
         set range [binary format [::ffidl::info format CFRange] 0 $len]
         CFStringGetCharacters $cfstr $range buf
         CFRelease $cfloc
         encoding convertfrom unicode $buf
     }
 }

 puts [corefoundation::getLocaleIdentifier]

  typedef short           I16;
  typedef unsigned short  U16;

  I16 _7443_initial(I16 *existCards);
  I16 _7443_close(void);
  I16 _7443_version_info(I16 CardNo, U16 *HardwareInfo, U16 *SoftwareInfo, U16 *DriverInfo);
  I16 _7443_d_output(I16 CardNo, I16 Ch_No, I16 value);

  namespace eval 7443 {
      variable dll_name PPCI7443.dll

      ffidl::callout _initial {pointer-var} sint16 \
          [ffidl::symbol $dll_name _7443_initial]

      ffidl::callout close {} void [ffidl::symbol $dll_name _7443_close]

      ffidl::callout _version_info {sint16 pointer-var pointer-var pointer-var} \
          sint16 [ffidl::symbol $dll_name _7443_version_info]

      ffidl::callout d_output {sint16 sint16 sint16} sint16 \
            [ffidl::symbol $dll_name _7443_d_output]

  }

  # varName should containt quantity of available cards
  proc 7443::initial {varName} {
      upvar $varName existsCards
      set cards [binary format s 0]
      set result [_initial cards]
      binary scan $cards s existsCards
      return $result
  }

  # return: {errorCode hardwareInfo softwareInfo driverInfo}
  proc 7443::version_info {cardNumber} {
      set hardwareInfo [binary format s 0]
      set softwareInfo [binary format s 0]
      set driverInfo   [binary format s 0]

      set result [_version_info $cardNumber hardwareInfo softwareInfo driverInfo]

      binary scan $hardwareInfo s hi
      binary scan $softwareInfo s si
      binary scan $driverInfo   s di

      return [list $result $hi $si $di]
  }

• Home
• Recent changes
• Help
• WhoAmI/Logout
• Create new page
• Random page
• 
  
• Add comments
• Edit
• History
• Edit summary
• References