Solved

Conert TCL to C

Posted on 2001-07-04
5
480 Views
Last Modified: 2008-02-20
At present we have a code written in TCL which connects to informics database, we want the same to be converted into C which connects to DB2.i have put down the different codes below, pls help me on this
URGENT.........


# rpcserv.tcl
# PROVIDE RPC Server Services
# Created: Wed Apr 10 09:16:40 EDT 1996
# Version 1.0
# Functions available:
# NONE
# Called from: /etc/inetd
#
proc docs {} {

Input Format:
      1-CHARACTER COMMAND CODE
      6-CHARACTER LENGTH OF DATA/COMMAND FOLLOWING (in ascii)
      DATA/COMMAND WITHOUT TRANSLATION (NO CR/LF etc.)

Output Format:
      1-CHARACTER COMMAND CODE
      6-CHARACTER LENGTH OF DATA/COMMAND FOLLOWING (in ascii)
      DATA/COMMAND WITHOUT TRANSLATION (NO CR/LF etc.)

Available Input Command Codes:
      SPACE            
            Evaluate Command as is
      P                  
            Set up a proxy server to server specified in data
            The syntax for the proxy server is
            mach1@mach2@mach3@mach4
            If server name does not contain a @, then will use
            local services otherwise forward it to the appropriate
            server
      V
            Validate user connection with database
            The database is stored in /etc/rpctcl.db with the format
            ipaddress      {userlist} {allow-commands} {deny-commands}
            e.g.
            1.0.1.1            {*} {sql* open* close* gets* read* seek* eof*} {*}
            If environment variable RPCTCLDB is set and points to
            a readable file then that file will be used instead
      L
            Login to user specified in data first
            (need not be a valid UNIX user)
Available Output Command Codes:
      SPACE
            Interpret and return data as is
      E
            Interpret data as an error
      F
            Interpret as an EOF (the server disappeared or shut-down)
      X
            Server exited (normally)
}

# Send output back to client
proc send_output {cmd} {
      global menu
      set len [string length $cmd]
      puts -nonewline stdout [format " %06d" $len]
      puts -nonewline stdout $cmd
      if {$menu(srvdebug) == 1} {
            puts $menu(srvdbgfp) "[pid] : Sending output $cmd"
            flush $menu(srvdbgfp)
      }
      flush stdout
}
# Send Control Commands back to client
proc send_control {state cmd} {
      global menu
      set len [string length $cmd]
      puts -nonewline stdout [format "%-1.1s%06d" $state $len]
      puts -nonewline stdout $cmd
      flush stdout
      if {$menu(srvdebug) == 1} {
            puts $menu(srvdbgfp) "[pid] : Sending control '$state' $cmd"
            flush $menu(srvdbgfp)
      }
}
# Loop waiting for requests
# Read request length
# Read request
# Eval Request
# Send Output Back
proc main {} {
      global menu
      set menu(srvdebug) [getenv RPCSERVDEBUG]
      set menu(srvdbgfile) [getenv RPCSERVDEBUGFILE]
      set menu(proxy) 0
      set menu(proxy,server) ""
      set menu(proxy,handle) ""
      if {$menu(srvdebug) == 1} {
            if {$menu(srvdbgfile) == ""} {
                  set menu(srvdbgfile) /tmp/rpcdbg.1
            }
            set menu(srvdbgfp) [open $menu(srvdbgfile) a]
      }
      looper
}

proc rpceval {} {
      global menu
      set ret [catch {eval $menu(line)} out]
      if {$ret == 0} {
            send_output $out
      } else {
            send_control E $out
      }
}
proc looper {} {
      global menu
      while {1} {
            set len [read stdin 7]
            if {[eof stdin]} {
                  send_control F EOF
                  exit 0
            }
            set control [string range $len 0 0]
            if {$menu(srvdebug) == 1} {
                  puts $menu(srvdbgfp) "[pid] : GOT CONTROL '$control' len '$len'"
                  flush $menu(srvdbgfp)
            }
            if {[scan $len "%*c%d" len] != 1} {
                  send_control E "INVALID FORMAT CONTROL '$control' DATA '$len'"
                  continue
            }
            set menu(control) $control
            set menu(len) $len
            set menu(line) [read stdin $len]
            if {$menu(srvdebug) == 1} {
                  puts $menu(srvdbgfp) "[pid] : GOT DATA $menu(line)"
                  flush $menu(srvdbgfp)
            }
            if {[eof stdin]} {
                  send_control F EOF
                  exit 0
            }
            if {$menu(line) == ""} {
                  send_control X EXIT
                  exit 0
            }
            if {$control == " "} {
                  rpceval
                  continue
            }
            if {$control == "Q"} {
                  rpceval
                  continue
            }
            if {$control == "P"} {
                  rpcproxy
                  continue
            }
            send_control E "INVALID FORMAT CONTROL '$control' DATA '$len'"
            continue
      }
}
proc rpcproxy {} {
      global menu
      if {$menu(proxy) == 1} {
            send_control E "Proxy already exists with $menu(proxy,server)"
            return
      }
      set slist [string trim [split $menu(line) "@"]]
      if {$menu(srvdebug) == 1} {
            puts $menu(srvdbgfp) "[pid] : Got proxy $slist"
            flush $menu(srvdbgfp)
      }
      if {[llength $slist] == 1} {
            send_control L "LOGGED [pid]"
            return
      }
      set slist [join [lrange $slist 1 end] "@"]
      if {$menu(srvdebug) == 1} {
            puts $menu(srvdbgfp) "[pid] : Calling rpcopen $slist"
            flush $menu(srvdbgfp)
      }
      if {[catch {rpcopen $slist} handle] != 0} {
            send_control E $handle
            return
      }
      if {$menu(srvdebug) == 1} {
            puts $menu(srvdbgfp) "[pid] : Got handle from rpcopen $handle"
            flush $menu(srvdbgfp)
      }

      set menu(proxy) 1
      set menu(proxy,handle) $handle
      set menu(proxy,server) $slist
      send_output $handle
      return
}
source rpc.tcl
main
----------------------------------------------------
# rpc.tcl
# PROVIDE RPC Client Services
# Created: Wed Apr 10 09:16:40 EDT 1996
# Version 1.0
# Functions available:
# set handle [rpcopen server|server@server|server@server]
# rpc $handle tcl_function|tcl_call ..
# e.g. rpc $handle eval {global x; set x 1}
# To close connection, use
# rpc $handle
# To open a handle to the local machine use
# rpcopen "" which will bypass sockets completely


if {"[info command getenv]" == ""} {
      proc getenv {var} {
            global env
            if {[info exists env($var)]} {
                  return $env($var)
            }
            return ""
      }
}
proc send_command {handle cmd args} {
      global menu
      set args [lindex $args 0]
      set len [string length "$args"]
      if {$menu(debug) == 1} {
            puts $menu(dbgfp)\
            "[pid] : SENDING COMMAND [format "%06d" $len] cmd {$cmd} {$args}"
            flush $menu(dbgfp)
      }
      puts -nonewline $menu($handle,conn) [format "%-1.1s%06d" $cmd $len]
      puts -nonewline $menu($handle,conn) "$args"
      flush $menu($handle,conn)
      set len [read $menu($handle,conn) 7]
      set control [string range $len 0 0]
      scan $len "%*c%d" len
      if {$menu(debug) == 1} {
            puts $menu(dbgfp) "[pid] : READING len '$len' control '$control'"
            flush $menu(dbgfp)
      }
      if {[catch {read $menu($handle,conn) $len} out] != 0} {
            if {$menu(debug) == 1} {
                  puts $menu(dbgfp) "[pid] : READERR: $out"
                  flush $menu(dbgfp)
            }
            close $menu($handle,conn)
            set menu($handle,state) 0
            foreach name $menu($handle,names) {
                  unset menu($handle,$name)
            }
            error $out
      }
      if {$control == "F"} {
            if {$menu(debug) == 1} {
                  puts $menu(dbgfp) "[pid] : CONTROL F: $out"
                  flush $menu(dbgfp)
            }
            close $menu($handle,conn)
            set menu($handle,state) 0
            foreach name $menu($handle,names) {
                  unset menu($handle,$name)
            }
      } elseif {$control == "X"} {
            if {$menu(debug) == 1} {
                  puts $menu(dbgfp) "[pid] : CONTROL X: $out"
                  flush $menu(dbgfp)
            }
            close $menu($handle,conn)
            set menu($handle,state) 0
            foreach name $menu($handle,names) {
                  unset menu($handle,$name)
            }
      } elseif {$control == "E"} {
            if {$menu(debug) == 1} {
                  puts $menu(dbgfp) "[pid] : CONTROL E: $out"
                  flush $menu(dbgfp)
            }
            error $out
      } elseif {$control == "L"} {
            if {$menu(debug) == 1} {
                  puts $menu(dbgfp) "[pid] : CONTROL L: $out"
                  flush $menu(dbgfp)
            }
            return $out
      } else {
            return $out
      }
}
proc rpcopen {server} {
      global menu

      set idebug [getenv RPCDEBUG]
      set menu(debug) 0
      if {$idebug == "1"} {
            set menu(debug) 1
            set menu(dbgfile) [getenv RPCDEBUGFILE]
            if {$menu(dbgfile) == ""} {
                  set menu(dbgfile) /tmp/rpcdbg.2
            }
            set menu(dbgfp) [open $menu(dbgfile) a]
            flush $menu(dbgfp)
      }
      # Get server name and socket name from mach1:7098@mach2@mach3:7098
      # as mach1 and 7098
      # If socket is not specified use 7098
      if {$menu(debug) == 1} {
            puts $menu(dbgfp) "[pid] : GOT rpcopen $server"
            flush $menu(dbgfp)
      }
      set slist [string trim [split $server "@"]]
      set proxy 0
      if {[llength $slist] > 1} {
            set proxy 1
            if {$menu(debug) == 1} {
                  puts $menu(dbgfp) "[pid] : proxy is 1"
                  flush $menu(dbgfp)
            }
      }
      set slist [string trim [split [lindex $slist 0] ":"]]
      set sname [lindex $slist 0]
      set sock [lindex $slist 1]
      if {$sock == ""} {set sock 7098}
      if {$menu(debug) == 1} {
            puts $menu(dbgfp) "[pid] : CALLING socket $sname $sock"
            flush $menu(dbgfp)
      }
      set local 0
      if {$sname == ""} {
            error "NO RPCSERVER SPECIFIED !"
      }
      if {$sname == "local"} {
            set fp local
            set local 1
      } else {
            set fp [socket $sname $sock]
      }
      if {![info exists menu(tot)]} {
            set menu(tot) 0
      } else {
            incr menu(tot)
      }
      set tot $menu(tot)
      set menu(rpc$tot,names) "conn proxy server sock state isproxy"
      set menu(rpc$tot,conn) $fp
      set menu(rpc$tot,proxy) $server
      set menu(rpc$tot,server) $sname
      set menu(rpc$tot,sock) $sock
      if {$local == 1} {
            set menu(rpc$tot,state) 2
      } else {
            set menu(rpc$tot,state) 1
      }
      set menu(rpc$tot,isproxy) 0
      if {$proxy == 1} {
            set menu(rpc$tot,isproxy) 1
      }
      if {$menu(rpc$tot,state) == 1} {
            fconfigure $fp -translation binary
            if {[catch {send_command rpc$tot P $server} ret] != 0} {
                  set handle rpc$tot
                  close $menu($handle,conn)
                  set menu($handle,state) 0
                  foreach name $menu($handle,names) {
                        unset menu($handle,$name)
                  }
                  error $ret
            }
      }
      return rpc$tot
}
proc rpcexists {handle} {
      global menu
      if {![info exists menu($handle,state)]} {
            return 0
      }
      if {$menu($handle,state) < 1} {
            return 0
      }
      return $menu($handle,state)
}
proc rpcclose {handle} {
      global menu
      if {![info exists menu($handle,state)]} {
            error "$handle: not open"
      }
      if {$menu($handle,state) == 2} {
            set menu($handle,state) 0
            foreach name $menu($handle,names) {
                  unset menu($handle,$name)
            }
            return ""
      }
      if {$menu($handle,state) != 1} {
            error "$handle: not currently open"
      }
      send_command $handle " " ""
}
proc rpc {handle args} {
      global menu
      if {$handle == ""} {set handle $menu(rpchandle)}
      if {![info exists menu($handle,state)]} {
            error "$handle: not open"
      }
      if {$menu($handle,state) == 2} {
            if {[string length $args] == 0} {
                  set menu($handle,state) 0
                  foreach name $menu($handle,names) {
                        unset menu($handle,$name)
                  }
                  return ""
            }
            return [eval $args]
      }
      if {$menu($handle,state) != 1} {
            error "$handle: not currently open"
      }
      send_command $handle " " $args
}
proc _sql {args} {
      global menu
      if {[info exists menu(rpchandle)] && [rpcexists $menu(rpchandle)]} {
            return [rpc "" eval sql $args]
      }
      if {![info exists menu(sqlhandle)] || ![rpcexists $menu(sqlhandle)]} {
            global env
            if {[getenv ISTARSERVER] == ""} {
                  error "NO ISTARSERVER specified !"
            }
            set sock [getenv ISTARSOCKET]
            if {$sock != ""} {
                  set server "$env(ISTARSERVER):$sock"
            } else {
                  set server "$env(ISTARSERVER)"
            }
            set menu(sqlhandle) [rpcopen $server]
      }
      rpc $menu(sqlhandle) eval sql $args
}

proc rpcinit {} {
      global env menu
      set menu(rpcserver) [getenv RPCSERVER]
      if {$menu(rpcserver) == ""} {set menu(rpcserver) local}
      set menu(rpchandle) [rpcopen $menu(rpcserver)]
}


# Examples:
# set handle [rpcopen vista]
# rpc $handle eval {global x; set x 12}
# rpc $handle eval {global x; puts "x is $x"; incr x }
# rpc $handle
------------------------------------------------------

#!/smart/lbin/rtclsh
# Provide INETD service to rpcserv.tcl (RPC server capability)
# without using inetd
# Needs TCL version >= 7.5
# Created: Tue Apr 30 14:45:49 EDT 1996
# Last Updated: Tue Apr 30 14:45:55 EDT 1996
proc rpc_service_do {args} {
      #puts "GOT $args"
      set sockfd [lindex $args 0]
      set sockhost [lindex $args 1]
      set sockport [lindex $args 2]
      #flush stdout
      #puts "Launched: exec rtclsh rpcserv.tcl <@$sockfd >@$sockfd 2>@$sockfd &"
      set pid [exec tclx.ora rpcserv.tcl\
            RPCSERVTCLAUTO <@$sockfd >@$sockfd 2>@$sockfd &]
      #puts "sockfd is $sockfd"
      #flush stdout
      close $sockfd
      global fplog
      if {$fplog != ""} {
            set day [clock format [clock seconds]]
            puts $fplog\
            "HOST $sockhost PID $pid PORT $sockport FD $sockfd DATE $day"
            flush $fplog
      }
}

proc getenv {x} {
      global env
      if {[catch {set ret $env($x)}] == 0} {
            return $ret
      } else {return ""}
}

proc main {} {
      global env mainport fplog
      set port [getenv RPCSOCKET]
      if {$port == ""} {
            set port 7098
      }
      set mainport [socket -server rpc_service_do $port]
      set fplog ""
      catch {set fplog [open rpcserv.log a]}

}

main
vwait any
-------------------------------------------------------

#!/smart/lbin/rtclsh
# Provide INETD service to istarserv.tcl (ISTAR server capability)
# without using inetd
# Needs TCL version >= 7.5
# Created: Tue Apr 30 14:45:49 EDT 1996
# Last Updated: Tue Apr 30 14:45:55 EDT 1996
proc istar_service_do {args} {
      #puts "GOT $args"
      set sockfd [lindex $args 0]
      set sockhost [lindex $args 1]
      set sockport [lindex $args 2]
      #flush stdout
      #puts "Launched: exec rtclsh istarserv.tcl <@$sockfd >@$sockfd 2>@$sockfd &"
      exec tclsh8.1 istarserv.tcl <@$sockfd >@$sockfd 2>@$sockfd &
      #puts "sockfd is $sockfd"
      #flush stdout
      close $sockfd
}

proc getenv {var} {
      global env
      if {[catch {set env($var)} err] != 0} {
            return ""
      }
      return $err
}
proc main {} {
      global env mainport
      set port [getenv ISTARSOCKET]
      if {$port == ""} {
            set port 7028
      }
      set mainport [socket -server istar_service_do $port]
}

main
vwait any
---------------------------------------------------

# ISTAR SERVER 1.1
# Created: Thu Apr  4 09:40:05 EST 1996
# Last Updated: Tue Apr 30 14:17:31 EDT 1996

# Send output back to client
proc send_output {cmd} {
      set len [string length $cmd]
      puts -nonewline stdout [format " %06d" $len]
      puts -nonewline stdout $cmd
      flush stdout
}
# Send Control Commands back to client
proc send_control {state cmd} {
      set len [string length $cmd]
      puts -nonewline stdout [format "%-1.1s%06d" $state $len]
      puts -nonewline stdout $cmd
      flush stdout
}
# Provide inetd service to rpcserv.tcl
proc istar_service_do {args} {
      #puts "GOT $args"
      set sockfd [lindex $args 0]
      set sockhost [lindex $args 1]
      set sockport [lindex $args 2]
      #flush stdout
      #puts "Launched: exec rtclsh istarserv.tcl <@$sockfd >@$sockfd 2>@$sockfd &"
      fconfigure $sockfd -translation binary
      exec rtclsh istarserv.tcl <@$sockfd >@$sockfd 2>@$sockfd &
      #puts "sockfd is $sockfd"
      #flush stdout
      close $sockfd
}
if {"[info commands getenv]" != "getenv"} {
      proc getenv {var} {
            global env
            if {[info exists env($var)]} {
                  return $env($var)
            }
            return ""
      }
}
global argv
foreach opt $argv {
      if {$opt == "-server"} {
            set _sockport [getenv ISTARSOCKET]
            if {$_sockport == ""} {
                  set _sockport 7028
            }
      }
}
if {[info exists _sockport]} {
      if {[catch {socket -server istar_service_do $_sockport} _mainport] != 0} {
            puts "ERROR: $_mainport Port#: $_sockport"
            exit 1
      }
      vwait any
      exit 0
}
# Loop waiting for requests
# Read request length
# Read request
# Eval Request
# Send Output Back
while {1} {
      set len [read stdin 6]
      scan $len "%d" len
      set line [read stdin $len]
      flush stdout
      if {[eof stdin]} {
            send_control F EOF
            exit 0
      }
      if {$line == ""} {
            send_control X EXIT
            exit 0
      }
      if {[catch {eval $line} out] == 0} {
            send_output $out
      } else {
            send_control E $out
      }
}
-------------------------------------------------------

# Provide ISTAR capability for client ISTAR 1.1
# Created: Thu Apr  4 10:06:58 EST 1996
# Last Updated: Tue Apr 30 14:17:13 EDT 1996

if {"[info command getenv]" == ""} {
      proc getenv {var} {
            global env
            if {[info exists env($var)]} {
                  return $env($var)
            }
            return ""
      }
}
proc sql_send_command {cmd} {
      global istar
      set len [string length "$cmd"]
      if {$istar(debug) == 1} {
            puts "SENDING COMMAND [format "%06d" $len] {$cmd}"
      }
      puts -nonewline $istar(conn) [format "%06d" $len]
      puts -nonewline $istar(conn) "$cmd"
      flush $istar(conn)
      set len [read $istar(conn) 7]
      set control [string range $len 0 0]
      scan $len "%*c%d" len
      if {$istar(debug) == 1} {
            puts "READING len $len"
      }
      if {[catch {read $istar(conn) $len} out] != 0} {
            if {$istar(debug) == 1} {
                  puts "READERR: $out"
            }
            close $istar(conn)
            set istar(state) 0
            error $out
      }
      if {$control == "F"} {
            if {$istar(debug) == 1} {
                  puts "CONTROL F: $out"
            }
            close $istar(conn)
            set istar(state) 0
      } elseif {$control == "X"} {
            if {$istar(debug) == 1} {
                  puts "CONTROL X: $out"
            }
            close $istar(conn)
            set istar(state) 0
      } elseif {$control == "E"} {
            if {$istar(debug) == 1} {
                  puts "CONTROL E: $out"
            }
            error $out
      } else {
            return $out
      }
}
proc istar_connect {args} {
      global istar
      if {![info exists istar(state)] || $istar(state) == 0} {
            set server [getenv ISTARSERVER]
            set sock [getenv ISTARSOCKET]
            set idebug [getenv ISTARDEBUG]
            set istar(debug) 0
            if {$idebug == "1"} {
                  set istar(debug) 1
            }
            if {$sock == ""} {set sock 7028}
            if {$server == ""} {
                  error "NO ISTARSERVER SPECIFIED !"
            }
            set istar(conn) [socket $server $sock]
            set istar(server) $server
            set istar(sock) $sock
            set istar(state) 1
            fconfigure $istar(conn) -translation binary
      }
      return $istar(conn)
}
proc sql {args} {
      global istar
      if {![info exists istar(state)] || $istar(state) == 0} {
            istar_connect ""
      }
      sql_send_command "sql $args"
}

#set env(ISTARSERVER) dagger
#set env(ISTARDEBUG) 1
#set env(APPLIB) /ref/smart/guif
#set env(APPMAP) /ref/smart/guif
#set env(DATABASE) ni
#source /ref/smart/guif/ext.tcl
#sql database ni
#fconfigure sock3 -buffering none -buffersize 1 -translation binary
#puts [sql_database ni]
#puts [sql_open "select * from com_ne_defn"]
#puts [sql_fetch 0]
#exit 0
-----------------------------------------------------------

proc sql_open {args} { return [eval sql open $args] }
proc sql_run {args} { return [eval sql run $args] }
proc sql_fetch {args} { return [eval sql fetch $args] }
proc sql_close {args} { return [eval sql close $args] }
proc sql_exists {args} { return [eval sql exists $args] }
proc sql_reopen {args} { return [eval sql reopen $args] }
proc sql_explain {args} { return [eval sql explain $args] }
proc sql_geterror {args} { return [eval sql geterror $args] }
proc sqlca {args} { return [eval sql sqlca $args] }
proc sqlda {args} { return [eval sql sqlda $args] }
proc sqld {args} { return [eval sql sqld $args] }
proc sql_database {args} { return [eval sql database $args] }
proc sql_getdatabase {args} { return [eval sql getdatabase $args] }
proc sql_finish {args} { return [eval sql finish $args] }
proc sql_colnames {fd in} {
      set colnames {}
      for {set i 0} {$i < [sql sqld $fd $in]} {incr i} {
            lappend colnames [lindex [sql sqlda $fd $in $i] 3]
      }
      return $colnames
}
proc sql_coltypes {fd in} {
      set coltypes {}
      for {set i 0} {$i < [sql sqld $fd $in]} {incr i} {
            lappend coltypes [lindex [sql sqlda $fd $in $i] 7]
      }
      return $coltypes
}
proc sql_charlen {fd in} {
      set charlen {}
      for {set i 0} {$i < [sql sqld $fd $in]} {incr i} {
            lappend charlen [lindex [sql sqlda $fd $in $i] 1]
      }
      return $charlen
}
proc sql_dblen {fd in} {
      set dblen {}
      for {set i 0} {$i < [sql sqld $fd $in]} {incr i} {
            lappend dblen [lindex [sql sqlda $fd $in $i] 9]
      }
      return $dblen
}
proc sql_error {} {
      set s [sql sqlca]
      set cd [lindex $s 0]
      if {$cd == 0} {
            return ""
      }
      format "%d: [lindex $s 5]" $cd [lindex $s 1]
}
proc sql_error_num {} {
      lindex [sql sqlca] 0
}
proc sql_isam_error {} {
      set s [sql sqlca]
      set cd [lindex [lindex $s 3] 1]
      if {$cd == 0} {
            return ""
      }
      format "%d: [lindex $s 6]" $cd
}
proc isam_error_num {} {
      lindex [lindex [sql sqlca] 3] 1
}
proc sql_get_rowid {} {
      lindex [lindex [sql sqlca] 3] 5
}
proc sql_get_serial {} {
      lindex [lindex [sql sqlca] 3] 1
}
proc sql_get_numrows {} {
      lindex [lindex [sql sqlca] 3] 2
}
proc sql_get_estrows {} {
      lindex [lindex [sql sqlca] 3] 0
}
proc sql_get_erroffset {} {
      lindex [lindex [sql sqlca] 3] 4
}
proc sql_one {args} {
      set fd [eval sql open $args]
      set line [sql fetch $fd]
      sql close $fd
      return $line
}
proc sql_onetrim {args} {
      set fd [eval sql open $args]
      set line [sql fetch $fd 1]
      sql close $fd
      return $line
}
proc sql_all {args} {
      set arglist {}
      set fd [eval sql open $args]
      while {[set line [sql fetch $fd]] != ""} {
            lappend arglist $line
      }
      sql close $fd
      return $arglist
}
proc sql_alltrim {args} {
      set arglist {}
      set fd [eval sql open $args]
      while {[set line [sql fetch $fd 1]] != ""} {
            lappend arglist $line
      }
      sql close $fd
      return $arglist
}
proc sql_convert_text {str} {
      set len [string length $str]
      set out ""
      for {set i 0} {$i < $len} {incr i} {
            set s1 [string toupper [string index $str $i]]
            incr i
            set s2 [string toupper [string index $str $i]]
            if {$s1 >= "A"} {
                  switch $s1 {
                        "A"            {set s1 10}
                        "B"            {set s1 11}
                        "C"            {set s1 12}
                        "D"            {set s1 13}
                        "E"            {set s1 14}
                        "F"            {set s1 15}
                        default {error "Invalid format character $s1"}
                  }
            }
            if {$s2 >= "A"} {
                  switch $s2 {
                        "A"            {set s2 10}
                        "B"            {set s2 11}
                        "C"            {set s2 12}
                        "D"            {set s2 13}
                        "E"            {set s2 14}
                        "F"            {set s2 15}
                        default {error "Invalid format character $s2"}
                  }
            }
            append out [format "%c" [expr $s1*16+$s2]]
      }
      return $out
}
--------------------------------------------------------

proc oralogon {args} {
      set uid [lindex [split [lindex $args 0] "/"] 0]
      set pw [lindex [split [lindex [split [lindex $args 0] "/"] 1] "@"] 0]
      set db [lindex [split [lindex [split [lindex $args 0] "/"] 1] "@"] 1]
      if {"x$uid" != "x"} {
            sql connect $db user $uid password $pw
      } else {
            sql connect $db
      }
      return oratcl0
}
proc oraopen {args} {
      global infmenu oramsg
      for {set i 0} {$i <= 100} {incr i} {
            if {[info exists infmenu(cntr,$i)] == 0} {
                  set infmenu(cntr,$i) 1
                  set oramsg(handle) oratcl0.$i
                  return oratcl0.$i
            }
            if {$infmenu(cntr,$i) == 0} {
                  set infmenu(cntr,$i) 1
                  set oramsg(handle) oratcl0.$i
                  return oratcl0.$i
            }
      }
      error "No more handles"
}
proc orasql {args} {
      global infmenu oramsg
      set handle [lindex $args 0]
      set cmd [lindex $args 1]
      if {[scan $handle "oratcl0.%d" handle] != 1} {
            error "Invalid handle oratcl0.$handle to orasql"
      }
      if {[info exists infmenu(cntr,$handle)] == 0} {
            error "No such handle oratcl0.$handle"
      }
      set oramsg(handle) oratcl0.$handle
      if {[catch {sql open $cmd} ret] == 0} {
            set infmenu(cntr,$handle,sql) $ret
            if {[sql sqld $infmenu(cntr,$handle,sql) 0] == -1} {
                  return [sql run $infmenu(cntr,$handle,sql)]
            }
            return 0
      }
      error $ret
}
proc orafetch {args} {
      global infmenu oramsg
      set handle [lindex $args 0]
      if {[scan $handle "oratcl0.%d" handle] != 1} {
            error "Invalid handle oratcl0.$handle to orasql"
      }
      if {[info exists infmenu(cntr,$handle)] == 0} {
            error "No such handle oratcl0.$handle"
      }
      if {[info exists infmenu(cntr,$handle,sql)] == 0} {
            error "Handle not open oratcl0.$handle"
      }
      set oramsg(handle) oratcl0.$handle
      if {[sql sqld $infmenu(cntr,$handle,sql) 0] == -1} {
            return ""
      } else {
            sql fetch $infmenu(cntr,$handle,sql)
      }
}
proc oraclose {args} {
      global infmenu oramsg
      set handle [lindex $args 0]
      if {[scan $handle "oratcl0.%d" handle] != 1} {
            error "Invalid handle oratcl0.$handle to orasql"
      }
      if {[info exists infmenu(cntr,$handle)] == 0} {
            error "No such handle oratcl0.$handle"
      }
      if {[info exists infmenu(cntr,$handle,sql)] == 0} {
            unset infmenu(cntr,$handle)
            return 0
      }
      set oramsg(handle) oratcl0.$handle
      sql close $infmenu(cntr,$handle,sql)
      unset infmenu(cntr,$handle)
      unset infmenu(cntr,$handle,sql)
      return 0
}
proc oralogoff {args} {
      global infmenu oramsg
      for {set i 0} {$i <= 100} {incr i} {
            if {[info exists infmenu(cntr,$i)] == 1} {
                  oraclose oratcl0.$i
            }
      }
      sql finish
}
proc oraroll {args} {
      sql run "rollback work"
}
proc oracommit {args} {
      sql run "begin work"
}
proc oraautocom {args} {
      return 0
}
proc oracols {args} {
      global infmenu oramsg
      set handle [lindex $args 0]
      if {[scan $handle "oratcl0.%d" handle] != 1} {
            error "Invalid handle oratcl0.$handle to orasql"
      }
      if {[info exists infmenu(cntr,$handle)] == 0} {
            error "No such handle oratcl0.$handle"
      }
      if {[info exists infmenu(cntr,$handle,sql)] == 0} {
            error "Handle not open oratcl0.$handle"
      }
      set oramsg(handle) oratcl0.$handle
      set num [sql sqld $infmenu(cntr,$handle,sql) 0]
      set collist {}
      for {set i 0} {$i < $num} {incr i}  {
            set colname [lindex [sql sqlda $infmenu(cntr,$handle,sql) 0 $i] 3]
            lappend collist $colname
      }
      return $collist
}
proc oragetmsg {args} {
      global infmenu oramsg
      if {[info exists oramsg(handle)] == 0} {
            return ""
      }
      set handle $oramsg(handle)
      if {[scan $handle "oratcl0.%d" handle] != 1} {
            return ""
      }
      switch [lindex $args 0] {
            "nullvalue"            {return "default"}
            "errortxt"            {
                                          if {[lindex [sql sqlca] 0] == 0} {
                                                return ""
                                          }
                                          if {[lindex [sql sqlca] 0] == 100} {
                                                return ""
                                          }
                                          return [format [lindex [sql sqlca] 5] [lindex\
                                                            [sql sqlca] 1]]
                                    }
            "rc"                  {
                                          set rc [lindex [sql sqlca] 0]
                                          if {$rc == 100} {
                                                return 1403
                                          } else {
                                                
                                                if {[info exists infmenu(cntr,$handle,sql)]\
                                                      == 1 && [sql sqld\
                                                      $infmenu(cntr,$handle,sql) 0] == -1} {
                                                      set rc 1403
                                                }
                                          }
                                          return $rc
                                    }
            "rows"                  {
                                          if {[info exists infmenu(cntr,$handle,sql)] == 1\
                                            && [sql sqld $infmenu(cntr,$handle,sql) 0]\
                                            == -1} {
                                                return [lindex [lindex [sql sqlca] 3] 2]
                                          }
                                          return 1
                                    }
      }
      if {[info exists infmenu(cntr,$handle,sql)] == 1} {
            set num [sql sqld $infmenu(cntr,$handle,sql) 0]
            set typelist {}
            set lenlist {}
            for {set i 0} {$i < $num} {incr i}  {
                  set coltype [lindex [sql sqlda $infmenu(cntr,$handle,sql) 0 $i] 0]
                  set collen [lindex [sql sqlda $infmenu(cntr,$handle,sql) 0 $i] 1]
                  lappend typelist $coltype
                  lappend lenlist $collen
            }
            switch [lindex $args 0] {
                  "collengths" {return $lenlist}
                  "coltypes"      {return $typelist}
            }
      }
      error "Not supported arg [lindex $args 0] to oramsg"
}
-----------------------------------------------------


0
Comment
Question by:rvinay_kumar
5 Comments
 
LVL 2

Expert Comment

by:obg
ID: 6252948
Is it a big program? Otherwise you could post it, and let us do the job... (I don't know of any tools for TCL to C conversion.)
0
 
LVL 51

Expert Comment

by:ahoffmann
ID: 6253733
there exist a comercial tool tcl2c or so. Sorry can't remember the name and company.
I suggest looking at http://www.scriptics.com/
0
 
LVL 5

Expert Comment

by:djbusychild
ID: 6254141
0
 
LVL 14

Accepted Solution

by:
AlexVirochovsky earned 100 total points
ID: 6264077
0
 
LVL 45

Expert Comment

by:sunnycoder
ID: 9376606
No comment has been added lately and this question is therefore classified abandoned.

If asker wishes to close the question, then refer to
http://www.experts-exchange.com/help/closing.jsp

Otherwise, I will leave a recommendation in the Cleanup topic area that this question is:
PAQed with A grade to AlexVirochovsky. As djbusychild's link is no longer active so I cannot verify its contents

Please leave any comments or objections here within the next seven days. It is assumed that any participant not responding to this request is no longer interested in its final disposition.

PLEASE DO NOT ACCEPT THIS COMMENT AS AN ANSWER!

Sunny
EE Cleanup Volunteer
0

Featured Post

Highfive + Dolby Voice = No More Audio Complaints!

Poor audio quality is one of the top reasons people don’t use video conferencing. Get the crispest, clearest audio powered by Dolby Voice in every meeting. Highfive and Dolby Voice deliver the best video conferencing and audio experience for every meeting and every room.

Join & Write a Comment

This tutorial is posted by Aaron Wojnowski, administrator at SDKExpert.net.  To view more iPhone tutorials, visit www.sdkexpert.net. This is a very simple tutorial on finding the user's current location easily. In this tutorial, you will learn ho…
Summary: This tutorial covers some basics of pointer, pointer arithmetic and function pointer. What is a pointer: A pointer is a variable which holds an address. This address might be address of another variable/address of devices/address of fu…
Video by: Grant
The goal of this video is to provide viewers with basic examples to understand and use nested-loops in the C programming language.
Video by: Grant
The goal of this video is to provide viewers with basic examples to understand and use while-loops in the C programming language.

760 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

19 Experts available now in Live!

Get 1:1 Help Now