ffi-tk 2009.11.29

data/lib/ffi-tk/ffi/tcl/interp.rb

@@ -0,0 +1,95 @@
+module FFI
+  module Tcl
+    class Interp < PrettyStruct
+      layout(
+        :result, :string,
+        :freeProc, :pointer,
+        :errorLine, :int
+      )
+
+      def inspect
+        "Interp"
+      end
+
+      def guess_result
+        EvalResult.guess(self, Obj.new(Tcl.get_obj_result(self)))
+      end
+
+      def obj_result
+        Obj.new(Tcl.get_obj_result(self))
+      end
+
+      def obj_result=(ruby_obj)
+        obj =
+          case ruby_obj
+          when true
+            Tcl.new_boolean_obj(1)
+          when false
+            Tcl.new_boolean_obj(0)
+          when String
+            Tcl.new_string_obj(ruby_obj, ruby_obj.bytesize)
+          when Fixnum
+            Tcl.new_int_obj(ruby_obj)
+          else
+            if ruby_obj.respond_to?(:to_tcl)
+              ruby_obj.to_tcl
+            else
+              raise ArgumentError, "Don't know how to set %p automatically" % [ruby_obj]
+            end
+          end
+
+        Tcl.set_obj_result(self, obj)
+      end
+
+      def wait_for_event(seconds = 0.0)
+        if seconds && seconds > 0.0
+          seconds, microseconds = (seconds * 1000).divmod(1000)
+          time = TclTime.new(seconds, microseconds)
+        else
+          time = nil
+        end
+
+        Tcl.wait_for_event(time)
+      end
+
+      def do_one_event(flag = 0)
+        Tcl.do_one_event(flag)
+      end
+
+      def do_events_until(flag = 0)
+        begin
+          wait_for_event(0.1)
+          Tcl.do_one_event(flag)
+        end until yield
+      end
+
+      def do_events_while(flag = 0)
+        begin
+          wait_for_event(0.1)
+          Tcl.do_one_event(flag)
+        end while yield
+      end
+
+      def eval(string)
+        if $DEBUG
+          if string =~ /\n/
+            puts "eval: %p" % [string]
+          else
+            puts "eval: %s" % [string]
+          end
+        end
+
+        code = Tcl.eval_ex(self, string, string.bytesize, 0x40000)
+        return true if code == 0
+
+        message = guess_result.to_s
+
+        if message.empty?
+          raise 'Failure during eval of: %p' % [string]
+        else
+          raise '%s during eval of: %p' % [message, string]
+        end
+      end
+    end
+  end
+end

data/lib/ffi-tk/ffi/tcl/obj.rb

@@ -0,0 +1,89 @@
+module FFI
+  module Tcl
+    # Nicer introspection and some accessors.
+    class PrettyStruct < FFI::Struct
+      ACCESSOR_CODE = <<-CODE
+        def {name}; self[{sym}]; end
+        def {name}=(value) self[{sym}] = value; end
+      CODE
+
+      def self.layout(*kvs)
+        kvs.each_slice(2) do |key, value|
+          eval ACCESSOR_CODE.gsub(/\{(.*?)\}/, '{name}' => key, '{sym}' => ":#{key}")
+        end
+
+        super
+      end
+
+      def inspect
+        kvs = members.zip(values)
+        kvs.map!{|key, value| "%s=%s" % [key, value.inspect] }
+        "<%s %s>" % [self.class, kvs.join(' ')]
+      end
+    end
+
+    # The following structure represents a type of object, which is a particular
+    # internal representation for an object plus a set of functions that provide
+    # standard operations on objects of that type.
+    class ObjType < PrettyStruct
+      layout(
+        :name,                   :string,
+        :free_internal_rep_proc, :pointer,
+        :dup_internal_rep_proc,  :pointer,
+        :update_string_proc,     :pointer,
+        :set_from_any_proc,      :pointer
+      )
+
+      def to_i
+        pointer.get_pointer(0).to_i
+      end
+
+      def inspect
+        "#<ObjType name=%p>" % [self[:name]]
+      end
+    end
+
+    class Obj < PrettyStruct
+      class InternalRep < Union
+        class TwoPtrValue < PrettyStruct
+          layout(
+            :ptr1, :pointer,
+            :ptr2, :pointer
+          )
+        end
+
+        class PtrAndLongRep < PrettyStruct
+          layout(
+            :ptr,   :pointer,
+            :value, :ulong
+          )
+        end
+
+        layout(
+          :longValue,     :long,
+          :doubleValue,   :double,
+          :otherValuePtr, :pointer,
+          :wideValue,     :int64,
+          :twoPtrValue,   TwoPtrValue,
+          :ptrAndLongRep, PtrAndLongRep
+        )
+      end
+
+      layout(
+        :refCount,    :int,
+        :bytes,       :string,
+        :length,      :int,
+        :type,        ObjType,
+        :internalRep, InternalRep
+      )
+
+      def pretty_type
+        EvalResult::TYPES[type.to_i]
+      end
+
+      def inspect
+        "#<Obj bytes=%p type=%p>" % [self[:bytes], pretty_type]
+      end
+    end
+  end
+end

data/lib/ffi-tk/ffi/tcl/time.rb

@@ -0,0 +1,36 @@
+module FFI
+  module Tcl
+    class TclTime < PrettyStruct
+      layout(
+        :sec,  :long, # Seconds
+        :usec, :long  # Microseconds
+      )
+
+      def initialize(seconds = nil, microseconds = nil)
+        super()
+        self[:sec] = seconds.to_i if seconds
+        self[:usec] = microseconds.to_i if microseconds
+      end
+
+      def seconds
+        self[:sec]
+      end
+      alias sec seconds
+
+      def microseconds
+        self[:usec]
+      end
+      alias usec microseconds
+
+      def seconds=(seconds)
+        self[:sec] = seconds
+      end
+      alias sec= seconds=
+
+      def microseconds=(microseconds)
+        self[:usec] = microseconds
+      end
+      alias usec= microseconds=
+    end
+  end
+end

data/lib/ffi-tk/ffi/tk.rb

@@ -0,0 +1,35 @@
+module FFI
+  module Tk
+    extend FFI::Library
+    ffi_lib 'libtk8.5.so', 'libtk.so', *::Tk::LIBPATH[:tk]
+
+    attach_function :Tk_Init, [:pointer], :int
+    attach_function :Tk_MainLoop, [], :void
+
+    module_function
+
+    def mainloop
+      if ::Tk::RUN_EVENTLOOP_ON_MAIN_THREAD
+        Tk_MainLoop()
+      else
+        Tcl.thread_sender.thread_send{ Tk_MainLoop() }
+      end
+    end
+
+    def init(interp)
+      if ::Tk::RUN_EVENTLOOP_ON_MAIN_THREAD
+        if Tk_Init(interp) == 1
+          message = Tcl.Tcl_GetStringResult(interp)
+          raise RuntimeError, message
+        end
+      else
+        Tcl.thread_sender.thread_send do
+          if Tk_Init(interp) == 1
+            message = Tcl.Tcl_GetStringResult(interp)
+            raise RuntimeError, message
+          end
+        end
+      end
+    end
+  end
+end

data/lib/ffi-tk/geometry.rb

@@ -0,0 +1,32 @@
+module Tk
+  class TkGeometry < Struct.new(:original, :width, :height, :x, :y)
+    def initialize(tcl_string)
+      case tcl_string.to_s
+      when /^\=?(?<width>\d+)x(?<height>\d+)(?<x>[+-]\d+)(?<y>[+-]\d+)$/
+        md = $~
+        self.width, self.height, self.x, self.y =
+          md[:width].to_i, md[:height].to_i, md[:x].to_i, md[:y].to_i
+      when /^\=?(?<width>\d+)x(?<height>\d+)$/
+        md = $~
+        self.width, self.height = md[:width].to_i, md[:height].to_i
+      when /^\=?(?<x>[+-]\d+)(?<y>[+-]\d+)$/
+        md = $~
+        self.x, self.y = md[:x].to_i, md[:y].to_i
+      else
+        raise "Invalid geometry: %p" % [tcl_string]
+      end
+    end
+
+    def to_tcl
+      if width && height && x && y
+        "=%dx%d%+d%+d" % [width, height, x, y]
+      elsif width && height
+        "=%dx%d%" % [width, height]
+      elsif x && y
+        "=+d%+d" % [x, y]
+      else
+        raise "Incomplete geometry: %p" % [self]
+      end
+    end
+  end
+end

data/lib/ffi-tk/thread_sender.rb

@@ -0,0 +1,26 @@
+class ThreadSender
+  def initialize
+    @queue = Queue.new
+    @thread = Thread.new{ reaper }
+  end
+
+  def reaper
+    loop do
+      block, response_queue = *@queue.pop
+      response_queue.push(block.call)
+    end
+  end
+
+  # If callbacks are invoked within a thread_send, we process them inside the
+  # same thread.
+  # Calling pop on the queue would cause deadlocks.
+  def thread_send
+    if @thread == Thread.current
+      yield
+    else
+      response_queue = Queue.new
+      @queue.push([Proc.new, response_queue])
+      response_queue.pop
+    end
+  end
+end

data/lib/ffi-tk/tk.rb

@@ -0,0 +1,222 @@
+class Object
+  undef :type if respond_to?(:type)
+end
+
+module Tk
+  @register = Hash.new(0)
+  @widgets = {}
+  @callbacks = {}
+  @mutex = Mutex.new
+
+  class << self
+    attr_reader :callbacks, :widgets
+  end
+
+  module_function
+
+  unless const_defined?(:RUN_EVENTLOOP_ON_MAIN_THREAD)
+    # In some cases Tk has trouble running, this seems to happen on windows and
+    # OSX/TkAqua mostly.
+    # In these cases please use:
+    #   module Tk; RUN_EVENTLOOP_ON_MAIN_THREAD = true; end
+    # before you require 'tk'
+    RUN_EVENTLOOP_ON_MAIN_THREAD = false
+  end
+
+  def init
+    if RUN_EVENTLOOP_ON_MAIN_THREAD
+      @interp = FFI::Tcl.setup_eventloop_on_main_thread
+    else
+      @interp = FFI::Tcl.setup_eventloop_on_new_thread
+    end
+
+    FFI::Tcl.init(@interp)
+    FFI::Tcl::EvalResult.reset_types(@interp)
+    FFI::Tk.init(@interp)
+
+    @root = Root.new
+
+    @interp.eval('namespace eval RubyFFI {}')
+
+    FFI::Tcl.create_obj_command(@interp, 'RubyFFI::callback', TCL_CALLBACK, 0, TCL_DELETE)
+    FFI::Tcl.create_obj_command(@interp, 'RubyFFI::event',    TCL_EVENT,    0, TCL_DELETE)
+
+    module_eval('class << Tk; attr_reader :interp, :root; end')
+
+    return @interp
+  end
+
+  # A little something so people don't have to call Tk.init
+  def interp
+    Tk.init
+    @interp
+  end
+
+  # A little something so people don't have to call Tk.init
+  def root
+    Tk.init
+    @root
+  end
+
+  def mainloop
+    @running = true
+
+    while @running && interp.wait_for_event(0.1)
+      interp.do_one_event(0)
+    end
+  end
+
+  def stop
+    @running = false
+  end
+
+  def eval(string)
+    interp.eval(string)
+  end
+
+  def execute_only(*args)
+    interp.eval(convert_arguments(*args))
+  end
+
+  def execute(*args)
+    interp.eval(convert_arguments(*args))
+    result
+  end
+
+  def result
+    interp.guess_result
+  end
+
+  def exit
+    execute('exit')
+  end
+
+  def callback_break
+    throw :callback_break
+  end
+
+  def callback_continue
+    throw :callback_continue
+  end
+
+  # without our callbacks, nothing goes anymore, abort mission
+  def tcl_delete(client_data)
+    raise RuntimeError, "tcl function is going to be removed"
+  end
+  TCL_DELETE = method(:tcl_delete)
+
+  # TODO: support for break and continue return status (by catch/throw)
+  # 1 means true, 0 means false.
+  def tcl_callback(client_data, interp, objc, objv)
+    cmd, id, *args = tcl_cmd_args(interp, objc, objv)
+    id = id.first if id.is_a?(Array)
+
+    catch :callback_break do
+      catch :callback_continue do
+        result = handle_callback(id, *args)
+        FFI::Tcl::Interp.new(interp).obj_result = result
+
+        return OK
+      end
+
+      return CONTINUE
+    end
+
+    return BREAK
+  rescue => ex
+    FFI::Tcl::Interp.new(interp).obj_result = ex.message
+    return ERROR
+  end
+  TCL_CALLBACK = method(:tcl_callback)
+
+  # TODO: support for break and continue return status (by catch/throw)
+  def tcl_event(client_data, interp, objc, objv)
+    cmd, id, sequence, *args = tcl_cmd_args(interp, objc, objv)
+
+    catch :callback_break do
+      catch :callback_continue do
+        Event::Data.new(id.to_i, sequence.to_s, *args).call
+
+        return OK
+      end
+
+      return CONTINUE
+    end
+
+    return BREAK
+  rescue => ex
+    FFI::Tcl::Interp.new(interp).obj_result = ex.message
+    return ERROR
+  end
+  TCL_EVENT = method(:tcl_event)
+
+  def tcl_cmd_args(interp, objc, objv)
+    length = FFI::MemoryPointer.new(0)
+    array = objv.read_array_of_pointer(objc)
+    array.map{|e|
+      obj = FFI::Tcl::EvalResult.guess(interp, e)
+      case obj
+      when Fixnum, Float
+        obj
+      else
+        obj.respond_to?(:dup) ? obj.dup : obj
+      end
+    }
+  end
+
+  def handle_callback(id, *args)
+    callback = @callbacks.fetch(id.to_i)
+    callback.call(*args)
+  end
+
+  def register_object(parent, object)
+    parent_name = parent.respond_to?(:tk_pathname) ? parent.tk_pathname : parent
+    cmd = object.class.tk_command
+
+    id = "#{cmd}#{uuid(cmd)}"
+    pathname = [parent_name, id].join('.').squeeze('.')
+    @widgets[pathname] = object
+
+    return pathname
+  end
+
+  def unregister_object(object)
+    @widgets.delete_if{|path, obj| obj == object }
+  end
+
+  def unregister_objects(*objects)
+    @widgets.delete_if{|path, obj| objects.include?(obj) }
+  end
+
+  def register_proc(proc, argument_string = '')
+    id = uuid(:proc){|uuid| @callbacks[uuid] = proc }
+    return id, %(RubyFFI::callback #{id} #{argument_string})
+  end
+
+  def unregister_proc(id)
+    @callbacks.delete(id)
+  end
+
+  def uuid(name)
+    @mutex.synchronize do
+      id = @register[name]
+      @register[name] += 1
+      yield id if block_given?
+      id
+    end
+  end
+
+  def boolean(obj)
+    boolean_pointer = FFI::MemoryPointer.new(:int)
+    FFI::Tcl.get_boolean(interp, obj.to_s, boolean_pointer)
+    boolean_pointer.get_int(0) == 1
+  end
+
+  def convert_arguments(*args)
+    args.map(&:to_tcl).compact.join(' ')
+  end
+
+  def pathname_to_widget(pathname)
+    @widgets[pathname]
+  end
+end