Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Add branches, tags, and trunk directories and move the source into trunk

git-svn-id: svn://rubyforge.org/var/svn/tcl/trunk@2 017b7ecb-b1d0-4998-98d6-e9014aaf4887
  • Loading branch information...
commit 4d42a87268d36734a37d2c12cd33b8767554f3d3 0 parents
@sstephenson sstephenson authored
18 Rakefile
@@ -0,0 +1,18 @@
+require "rake/testtask"
+require "rcov/rcovtask"
+
+task :default => "test"
+task :test => "test:units"
+
+namespace :test do
+ Rake::TestTask.new(:units) do |t|
+ t.test_files = FileList["test/**/*_test.rb"]
+ t.verbose = true
+ end
+
+ Rcov::RcovTask.new(:coverage) do |t|
+ t.test_files = FileList["test/**/*_test.rb"]
+ t.verbose = true
+ t.rcov_opts << "-x 'rcov\.rb$'"
+ end
+end
7 lib/tcl.rb
@@ -0,0 +1,7 @@
+$:.unshift File.dirname(__FILE__)
+
+require File.join(File.dirname(__FILE__), *%w".. src tcl")
+require "tcl/interp_helper"
+require "tcl/interp"
+require "tcl/proc"
+require "tcl/var"
42 lib/tcl/interp.rb
@@ -0,0 +1,42 @@
+module Tcl
+ class Interp
+ include InterpHelper
+
+ class << self
+ def load_from_file(filename)
+ interp = new
+ interp.eval(IO.read(filename))
+ interp
+ end
+ end
+
+ def interp
+ self
+ end
+
+ def proc(name)
+ Tcl::Proc.new(self, name)
+ end
+
+ def var(name)
+ Tcl::Var.find(self, name)
+ end
+
+ def procs
+ list_to_array _!(:info, :procs)
+ end
+
+ def vars
+ list_to_array _!(:info, :vars)
+ end
+
+ def to_tcl
+ %w( var proc ).inject([]) do |lines, type|
+ send("#{type}s").sort.each do |name|
+ lines << send(type, name).to_tcl
+ end
+ lines
+ end.join("\n")
+ end
+ end
+end
25 lib/tcl/interp_helper.rb
@@ -0,0 +1,25 @@
+module Tcl
+ module InterpHelper
+ def self.included(klass)
+ klass.class_eval do
+ attr_reader :interp
+ end
+ end
+
+ def _(*args)
+ interp.array_to_list(args)
+ end
+
+ def _!(*args)
+ interp.eval(_(*args))
+ end
+
+ def method_missing(name, *args, &block)
+ if interp.respond_to?(name)
+ interp.send(name, *args, &block)
+ else
+ super
+ end
+ end
+ end
+end
40 lib/tcl/proc.rb
@@ -0,0 +1,40 @@
+module Tcl
+ class Proc
+ include InterpHelper
+
+ attr_reader :name
+
+ def initialize(interp, name)
+ @interp = interp
+ @name = name.to_s
+ to_tcl
+ end
+
+ def arguments
+ list_to_array(_!(:info, :args, name)).map do |argument_name|
+ begin
+ variable_name = "__Tcl_Proc_arguments_#{name}_#{argument_name}"
+ if _!(:info, :default, name, argument_name, variable_name) == "0"
+ argument_name
+ else
+ _(argument_name, var(variable_name).value)
+ end
+ ensure
+ _!(:unset, variable_name)
+ end
+ end
+ end
+
+ def body
+ _!(:info, :body, name)
+ end
+
+ def call(*args)
+ _!(name, *args.map { |arg| arg.to_s })
+ end
+
+ def to_tcl
+ _(:proc, name, _(*arguments), body)
+ end
+ end
+end
45 lib/tcl/var.rb
@@ -0,0 +1,45 @@
+module Tcl
+ class Var
+ include InterpHelper
+
+ class << self
+ def find(interp, name)
+ StringVar.new(interp, name)
+ rescue Tcl::Error => e
+ if e.message["variable is array"]
+ ArrayVar.new(interp, name)
+ else
+ raise
+ end
+ end
+ end
+
+ attr_reader :name
+
+ def initialize(interp, name)
+ @interp = interp
+ @name = name.to_s
+ to_tcl
+ end
+ end
+
+ class StringVar < Var
+ def value
+ _!(:set, name)
+ end
+
+ def to_tcl
+ _(:set, name, value)
+ end
+ end
+
+ class ArrayVar < Var
+ def value
+ _!(:array, :get, name)
+ end
+
+ def to_tcl
+ _(:array, :set, name, value)
+ end
+ end
+end
3  src/extconf.rb
@@ -0,0 +1,3 @@
+require "mkmf"
+have_library("tcl")
+create_makefile("tcl")
112 src/tcl.c
@@ -0,0 +1,112 @@
+#include <ruby.h>
+#include <tcl.h>
+
+typedef struct {
+ Tcl_Interp *interp;
+} tcl_interp_struct;
+
+static VALUE rb_value_to_s(VALUE value) {
+ return rb_funcall(value, rb_intern("to_s"), 0, 0);
+}
+
+void rb_tcl_interp_destroy(tcl_interp_struct *tcl_interp) {
+ Tcl_DeleteInterp(tcl_interp->interp);
+ Tcl_Release(tcl_interp->interp);
+ free(tcl_interp);
+}
+
+static VALUE rb_tcl_interp_allocate(VALUE klass) {
+ tcl_interp_struct *tcl_interp;
+ VALUE obj = Data_Make_Struct(klass, tcl_interp_struct, NULL, rb_tcl_interp_destroy, tcl_interp);
+
+ tcl_interp->interp = Tcl_CreateInterp();
+ Tcl_Init(tcl_interp->interp);
+ Tcl_Preserve(tcl_interp->interp);
+
+ return obj;
+}
+
+static VALUE rb_tcl_safe_interp_allocate(VALUE klass) {
+ VALUE obj = rb_tcl_interp_allocate(klass);
+
+ tcl_interp_struct *tcl_interp;
+ Data_Get_Struct(obj, tcl_interp_struct, tcl_interp);
+
+ Tcl_MakeSafe(tcl_interp->interp);
+
+ return obj;
+}
+
+static VALUE rb_tcl_interp_eval(VALUE self, VALUE script) {
+ VALUE error_class = rb_const_get(rb_const_get(rb_cObject, rb_intern("Tcl")), rb_intern("Error"));
+
+ tcl_interp_struct *tcl_interp;
+ Data_Get_Struct(self, tcl_interp_struct, tcl_interp);
+
+ int result = Tcl_Eval(tcl_interp->interp, RSTRING(rb_value_to_s(script))->ptr);
+
+ switch (result) {
+ case TCL_OK:
+ return rb_tainted_str_new2(tcl_interp->interp->result);
+ case TCL_ERROR:
+ rb_raise(error_class, "%s", tcl_interp->interp->result);
+ default:
+ return Qnil;
+ }
+}
+
+static VALUE rb_tcl_interp_list_to_array(VALUE self, VALUE list) {
+ tcl_interp_struct *tcl_interp;
+ Data_Get_Struct(self, tcl_interp_struct, tcl_interp);
+
+ Tcl_Obj *string = Tcl_NewStringObj(RSTRING(rb_value_to_s(list))->ptr, -1);
+
+ int list_length, i;
+ Tcl_Obj **elements;
+
+ if (Tcl_ListObjGetElements(tcl_interp->interp, string, &list_length, &elements) != TCL_OK)
+ return Qnil;
+
+ VALUE result = rb_ary_new2(list_length);
+
+ for (i = 0; i < list_length; i++) {
+ int element_length;
+ const char *element;
+
+ element = Tcl_GetStringFromObj(elements[i], &element_length);
+ rb_ary_push(result, element ? rb_tainted_str_new(element, element_length) : rb_str_new2(""));
+ }
+
+ return result;
+}
+
+static VALUE rb_tcl_interp_array_to_list(VALUE self, VALUE array) {
+ tcl_interp_struct *tcl_interp;
+ Data_Get_Struct(self, tcl_interp_struct, tcl_interp);
+
+ int array_length = NUM2INT(rb_funcall(array, rb_intern("length"), 0, 0)), i;
+
+ Tcl_Obj *list = Tcl_NewObj();
+
+ for (i = 0; i < array_length; i++) {
+ VALUE element = rb_ary_entry(array, i);
+ Tcl_Obj *string = Tcl_NewStringObj(RSTRING(rb_value_to_s(element))->ptr, -1);
+
+ Tcl_ListObjAppendElement(tcl_interp->interp, list, string);
+ }
+
+ return rb_tainted_str_new2(Tcl_GetStringFromObj(list, NULL));
+}
+
+void Init_tcl() {
+ VALUE tcl_module = rb_define_module("Tcl");
+ VALUE interp_class = rb_define_class_under(tcl_module, "Interp", rb_cObject);
+ VALUE safe_interp_class = rb_define_class_under(tcl_module, "SafeInterp", interp_class);
+ VALUE error_class = rb_define_class_under(tcl_module, "Error", rb_eStandardError);
+
+ rb_define_alloc_func(interp_class, rb_tcl_interp_allocate);
+ rb_define_alloc_func(safe_interp_class, rb_tcl_safe_interp_allocate);
+ rb_define_method(interp_class, "eval", rb_tcl_interp_eval, 1);
+ rb_define_method(interp_class, "list_to_array", rb_tcl_interp_list_to_array, 1);
+ rb_define_method(interp_class, "array_to_list", rb_tcl_interp_array_to_list, 1);
+}
6 test/fixtures/test.tcl
@@ -0,0 +1,6 @@
+set a 0
+set b(a) 1
+set b(b) 2
+proc c args return
+proc d {a {b 0}} {return $b}
+proc e {} {}
102 test/interp_test.rb
@@ -0,0 +1,102 @@
+require File.join(File.dirname(__FILE__), "test_helper")
+
+class InterpTest < Test::Unit::TestCase
+ def setup
+ @interp = Tcl::Interp.new
+ end
+
+ def test_load_from_file
+ vars, procs = @interp.vars, @interp.procs
+ @interp = Tcl::Interp.load_from_file(path_to_fixture("test.tcl"))
+
+ assert_equal ["a", "b"], (@interp.vars - vars).sort
+ assert_equal ["c", "d", "e"], (@interp.procs - procs).sort
+ end
+
+ def test_eval
+ assert_equal "", @interp.eval("")
+ assert_equal "0", @interp.eval("return 0")
+ assert_equal "", @interp.eval("return \"\"")
+ assert_equal "", @interp.eval("return {}")
+ assert_equal " ", @interp.eval("return \" \"")
+ end
+
+ def test_eval_raises_on_tcl_exception
+ assert_raises(Tcl::Error) { @interp.eval("nonexistent") }
+ assert_raises(Tcl::Error) { @interp.eval("{") }
+ assert_raises(Tcl::Error) { @interp.eval("error") }
+ end
+
+ def test_array_to_list
+ assert_equal "", @interp.array_to_list([])
+ assert_equal "{}", @interp.array_to_list([nil])
+ assert_equal "{}", @interp.array_to_list([""])
+ assert_equal "one", @interp.array_to_list(["one"])
+ assert_equal "one two", @interp.array_to_list(["one", "two"])
+ assert_equal "a { b} c", @interp.array_to_list(["a", " b", "c"])
+ assert_equal "\\{", @interp.array_to_list(["{"])
+ assert_equal "{\"}", @interp.array_to_list(["\""])
+ end
+
+ def test_list_to_array
+ assert_equal [], @interp.list_to_array("")
+ assert_equal [""], @interp.list_to_array("{}")
+ assert_equal ["one"], @interp.list_to_array("one")
+ assert_equal ["one", "two"], @interp.list_to_array("one two")
+ assert_equal ["a", " b", "c"], @interp.list_to_array("a { b} c")
+ assert_equal ["a", " b", "c"], @interp.list_to_array("a \\ b c")
+ assert_equal ["{"], @interp.list_to_array("\\{")
+ assert_equal ["["], @interp.list_to_array("\\[")
+ assert_equal ["\""], @interp.list_to_array("\\\"")
+ end
+
+ def test_procs
+ @interp.clear!
+ assert_equal [], @interp.procs
+ @interp.eval "proc foo {} {}"
+ assert_equal ["foo"], @interp.procs
+ @interp.eval "proc bar {} {}"
+ assert_equal ["bar", "foo"], @interp.procs.sort
+ end
+
+ def test_vars
+ @interp.clear!
+ assert_equal [], @interp.vars
+ @interp.eval "set a 0"
+ assert_equal ["a"], @interp.vars
+ @interp.eval "set b(a) 0"
+ assert_equal ["a", "b"], @interp.vars.sort
+ end
+
+ def test_proc
+ assert_raises(Tcl::Error) { @interp.proc("foo") }
+ @interp.eval "proc foo {} {}"
+ proc = @interp.proc("foo")
+ assert proc.is_a?(Tcl::Proc)
+ assert_equal "foo", proc.name
+ end
+
+ def test_var
+ assert_raises(Tcl::Error) { @interp.var("foo") }
+ @interp.eval "set foo bar"
+ var = @interp.var("foo")
+ assert var.is_a?(Tcl::Var)
+ assert_equal "foo", var.name
+ end
+
+ def test_to_tcl
+ @interp.clear!
+ @interp.eval IO.read(path_to_fixture("test.tcl"))
+ assert_equal <<-EOF.chomp, @interp.to_tcl
+set a 0
+array set b {a 1 b 2}
+proc c args return
+proc d {a {b 0}} {return $b}
+proc e {} {}
+ EOF
+ end
+
+ def test_interp_helper_method_missing_super_passthrough
+ assert_raises(NoMethodError) { @interp.nonexistent }
+ end
+end
42 test/proc_test.rb
@@ -0,0 +1,42 @@
+require File.join(File.dirname(__FILE__), "test_helper")
+
+class ProcTest < Test::Unit::TestCase
+ def setup
+ @interp = Tcl::Interp.load_from_file(path_to_fixture("test.tcl"))
+ end
+
+ def test_proc_arguments_for_proc_with_no_arguments
+ assert_equal [], @interp.proc("e").arguments
+ end
+
+ def test_proc_arguments_for_proc_with_one_argument
+ assert_equal ["args"], @interp.proc("c").arguments
+ end
+
+ def test_proc_arguments_for_proc_with_default_argument
+ assert_equal ["a", "b 0"], @interp.proc("d").arguments
+ end
+
+ def test_proc_body
+ assert_equal "return", @interp.proc("c").body
+ assert_equal "return $b", @interp.proc("d").body
+ assert_equal "", @interp.proc("e").body
+ end
+
+ def test_proc_call
+ assert_equal "", @interp.proc("c").call
+ assert_equal "0", @interp.proc("d").call("a")
+ assert_equal "b", @interp.proc("d").call("a", "b")
+ assert_equal "", @interp.proc("e").call
+ end
+
+ def test_proc_call_raises_on_missing_argument
+ assert_raises(Tcl::Error) { @interp.proc("d").call }
+ end
+
+ def test_proc_to_tcl
+ assert_equal "proc c args return", @interp.proc("c").to_tcl
+ assert_equal "proc d {a {b 0}} {return $b}", @interp.proc("d").to_tcl
+ assert_equal "proc e {} {}", @interp.proc("e").to_tcl
+ end
+end
15 test/test_helper.rb
@@ -0,0 +1,15 @@
+require "test/unit"
+require File.join(File.dirname(__FILE__), *%w".. lib tcl")
+
+class Tcl::Interp
+ def clear!
+ procs.each { |p| _! :rename, p, "" }
+ vars.each { |v| _! :unset, v }
+ end
+end
+
+class Test::Unit::TestCase
+ def path_to_fixture(*path_pieces)
+ File.join(File.dirname(__FILE__), "fixtures", *path_pieces)
+ end
+end
39 test/var_test.rb
@@ -0,0 +1,39 @@
+require File.join(File.dirname(__FILE__), "test_helper")
+
+class VarTest < Test::Unit::TestCase
+ def setup
+ @interp = Tcl::Interp.load_from_file(path_to_fixture("test.tcl"))
+ end
+
+ def test_var_find_raises_when_var_does_not_exist
+ assert_raises(Tcl::Error) { Tcl::Var.find(@interp, "nonexistent") }
+ end
+
+ def test_var_find_returns_string_var
+ var = Tcl::Var.find(@interp, "a")
+ assert_equal "a", var.name
+ assert var.is_a?(Tcl::StringVar)
+ end
+
+ def test_var_find_returns_array_var
+ var = Tcl::Var.find(@interp, "b")
+ assert_equal "b", var.name
+ assert var.is_a?(Tcl::ArrayVar)
+ end
+
+ def test_string_var_value
+ assert_equal "0", @interp.var("a").value
+ end
+
+ def test_array_var_value
+ assert_equal "a 1 b 2", @interp.var("b").value
+ end
+
+ def test_string_var_to_tcl
+ assert_equal "set a 0", @interp.var("a").to_tcl
+ end
+
+ def test_array_var_to_tcl
+ assert_equal "array set b {a 1 b 2}", @interp.var("b").to_tcl
+ end
+end
Please sign in to comment.
Something went wrong with that request. Please try again.