def install_bind_for_event_class(klass, cmd, *args)
extra_args_tbl = klass._get_extra_args_tbl
if args.compact.size > 0
args.map!{|arg| klass._sym2subst(arg)}
args = args.join(' ')
keys = klass._get_subst_key(args)
if cmd.kind_of?(String)
id = cmd
elsif cmd.kind_of?(TkCallbackEntry)
id = install_cmd(cmd)
else
id = install_cmd(proc{|*arg|
ex_args = []
extra_args_tbl.reverse_each{|conv| ex_args << conv.call(arg.pop)}
begin
TkUtil.eval_cmd(cmd, *(ex_args.concat(klass.scan_args(keys, arg))))
rescue Exception=>e
if TkCore::INTERP.kind_of?(TclTkIp)
fail e
else
fail Exception, "#{e.class}: #{e.message.dup}"
end
end
})
end
elsif cmd.respond_to?(:arity) && cmd.arity == 0
args = ''
if cmd.kind_of?(String)
id = cmd
elsif cmd.kind_of?(TkCallbackEntry)
id = install_cmd(cmd)
else
id = install_cmd(proc{
begin
TkUtil.eval_cmd(cmd)
rescue Exception=>e
if TkCore::INTERP.kind_of?(TclTkIp)
fail e
else
fail Exception, "#{e.class}: #{e.message.dup}"
end
end
})
end
else
keys, args = klass._get_all_subst_keys
if cmd.kind_of?(String)
id = cmd
elsif cmd.kind_of?(TkCallbackEntry)
id = install_cmd(cmd)
else
id = install_cmd(proc{|*arg|
ex_args = []
extra_args_tbl.reverse_each{|conv| ex_args << conv.call(arg.pop)}
begin
TkUtil.eval_cmd(cmd, *(ex_args << klass.new(*klass.scan_args(keys, arg))))
rescue Exception=>e
if TkCore::INTERP.kind_of?(TclTkIp)
fail e
else
fail Exception, "#{e.class}: #{e.message.dup}"
end
end
})
end
end
if TkCore::INTERP.kind_of?(TclTkIp)
id + ' ' + args
else
"if {[set st [catch {#{id} #{args}} ret]] != 0} {
if {$st == 4} {
return -code continue $ret
} elseif {$st == 3} {
return -code break $ret
} elseif {$st == 2} {
return -code return $ret
} elseif {[regexp {^Exception: (TkCallbackContinue: .*)$} \
$ret m msg]} {
return -code continue $msg
} elseif {[regexp {^Exception: (TkCallbackBreak: .*)$} $ret m msg]} {
return -code break $msg
} elseif {[regexp {^Exception: (TkCallbackReturn: .*)$} $ret m msg]} {
return -code return $msg
} elseif {[regexp {^Exception: (\\S+: .*)$} $ret m msg]} {
return -code return $msg
} else {
return -code error $ret
}
} else {
set ret
}"
end
end