* ext/tcltklib/tcltklib.c: fix SEGV

* ext/tk/lib/multi-tk.rb: improve safe-level handling of argument proc
* ext/tk/sample/multi-ip_sample.rb: rename of old 'safe-tk.rb'
* ext/tk/sample/safe-tk.rb: new sample script


git-svn-id: svn+ssh://ci.ruby-lang.org/ruby/trunk@6905 b2dd03c8-39d4-4d8f-98ff-823fe69b080e

5 files changed, 252 insertions, 116 deletions

diff --git a/ext/tcltklib/tcltklib.c b/ext/tcltklib/tcltklib.c
index 27305980df..6f7017c33d 100644
--- a/ext/tcltklib/tcltklib.c
+++ b/ext/tcltklib/tcltklib.c
@@ -64,7 +64,7 @@ fprintf(stderr, ARG1, ARG2); fprintf(stderr, "\n"); fflush(stderr); }
 #define DUMP2(ARG1, ARG2)
 */
 
-/* finalize_proc_name */
+/*finalize_proc_name */
 static char *finalize_hook_name = "INTERP_FINALIZE_HOOK";
 
 /* for callback break & continue */
@@ -629,7 +629,7 @@ lib_eventloop_core(check_root, update_flag, check_var)
     int update_flag;
     int *check_var;
 {
-    VALUE current = eventloop_thread;
+    volatile VALUE current = eventloop_thread;
     int found_event = 1;
     int event_flag;
     struct timeval t;
@@ -1321,6 +1321,7 @@ ip_ruby_eval(clientData, interp, argc, argv)
 #endif
     /* arg.failed = 0; */
     RARRAY(exception)->ptr[0] = Qnil;
+    RARRAY(exception)->len = 1;
     arg->failed = exception;
 
     /* evaluate the argument string by ruby */
@@ -1717,6 +1718,7 @@ ip_ruby_cmd(clientData, interp, argc, argv)
     rb_thread_critical = thr_crit_bup;
 
     RARRAY(exception)->ptr[0] = Qnil;
+    RARRAY(exception)->len = 1;
 
     arg->receiver = receiver;
     arg->method = method;
@@ -3878,9 +3880,11 @@ eval_queue_handler(evPtr, flags)
 	    rb_bug("cross-thread violation on eval_queue_handler()");
 	}
 #endif
+	/* q_dat = Data_Wrap_Struct(rb_cData,0,0,q); */
 	q_dat = Data_Wrap_Struct(rb_cData,eval_queue_mark,0,q);
 	ret = rb_funcall(rb_proc_new(evq_safelevel_handler, q_dat), 
 			 ID_call, 0);
+	rb_gc_force_recycle(q_dat);
     } else {
 	DUMP2("call eval_real (for caller thread:%lx)", q->thread);
 	DUMP2("call eval_real (current thread:%lx)", rb_thread_current());
@@ -3912,9 +3916,9 @@ ip_eval(self, str)
     char *eval_str;
     int  *alloc_done;
     int  thr_crit_bup;
-    VALUE current = rb_thread_current();
+    volatile VALUE current = rb_thread_current();
     volatile VALUE ip_obj = self;
-    volatile VALUE result = rb_ary_new2(1);
+    volatile VALUE result;
     volatile VALUE ret;
     Tcl_QueuePosition position;
 
@@ -3952,6 +3956,11 @@ ip_eval(self, str)
     /* allocate memory (freed by Tcl_ServiceEvent) */
     evq = (struct eval_queue *)Tcl_Alloc(sizeof(struct eval_queue));
 
+    /* allocate result obj */
+    result = rb_ary_new2(1);
+    RARRAY(result)->ptr[0] = Qnil;
+    RARRAY(result)->len = 1;
+
     /* construct event data */
     evq->done = alloc_done;
     evq->str = eval_str;
@@ -4772,9 +4781,11 @@ invoke_queue_handler(evPtr, flags)
 
     /* check safe-level */
     if (rb_safe_level() != q->safe_level) {
+	/* q_dat = Data_Wrap_Struct(rb_cData,0,0,q); */
 	q_dat = Data_Wrap_Struct(rb_cData,invoke_queue_mark,0,q);
 	ret = rb_funcall(rb_proc_new(ivq_safelevel_handler, q_dat), 
 			 ID_call, 0);
+	rb_gc_force_recycle(q_dat);
     } else {
 	DUMP2("call invoke_real (for caller thread:%lx)", q->thread);
 	DUMP2("call invoke_real (current thread:%lx)", rb_thread_current());
@@ -4810,10 +4821,9 @@ ip_invoke_with_position(argc, argv, obj, position)
     int  i;
     int  *alloc_done;
     int  thr_crit_bup;
-    VALUE v;
-    VALUE current = rb_thread_current();
+    volatile VALUE current = rb_thread_current();
     volatile VALUE ip_obj = obj;
-    volatile VALUE result = rb_ary_new2(1);
+    volatile VALUE result;
     volatile VALUE ret;
 
 #if TCL_MAJOR_VERSION >= 8
@@ -4853,6 +4863,11 @@ ip_invoke_with_position(argc, argv, obj, position)
     /* allocate memory (freed by Tcl_ServiceEvent) */
     ivq = (struct invoke_queue *)Tcl_Alloc(sizeof(struct invoke_queue));
 
+    /* allocate result obj */
+    result = rb_ary_new2(1);
+    RARRAY(result)->ptr[0] = Qnil;
+    RARRAY(result)->len = 1;
+
     /* construct event data */
     ivq->done = alloc_done;
     ivq->argc = argc;
diff --git a/ext/tk/MANIFEST b/ext/tk/MANIFEST
index efcb81babc..158c8dd5b9 100644
--- a/ext/tk/MANIFEST
+++ b/ext/tk/MANIFEST
@@ -267,6 +267,7 @@ sample/encstr_usage.rb
 sample/iso2022-kr.txt
 sample/menubar1.rb
 sample/menubar2.rb
+sample/multi-ip_sample.rb
 sample/optobj_sample.rb
 sample/propagate.rb
 sample/remote-ip_sample.rb
diff --git a/ext/tk/lib/multi-tk.rb b/ext/tk/lib/multi-tk.rb
index 0d82ce74b6..d54c6a5022 100644
--- a/ext/tk/lib/multi-tk.rb
+++ b/ext/tk/lib/multi-tk.rb
@@ -140,16 +140,17 @@ class MultiTkIp
   ######################################
 
   def set_safe_level(safe)
-    @safe_level[0] = safe
-    @cmd_queue.enq([@system, 'set_safe_level', safe])
-    self
+    if safe > @safe_level[0]
+      @safe_level[0] = safe
+      @cmd_queue.enq([@system, 'set_safe_level', safe])
+    end
+    @safe_level[0]
   end
   def safe_level=(safe)
     set_safe_level(safe)
   end
   def self.set_safe_level(safe)
     __getip.set_safe_level(safe)
-    self
   end
   def self.safe_level=(safe)
     self.set_safe_level(safe)
@@ -222,7 +223,8 @@ class MultiTkIp
 	else
 	  # procedure
 	  begin
-	    ret = proc{$SAFE = safe_level; cmd.call(*args)}.call
+	    #ret = proc{$SAFE = safe_level; cmd.call(*args)}.call
+	    ret = cmd.call(safe_level, *args)
 	  rescue SystemExit => e
 	    # delete IP
 	    unless @interp.deleted?
@@ -1183,7 +1185,10 @@ class MultiTkIp
 
   def cb_eval(cmd, *args)
     #self.eval_callback{ TkComm._get_eval_string(TkUtil.eval_cmd(cmd, *args)) }
-    ret = self.eval_callback{ TkComm._get_eval_string(TkUtil.eval_cmd(cmd, *args)) }
+    #ret = self.eval_callback{ TkComm._get_eval_string(TkUtil.eval_cmd(cmd, *args)) }
+    ret = self.eval_callback(*args){|safe, *params|
+      $SAFE=safe; TkComm._get_eval_string(TkUtil.eval_cmd(cmd, *params))
+    }
     if ret.kind_of?(Exception)
       raise ret 
     end
@@ -1268,9 +1273,7 @@ class MultiTkIp
   end
   private :eval_proc_core
 
-  #def eval_callback(cmd = proc{$SAFE=@safe_level[0]; Proc.new}.call, *args)
-  #  eval_proc_core(false, cmd, *args)
-  #end
+=begin
   def eval_callback(*args)
     if block_given?
       eval_proc_core(false, proc{$SAFE=@safe_level[0]; Proc.new}.call, *args)
@@ -1278,10 +1281,16 @@ class MultiTkIp
       eval_proc_core(false, *args)
     end
   end
+=end
+  def eval_callback(*args)
+    if block_given?
+      eval_proc_core(false, Proc.new, *args)
+    else
+      eval_proc_core(false, *args)
+    end
+  end
 
-  #def eval_proc(cmd = proc{$SAFE=@safe_level[0]; Proc.new}.call, *args)
-  #  eval_proc_core(true, cmd, *args)
-  #end
+=begin
   def eval_proc(*args)
     if block_given?
       eval_proc_core(true, proc{$SAFE=@safe_level[0]; Proc.new}.call, *args)
@@ -1289,15 +1298,34 @@ class MultiTkIp
       eval_proc_core(true, *args)
     end
   end
+=end
+  def eval_proc(*args)
+    if block_given?
+      cmd = Proc.new
+    else
+      unless (cmd = args.shift)
+	fail ArgumentError, "A Proc or Method object is expected for 1st argument"
+      end
+    end
+    eval_proc_core(true, 
+		   proc{|safe, *params| 
+		     $SAFE=safe; Thread.new(*params, &cmd).value
+		   },
+		   *args)
+  end
   alias call eval_proc
   alias eval_string eval_proc
 end
+
 class << MultiTkIp
   # class method
-  # def eval_proc(cmd = proc{$SAFE=__getip.safe_level; Proc.new}.call, *args)
-  #   # class ==> interp object
-  #   __getip.eval_proc(cmd, *args)
-  # end
+=begin
+  def eval_proc(cmd = proc{$SAFE=__getip.safe_level; Proc.new}.call, *args)
+    # class ==> interp object
+    __getip.eval_proc(cmd, *args)
+  end
+=end
+=begin
   def eval_proc(*args)
     # class ==> interp object
     if block_given?
@@ -1306,6 +1334,13 @@ class << MultiTkIp
       __getip.eval_proc(*args)
     end
   end
+=end
+#=begin
+  def eval_proc(*args, &blk)
+    # class ==> interp object
+    __getip.eval_proc(*args, &blk)
+  end
+#=end
   alias call eval_proc
   alias eval_string eval_proc
 end
diff --git a/ext/tk/sample/multi-ip_sample.rb b/ext/tk/sample/multi-ip_sample.rb
new file mode 100644
index 0000000000..2bb20db4c7
--- /dev/null
+++ b/ext/tk/sample/multi-ip_sample.rb
@@ -0,0 +1,102 @@
+#!/usr/bin/env ruby
+# This script is a sample of MultiTkIp class
+
+require "multi-tk"
+
+# create slave interpreters
+trusted_slave = MultiTkIp.new_slave
+safe_slave1   = MultiTkIp.new_safeTk
+safe_slave2   = MultiTkIp.new_safeTk('fill'=>:none, 'expand'=>false)
+#safe_slave2   = MultiTkIp.new_safeTk('fill'=>:none)
+#safe_slave2   = MultiTkIp.new_safeTk('expand'=>false)
+
+cmd = Proc.new{|txt|
+  #####################
+  ## from TkTimer2.rb
+
+  if TkCore::INTERP.safe?
+    # safeTk doesn't have permission to call 'wm' command
+  else
+    root = TkRoot.new(:title=>'timer sample')
+  end
+
+  label = TkLabel.new(:parent=>root, :relief=>:raised, :width=>10) \
+                  .pack(:side=>:bottom, :fill=>:both)
+
+  tick = proc{|aobj|
+    cnt = aobj.return_value + 5
+    label.text format("%d.%02d", *(cnt.divmod(100)))
+    cnt
+  }
+
+  timer = TkTimer.new(50, -1, tick).start(0, proc{ label.text('0.00'); 0 })
+
+=begin
+  TkButton.new(:text=>'Start') {
+    command proc{ timer.continue unless timer.running? }
+    pack(:side=>:left, :fill=>:both, :expand=>true)
+  }
+  TkButton.new(:text=>'Restart') {
+    command proc{ timer.restart(0, proc{ label.text('0.00'); 0 }) }
+    pack('side'=>'right','fill'=>'both','expand'=>'yes')
+  }
+  TkButton.new(:text=>'Stop') {
+    command proc{ timer.stop if timer.running? }
+    pack('side'=>'right','fill'=>'both','expand'=>'yes')
+  }
+=end
+  b_start = TkButton.new(:text=>'Start', :state=>:disabled) {
+    pack(:side=>:left, :fill=>:both, :expand=>true)
+  }
+  b_stop  = TkButton.new(:text=>'Stop', :state=>:normal) {
+    pack('side'=>'left', 'fill'=>'both', 'expand'=>'yes')
+  }
+
+  b_start.command {
+    timer.continue
+    b_stop.state(:normal)
+    b_start.state(:disabled)
+  }
+
+  b_stop.command {
+    timer.stop
+    b_start.state(:normal)
+    b_stop.state(:disabled)
+  }
+
+  TkButton.new(:text=>'Reset', :state=>:normal) {
+    command { timer.reset }
+    pack('side'=>'right', 'fill'=>'both', 'expand'=>'yes')
+  }
+
+  ev_quit = TkVirtualEvent.new('Control-c', 'Control-q')
+  Tk.root.bind(ev_quit, proc{Tk.exit}).focus
+}
+
+# call on the default master interpreter
+trusted_slave.eval_proc(cmd, 'trusted')  # label -> .w00012
+safe_slave1.eval_proc(cmd, 'safe1')      # label -> .w00016
+safe_slave2.eval_proc(cmd, 'safe2')      # label -> .w00020
+cmd.call('master')                       # label -> .w00024
+
+#second_master = MultiTkIp.new(&cmd)
+
+TkTimer.new(2000, -1, proc{p ['safe1', safe_slave1.deleted?]}).start
+TkTimer.new(2000, -1, proc{p ['safe2', safe_slave2.deleted?]}).start
+TkTimer.new(2000, -1, proc{p ['trusted', trusted_slave.deleted?]}).start
+
+TkTimer.new(5000, 1, 
+	    proc{
+	      safe_slave1.eval_proc{Tk.root.destroy}
+	      safe_slave1.delete
+	      print "*** The safe_slave1 is deleted by the timer.\n"
+	    }).start
+
+TkTimer.new(10000, 1, 
+	    proc{
+	      trusted_slave.eval_proc{Tk.root.destroy}
+	      trusted_slave.delete
+	      print "*** The trusted_slave is deleted by the timer.\n"
+	    }).start
+
+Tk.mainloop
diff --git a/ext/tk/sample/safe-tk.rb b/ext/tk/sample/safe-tk.rb
index a93707220e..1a8f0fc770 100644
--- a/ext/tk/sample/safe-tk.rb
+++ b/ext/tk/sample/safe-tk.rb
@@ -3,100 +3,83 @@
 
 require "multi-tk"
 
-# create slave interpreters
-trusted_slave = MultiTkIp.new_slave
-safe_slave1   = MultiTkIp.new_safeTk
-safe_slave2   = MultiTkIp.new_safeTk('fill'=>:none, 'expand'=>false)
-#safe_slave2   = MultiTkIp.new_safeTk('fill'=>:none)
-#safe_slave2   = MultiTkIp.new_safeTk('expand'=>false)
-
-cmd = Proc.new{|txt|
-  #####################
-  ## from TkTimer2.rb
-
-  if TkCore::INTERP.safe?
-    # safeTk doesn't have permission to call 'wm' command
-  else
-    root = TkRoot.new(:title=>'timer sample')
-  end
-
-  label = TkLabel.new(:parent=>root, :relief=>:raised, :width=>10) \
-                  .pack(:side=>:bottom, :fill=>:both)
-
-  tick = proc{|aobj|
-    cnt = aobj.return_value + 5
-    label.text format("%d.%02d", *(cnt.divmod(100)))
-    cnt
-  }
-
-  timer = TkTimer.new(50, -1, tick).start(0, proc{ label.text('0.00'); 0 })
-
-=begin
-  TkButton.new(:text=>'Start') {
-    command proc{ timer.continue unless timer.running? }
-    pack(:side=>:left, :fill=>:both, :expand=>true)
-  }
-  TkButton.new(:text=>'Restart') {
-    command proc{ timer.restart(0, proc{ label.text('0.00'); 0 }) }
-    pack('side'=>'right','fill'=>'both','expand'=>'yes')
-  }
-  TkButton.new(:text=>'Stop') {
-    command proc{ timer.stop if timer.running? }
-    pack('side'=>'right','fill'=>'both','expand'=>'yes')
-  }
-=end
-  b_start = TkButton.new(:text=>'Start', :state=>:disabled) {
-    pack(:side=>:left, :fill=>:both, :expand=>true)
-  }
-  b_stop  = TkButton.new(:text=>'Stop', :state=>:normal) {
-    pack('side'=>'left', 'fill'=>'both', 'expand'=>'yes')
-  }
-
-  b_start.command {
-    timer.continue
-    b_stop.state(:normal)
-    b_start.state(:disabled)
-  }
-
-  b_stop.command {
-    timer.stop
-    b_start.state(:normal)
-    b_stop.state(:disabled)
-  }
-
-  TkButton.new(:text=>'Reset', :state=>:normal) {
-    command { timer.reset }
-    pack('side'=>'right', 'fill'=>'both', 'expand'=>'yes')
-  }
-
-  ev_quit = TkVirtualEvent.new('Control-c', 'Control-q')
-  Tk.root.bind(ev_quit, proc{Tk.exit}).focus
+###############################
+
+TkLabel.new(:text=>'Default Master Ipnterpreter').pack(:padx=>5, :pady=>7)
+TkButton.new(:text=>'QUIT', :command=>proc{exit}).pack(:pady=>3)
+
+###############################
+
+puts "---- create a safe slave IP with Ruby's safe-level == 1 ----------"
+ip = MultiTkIp.new_safe_slave(1)
+
+puts "\n---- create procs ----------"
+puts 'x = proc{p [\'proc x\', "$SAFE==#{$SAFE}"]; exit}'
+x = proc{p ['proc x', "$SAFE==#{$SAFE}"]; exit}
+
+puts 'y = proc{|label| p [\'proc y\', "$SAFE==#{$SAFE}", label]; label.text($SAFE)}'
+y = proc{|label| p ['proc y', "$SAFE==#{$SAFE}", label]; label.text($SAFE)}
+
+puts 'z = proc{p [\'proc z\', "$SAFE==#{$SAFE}"]; exit}'
+z = proc{p ['proc z', "$SAFE==#{$SAFE}"]; exit}
+
+puts "\n---- call 1st eval_proc ----------"
+print 'lbl = '
+p lbl = ip.eval_proc{
+  TkLabel.new(:text=>"1st eval_prpc : $SAFE == #{$SAFE}").pack
+
+  f = TkFrame.new.pack
+  TkLabel.new(f, :text=>"$SAFE == ").pack(:side=>:left)
+  l = TkLabel.new(f).pack(:side=>:right)
+
+  TkButton.new(:text=>':command=>proc{l.text($SAFE)}', 
+	       :command=>proc{l.text($SAFE)}).pack(:fill=>:x, :padx=>5)
+  TkButton.new(:text=>':command=>x', :command=>x).pack(:fill=>:x, :padx=>5)
+  TkButton.new(:text=>':command=>proc{exit}', 
+	       :command=>proc{exit}).pack(:fill=>:x, :padx=>5)
+  TkFrame.new(:borderwidth=>2, :height=>3, 
+	      :relief=>:sunken).pack(:fill=>:x, :expand=>true,
+				     :padx=>10, :pady=>7)
+  l # return the label widget
+}
+
+puts "\n---- change the safe slave IP's safe-level ==> 3 ----------"
+ip.safe_level = 3
+
+puts "\n---- call 2nd eval_proc ----------"
+p ip.eval_proc(proc{
+		 TkLabel.new(:text=>"2nd eval_prpc : $SAFE == #{$SAFE}").pack
+		 f = TkFrame.new.pack
+		 TkLabel.new(f, :text=>"$SAFE == ").pack(:side=>:left)
+		 l = TkLabel.new(f, :text=>$SAFE).pack(:side=>:right)
+		 TkButton.new(:text=>':command=>proc{l.text($SAFE)}', 
+			      :command=>proc{l.text($SAFE)}).pack(:fill=>:x, 
+								  :padx=>5)
+		 TkButton.new(:text=>':command=>proc{y.call(l)}', 
+			      :command=>proc{y.call(l)}).pack(:fill=>:x, 
+							      :padx=>5)
+		 TkButton.new(:text=>':command=>proc{Thread.new(l, &y).value}',
+			      :command=>proc{
+				Thread.new(l, &y).value
+			      }).pack(:fill=>:x, :padx=>5)
+		 TkButton.new(:text=>':command=>proc{z.call}', 
+			      :command=>proc{z.call}).pack(:fill=>:x, :padx=>5)
+		 TkFrame.new(:borderwidth=>2, :height=>3, 
+			     :relief=>:sunken).pack(:fill=>:x, :expand=>true,
+						    :padx=>10, :pady=>7)
+	       })
+
+
+puts "\n---- change the safe slave IP's safe-level ==> 4 ----------"
+ip.safe_level = 4
+
+puts "\n---- call 3rd and 4th eval_proc ----------"
+p ip.eval_proc{ TkLabel.new(:text=>"3rd+ eval_prpc : $SAFE == #{$SAFE}").pack }
+p ip.eval_proc{
+  TkButton.new(:text=>':command=>proc{ lbl.text = $SAFE }', 
+	       :command=>proc{ lbl.text = $SAFE }).pack(:fill=>:x, :padx=>5)
 }
 
-# call on the default master interpreter
-trusted_slave.eval_proc(cmd, 'trusted')  # label -> .w00012
-safe_slave1.eval_proc(cmd, 'safe1')      # label -> .w00016
-safe_slave2.eval_proc(cmd, 'safe2')      # label -> .w00020
-cmd.call('master')                       # label -> .w00024
-
-#second_master = MultiTkIp.new(&cmd)
-
-TkTimer.new(2000, -1, proc{p ['safe1', safe_slave1.deleted?]}).start
-TkTimer.new(2000, -1, proc{p ['safe2', safe_slave2.deleted?]}).start
-TkTimer.new(2000, -1, proc{p ['trusted', trusted_slave.deleted?]}).start
-
-TkTimer.new(7000, 1, 
-	    proc{
-	      safe_slave1.eval_proc{Tk.root.destroy}
-	      safe_slave1.delete
-	      print "*** The safe_slave1 is deleted by the timer.\n"
-	    }).start
-
-TkTimer.new(10000, 1, 
-	    proc{
-	      trusted_slave.eval_proc{Tk.root.destroy}
-	      trusted_slave.delete
-	      print "*** The trusted_slave is deleted by the timer.\n"
-	    }).start
+puts "\n---- start event-loop ( current $SAFE == #{$SAFE} ) ----------"
 
 Tk.mainloop