Tcl/Tk
Curso On-Line de Programação
Curso On-Line de Programação
|
Tcl/Tk
Curso On-Line de Programação |
Exemplos
A seguir são apresentados os códigos-fontes
de algumas bibliotecas Tcl. Estas bibliotecas podem ser utilizadas tanto
com o interpretador tclsh quanto com o interpretador wish.
Índice
# rc.tcl
# Suporte a arquivos de recursos.
#
# Copyright (c) 2000,2001 by Roberto Luiz Souza Monteiro
#
# Este arquivo e distribuido nos termos da licenca GNU GPL.
namespace eval rc {
namespace export *
}
# rc::loadRc RcArray RcFile
#
# Carrega um arquivo de recursos em um vetor associativo.
#
# Argumentos:
# RcArray Vetor associativo onde cada elemento corresponde
# a uma variavel no arquivo de recursos.
#
# RcFile Arquivo de recursos.
#
# Retorno:
# 1 Arquivo encontrado.
# 0 Arquivo nao encontrado.
#
# Linhas de comentarios comecam com o caractere sustenido(#).
# Linhas em branco sao ignoradas.
# Recursos devem estar no formato: variavel=valor.
proc rc::loadRc {RcArray RcFile} {
global $RcArray
set RcFound 1
if {[file exists $RcFile]} {
set Handle [open $RcFile r]
set Rc [read $Handle]
close $Handle
set RcList [split $Rc "\n"]
if {[llength $RcList] > 0} {
for {set i 0} {$i < [llength $RcList]} {incr i} {
set RcLine [lindex $RcList $i]
set RcLine [string trim $RcLine]
if {[string index $RcLine 0] != "#"} {
if {[string trim $RcLine] != ""} {
set RcLineList [split $RcLine "="]
if {[llength $RcLineList] == 2} {
set Name [string trim [lindex $RcLineList 0]]
set Value [string trim [lindex $RcLineList 1]]
# Cria os elementos do vetor associativo
set ${RcArray}($Name) $Value
}
}
}
}
}
} else {
set RcFound 0
}
return $RcFound
}
# rc::saveRc RcArray RcFile
#
# Salva um vetor associativo em um arquivo de recursos.
#
# Argumentos:
# RcArray Vetor associativo onde cada elemento corresponde
# a uma variavel no arquivo de recursos.
#
# RcFile Arquivo de recursos.
#
# Recursos estarao no formato: variavel=valor.
proc rc::saveRc {RcArray RcFile} {
global $RcArray
set RcList [array get $RcArray]
set Handle [open $RcFile w+]
for {set i 0} {$i <= [expr "[llength $RcList] - 2"]} {incr i} {
set RcLine ""
append RcLine [lindex $RcList $i] "=" [lindex $RcList [expr "$i + 1"]]
incr i
puts $Handle $RcLine
}
close $Handle
}Biblioteca para criação de relatórios PostScript
# postscript.tcl --
#
# Suporte a impressao PostScript.
#
# RCS: @(#) $Id: postscript.tcl,v 1.0 2001/06/23 15:31:00 monteiro Exp $
#
# Copyright (c) 2001 Roberto Luiz Souza Monteiro.
#
# Este arquivo e distribuido nos termos da licenca GNU GPL.
namespace eval ::postscript {}
# ::postscript::beginDocument
# Cria o cabecalho PostScript Adobe 3.0.
#
# Resultados:
# Codigo do cabecalho PostScript Adobe 3.0.
proc ::postscript::beginDocument {} {
set PS "%!PS-Adobe-3.0 \r\n"
append PS "%%BoundingBox: 0 0 612 792 \r\n"
append PS "%%Pages: (atend) \r\n"
append PS "%%PageOrder: Ascend \r\n\r\n"
append PS "% Funcao para centralizar o texto na pagina. \r\n"
append PS "/center { \r\n"
append PS " dup stringwidth pop \r\n"
append PS " 2 div neg 0 rmoveto \r\n"
append PS "} bind def \r\n\r\n"
append PS "% Funcao para alinhar o texto a direita na pagina. \r\n"
append PS "/right {dup stringwidth pop neg 0 rmoveto} bind def \r\n\r\n"
return $PS
}
# ::postscript::beginPage Page
# Inicia uma pagina.
#
# Argumentos:
# Page Numero da pagina.
#
# Resultados:
# Codigo para iniciar uma pagina.
proc ::postscript::beginPage {{Page 1}} {
set PS "% Inicio da pagina. \r\n"
append PS "%%Page: $Page $Page \r\n\r\n"
return $PS
}
# ::postscript::endPage Page
# Finaliza a pagina.
#
# Argumentos:
# Page Numero da pagina.
#
# Resultados:
# Codigo para finalizar a pagina.
proc ::postscript::endPage {{Page 1}} {
set PS "% Final da pagina. \r\n"
append PS "showpage \r\n"
append PS "%%EndPage: $Page $Page \r\n\r\n"
return $PS
}
# ::postscript::endDocument Pages
# Finaliza um documento.
#
# Argumentos:
# Pages Numero de paginas.
#
# Resultados:
# Codigo para finalizar o documento.
proc ::postscript::endDocument {{Pages 1}} {
set PS "% Final do documento. \r\n"
append PS "%%Trailer \r\n"
append PS "%%Pages: $Pages \r\n"
append PS "%%EOF \r\n"
return $PS
}
# ::postscript::drawText X Y Text Font Size Justify
# Desenha um texto no documento.
#
# Argumentos:
# X Coordenada X em polegadas.
# Y Coordenada Y em polegadas.
# Text Texto.
# Font Nome da fonte.
# Size Corpo da fonte.
# Justify Alinhamento do texto em relacao a coordenada X. Pode ser "", center ou right.
#
# Resultados:
# Codigo para desenha um texto no documento.
proc ::postscript::drawText {{X 0} {Y 0} {Text ""} {Font Times} {Size 10} {Justify ""}} {
set PS "% Desenha uma string na pagina. \r\n"
append PS "/$Font findfont \r\n"
append PS "$Size scalefont \r\n"
append PS "setfont \r\n"
append PS "[expr $X * 72] [expr $Y * 72] moveto \r\n"
append PS "($Text) $Justify show \r\n\r\n"
return $PS
}
# ::postscript::drawLine X1 Y1 X2 Y2
# Desenha uma linha no documento.
#
# Argumentos:
# X1 Coordenada X1 em polegadas.
# Y1 Coordenada Y1 em polegadas.
# X2 Coordenada X2 em polegadas.
# Y2 Coordenada Y2 em polegadas.
#
# Resultados:
# Codigo para desenha uma linha no documento.
proc ::postscript::drawLine {{X1 0} {Y1 0} {X2 0} {Y2 0}} {
set PS "% Desenha uma linha na pagina. \r\n"
append PS "[expr $X1 * 72] [expr $Y1 * 72] moveto \r\n"
append PS "[expr $X2 * 72] [expr $Y2 * 72] lineto \r\n"
append PS "stroke \r\n\r\n"
return $PS
}
# ::postscript::drawRectangle X1 Y1 X2 Y2
# Desenha um retangulo no documento.
#
# Argumentos:
# X1 Coordenada X1 em polegadas.
# Y1 Coordenada Y1 em polegadas.
# Width Largura em polegadas.
# Height Altura em polegadas.
#
# Resultados:
# Codigo para desenha um retangulo no documento.
proc ::postscript::drawRectangle {{X1 0} {Y1 0} {Width 0} {Height 0}} {
set PS "% Desenha um retangulo na pagina. \r\n"
append PS "[expr $X1 * 72] [expr $Y1 * 72] moveto \r\n"
append PS "[expr $Width * 72] 0 rlineto \r\n"
append PS "0 [expr $Height * 72] rlineto \r\n"
append PS "-[expr $Width * 72] 0 rlineto \r\n"
append PS "closepath \r\n"
append PS "stroke \r\n\r\n"
return $PS
}
Biblioteca para comunicacao serial
# serial.tcl --
#
# Biblioteca para envio e recebimento de bytes pela porta serial.
#
# RCS: @(#) $Id: serial.tcl,v 1.0 2001/03/10 08:31:00 monteiro Exp $
#
# Copyright (c) 2001 Roberto Luiz Souza Monteiro.
#
# Este arquivo e distribuido nos termos da licenca GNU GPL.
# Informacoes Tecnicas
# Protocolo:
# Dependendo da aplicacao, pode-se usar um dos protocolos abaixo:
#
# <STX>dados<ETX>
# <STX>dados<ETX><LRC>
#
# <SI>dados<SO><LRC>
#
# <STX><NBL><NBH>dados
# <STX><NBL><NBH>dados<CSL><CSH>
# <STX><NBL><NBH>dados<LRC>
# dados<ETX>
# dados<CR>
#
# Onde LRC( Longitudinal Redundancy Check ) e um caractere de verificacao,
# calculado da seguinte forma:
#
# LRC = dado1 XOR dado2 XOR ... dadosN XOR ETX.
# LRC = dado1 XOR dado2 XOR ... dadosN XOR SO.
#
# NBL = Byte menos significativo da soma do numero de bytes que serao
# enviados( dados + CSL + CSH ).
# NBH = Byte mais significativo da soma do numero de bytes que serao
# enviados( dados + CSL + CSH ).
# CSL = Byte menos significativo da soma dos valores dos bytes que estao
# sendo enviados.
# CSH = Byte mais significativo da soma dos valores dos bytes que estao
# sendo enviados.
#
# Em alguns casos, pode ser conveniente que a cada byte, ou pacote
# enviados, o receptor responda com um caractere ENQ, a fim de
# sincronizar a comunicacao.
#
# Caracteres ASCII de Controle:
# NUL 00h Null.
# SOH 01h
# STX 02h Star of Text.
# ETX 03h End of Text.
# EOT 04h End of Transmission.
# ENQ 05h Enquire.
# ACK 06h Acknowledge.
# BEL 07h Soa um beep.
# BS 08h Backspace.
# HT 09h Horizontal Tabulation.
# NL 0Ah
# VT 0Bh Vertical Tabulation.
# NP, FF 0Ch Form Feed.
# CR 0Dh Carriage Return.
# SO 0Eh Shift Out.
# SI 0Fh Shift In.
# DLE 10h
# XON, DC1 11h
# DC2 12h
# XOFF, DC3 13h
# DC4 14h
# NAK 15h Negative Acknowledge.
# SYN 16h
# ETB 17h
# CAN 18h
# EM 19h
# SUB 1Ah
# ESC 1Bh Escape.
# FS 1Ch Field Separator.
# GS 1Dh
# RS 1Eh
# US 1Fh
#
# Status:
# SERIAL_OK Operacao bem sucedida.
# SERIAL_ERROR_OPEN Nao foi possivel abrir a porta serial.
# SERIAL_ERROR_CLOSE Nao foi possivel fechar a porta serial.
# SERIAL_ERROR_READ Nao foi possivel ler a porta serial.
# SERIAL_ERROR_WRITE Nao foi possivel escrever na porta serial.
# SERIAL_ERROR_TIMEOUT Ocorreu um Time Out ao tentar ler a porta serial.
# SERIAL_ERROR_CHECKSUM Soma de verificacao incorreta.
namespace eval serial:: {
global tcl_platform
variable handle ""
# Configura a porta serial default, de acordo com a plataforma.
if {$tcl_platform(platform) == "unix"} {
variable port "/dev/ttyS0"
} else {
variable port "com1:"
}
variable baund 9600
variable parity "n"
variable data 8
variable stop 1
variable timeout 2000
variable status "SERIAL_OK"
variable binarySent ""
variable asciiSent {}
variable binaryChar ""
variable asciiChar ""
variable binaryReceived ""
variable asciiReceived ""
variable checkSumReceived ""
variable checkSumCalculated ""
}
# serial::init
# Cria e inicializa as variaveis do namespace.
proc serial::init {} {
global tcl_platform
variable handle ""
# Configura a porta serial default, de acordo com a plataforma.
if {$tcl_platform(platform) == "unix"} {
variable port "/dev/ttyS0"
} else {
variable port "com1:"
}
variable baund 9600
variable parity "n"
variable data 8
variable stop 1
variable timeout 2000
variable status "SERIAL_OK"
variable binarySent ""
variable asciiSent {}
variable binaryChar ""
variable asciiChar ""
variable binaryReceived ""
variable asciiReceived ""
variable checkSumReceived ""
variable checkSumCalculated ""
}
# serial::openport Port Baund Parity Data Stop
# Abre e configura a porta serial.
#
# Argumentos:
# Port Porta serial.
# Baund Velocidade( 110, 300, 1200, 2400, 4800, 9600, 19200, 38400,
# 57600, 115200, 230400, 460800, 921600 ).
# Parity Paridade( n, o, e, m, s ).
# Data Numero de bits de dados( 5 a 8 ).
# Stop Numero de bits de parada( 1 ou 2 ).
#
# Resultados:
# Handle para a porta serial.
proc serial::openport {{Port ""} {Baund ""} {Parity ""} {Data ""} {Stop ""}} {
variable handle
variable port
variable baund
variable parity
variable data
variable stop
variable status "SERIAL_OK"
# Configura as variaveis do namespace.
if {[string length $Port] > 0} {
set port $Port
}
if {[string length $Baund] > 0} {
set baund $Baund
}
if {[string length $Parity] > 0} {
set parity $Parity
}
if {[string length $Data] > 0} {
set data $Data
}
if {[string length $Stop] > 0} {
set stop $Stop
}
# Abre e configura a porta serial.
set Result [catch {
set handle [open $port r+]
fconfigure $handle -blocking 0 -translation binary -mode "$baund,$parity,$data,$stop"
}]
if {$Result != 0} {
set status "SERIAL_ERROR_OPEN"
}
return $handle
}
# serial::closeport Handle
# Fecha a porta serial.
#
# Argumentos:
# Handle Handle para a porta serial.
#
# Resultados:
# 0 se a operacao for concluida com exito.
proc serial::closeport {{Handle ""}} {
variable handle
variable status "SERIAL_OK"
# Configura as variaveis do namespace.
if {[string length $Handle] > 0} {
set handle $Handle
}
# Fecha a porta serial.
set Result [catch {
close $handle
}]
if {$Result != 0} {
set status "SERIAL_ERROR_CLOSE"
}
set handle ""
return $Result
}
# serial::putchar Handle Byte
# Envia um byte para a porta serial.
#
# Argumento:
# Handle Handle para a porta serial.
# Byte Byte a ser enviado.
proc serial::putchar {{Handle ""} {Byte ""}} {
variable handle
variable status "SERIAL_OK"
# Configura as variaveis do namespace.
if {[string length $Handle] > 0} {
set handle $Handle
}
# Envia o byte para a porta serial.
set Result [catch {
puts -nonewline $handle $Byte
flush $handle
}]
if {$Result != 0} {
set status "SERIAL_ERROR_WRITE"
}
}
# serial::putstring Handle String
# Envia uma string para a porta serial.
#
# Argumento:
# Handle Handle para a porta serial.
# String String a ser enviada.
proc serial::putstring {{Handle ""} {String ""}} {
variable handle
# Configura as variaveis do namespace.
if {[string length $Handle] > 0} {
set handle $Handle
}
for {set i 0} {$i < [string length $String]} {incr i} {
serial::putchar $handle [string index $String $i]
}
}
# serial::getchar Handle TimeOut
# Recebe um byte da porta serial.
#
# Argumentos:
# Handle Handle para a porta serial.
# TimeOut Tempo, em milisegundos para que ocorra um TIMEOUT.
#
# Resultados:
# Byte recebido.
proc serial::getchar {{Handle ""} {TimeOut ""}} {
variable handle
variable timeout
variable status "SERIAL_OK"
variable binaryChar ""
variable asciiChar ""
# Configura as variaveis do namespace.
if {[string length $Handle] > 0} {
set handle $Handle
}
# Configura as variaveis do namespace.
if {[string length $TimeOut] > 0} {
set timeout $TimeOut
}
# Aguarda, time milisegundos, por um byte vindo da porta serial.
set Byte ""
set Begin [clock clicks -milliseconds]
while {[expr [clock clicks -milliseconds] - $Begin] < $timeout} {
set Result [catch {
set Byte [read $handle 1]
}]
if {$Result != 0} {
set status "SERIAL_ERROR_READ"
}
if {[string length $Byte] == 1} {
break
}
}
# Salva o byte em formato binario e ASCII para fins de depuracao.
set binaryChar $Byte
binary scan $Byte c asciiChar
return $Byte
}
# serial::getstring Handle Size TimeOut
# Recebe uma string pela porta serial.
#
# Argumentos:
# Handle Handle para a porta serial.
# Size Tamanho em bytes.
# TimeOut Tempo, em milisegundos para que ocorra um TIMEOUT.
#
# Resultados:
# String recebida.
proc serial::getstring {{Handle ""} {Size 254} {TimeOut ""}} {
variable handle
variable timeout
variable status "SERIAL_OK"
variable binaryReceived ""
variable asciiReceived ""
# Configura as variaveis do namespace.
if {[string length $Handle] > 0} {
set handle $Handle
}
set String ""
# Configura as variaveis do namespace.
if {[string length $TimeOut] > 0} {
set timeout $TimeOut
}
for {set i 1} {$i <= $Size} {incr i} {
# Aguarda, time milisegundos, por um byte vindo da porta serial.
set Byte [serial::getchar $handle]
# Se nenhum byte for recebido, ocorreu um TIMEOUT.
if {$Byte == ""} {
if {$status == "SERIAL_OK"} {
set status "SERIAL_ERROR_TIMEOUT"
}
break
}
append String $Byte
}
# Monta a string binaria para fins de depuracao.
append binaryReceived $String
# Monta a string em formato ASCII para fins de depuracao.
set ASCII 0
for {set i 0} {$i < [string length $binaryReceived]} {incr i} {
binary scan [string index $binaryReceived $i] c ASCII
lappend asciiReceived $ASCII
}
# Retorna a string recebida.
return $String
}
# serial::calculateLRC String
# Calcula o LRC ( um XOR de todos od bytes ) da string dada.
#
# Argumentos:
# String String para a qual sera calculado o LRC.
#
# Resultados:
# LRC.
proc serial::calculateLRC {{String ""}} {
set LRC 0
set ASCII 0
for {set i 0} {$i < [string length $String]} {incr i} {
binary scan [string index $String $i] c ASCII
set LRC [expr $LRC ^ $ASCII]
}
return [binary format c $LRC]
}
# serial::calculateCheckSum String
# Calcula o CheckSum ( soma de todos os bytes ) da string dada.
#
# Argumentos:
# String String para a qual sera calculado o CheckSum.
#
# Resultados:
# Lista contendo {CSL CSH} do CheckSum.
proc serial::calculateCheckSum {{String ""}} {
set CheckSum 0
set ASCII 0
for {set i 0} {$i < [string length $String]} {incr i} {
binary scan [string index $String $i] c ASCII
incr CheckSum $ASCII
}
if {$CheckSum >= 256} {
set CSL [binary format c [expr "int($CheckSum % 256)"]]
set CSH [binary format c [expr "int($CheckSum / 256)"]]
} else {
set CSL [binary format c $CheckSum]
set CSH [binary format c 0]
}
return [list $CSL $CSH]
}
# serial::calculateBytes String
# Calcula o numero de bytes da string dada.
#
# Argumentos:
# String String para a qual sera calculado o numero de bytes.
#
# Resultados:
# Lista contendo {NBL NBH} do numero de bytes.
proc serial::calculateBytes {{String ""}} {
set Bytes 0
set ASCII 0
set Bytes [string length $String]
if {$Bytes >= 256} {
set NBL [binary format c [expr "int($Bytes % 256)"]]
set NBH [binary format c [expr "int($Bytes / 256)"]]
} else {
set NBL [binary format c $Bytes]
set NBH [binary format c 0]
}
return [list $NBL $NBH]
}
# serial::sendText Handle String sendLRC
# Envia uma string para a porta serial usando o protocolo:
# <STX>dados<ETX><LRC>
#
# Argumentos:
# Handle Handle para a porta serial.
# String String a ser enviada.
# sendLRC Se 1, sera enviado um LRC de verificacao dos dados,
# se 0, nao sera enviado um LRC de verificacao dos dados.
proc serial::sendText {{Handle ""} {String ""} {sendLRC 1}} {
variable handle
variable binarySent ""
variable asciiSent {}
# Configura as variaveis do namespace.
if {[string length $Handle] > 0} {
set handle $Handle
}
set Text ""
append Text $String
# Inclui o caractere ETX.
append Text "\x03"
# Envia o caractere STX.
serial::putchar $handle "\x02"
# Envia a string.
serial::putstring $handle $Text
# Monta a string binaria para fins de depuracao.
append binarySent "\x02"
append binarySent $Text
# Envia o caractere LRC.
if {$sendLRC == 1} {
serial::putchar $handle [serial::calculateLRC $Text]
append binarySent [serial::calculateLRC $Text]
}
# Monta a string em formato ASCII para fins de depuracao.
set ASCII 0
for {set i 0} {$i < [string length $binarySent]} {incr i} {
binary scan [string index $binarySent $i] c ASCII
lappend asciiSent $ASCII
}
return
}
# serial::receiveText Handle receiveLRC
# Recebe uma string pela a porta serial usando o protocolo:
# <STX>dados<ETX><LRC>
#
# Argumentos:
# Handle Handle para a porta serial.
# receiveLRC Se 1, sera calculado um LRC de verificacao dos dados,
# se 0, nao sera calculado um LRC de verificacao dos dados.
#
# Resultados:
# String recebida.
proc serial::receiveText {{Handle ""} {receiveLRC 1}} {
variable handle
variable status "SERIAL_OK"
variable binaryReceived ""
variable asciiReceived ""
variable checkSumReceived ""
variable checkSumCalculated ""
# Configura as variaveis do namespace.
if {[string length $Handle] > 0} {
set handle $Handle
}
set Text ""
while 1 {
set Byte [serial::getchar $handle]
# Se nenhum byte for recebido, ocorreu um TIMEOUT.
if {$Byte == ""} {
if {$status == "SERIAL_OK"} {
set status "SERIAL_ERROR_TIMEOUT"
}
return
}
# Continua a receber os bytes ate encontrar um caractere STX.
if {$Byte == "\x02"} {
# Armazena o byte recebido.
append Text $Byte
break
}
}
while 1 {
set Byte [serial::getchar $handle]
# Se nenhum byte for recebido, ocorreu um TIMEOUT.
if {$Byte == ""} {
if {$status == "SERIAL_OK"} {
set status "SERIAL_ERROR_TIMEOUT"
}
return
}
# Armazena o byte recebido.
append Text $Byte
# Continua a receber os bytes ate encontrar um caractere ETX.
if {$Byte == "\x03"} {
break
}
}
# Monta a string binaria para fins de depuracao.
append binaryReceived $Text
# Recebe o caractere LRC.
if {$receiveLRC == 1} {
set LRC [serial::getchar $handle]
# Se nenhum byte for recebido, ocorreu um TIMEOUT.
if {$LRC == ""} {
if {$status == "SERIAL_OK"} {
set status "SERIAL_ERROR_TIMEOUT"
}
return
}
set checkSumReceived $LRC
set checkSumCalculated [serial::calculateLRC [string range $Text 1 [expr [string length $Text] - 1]]]
if {$checkSumReceived != $checkSumCalculated} {
set status "SERIAL_ERROR_CHECKSUM"
return
}
# Monta a string binaria para fins de depuracao.
append binaryReceived $LRC
}
# Monta a string em formato ASCII para fins de depuracao.
set ASCII 0
for {set i 0} {$i < [string length $binaryReceived]} {incr i} {
binary scan [string index $binaryReceived $i] c ASCII
lappend asciiReceived $ASCII
}
# Retorna a string recebida.
if {[string length $Text] > 3} {
return [string range $Text 1 [expr [string length $Text] - 2]]
}
}
# serial::sendShift Handle String sendLRC
# Envia uma string para a porta serial usando o protocolo:
# <SI>dados<SO><LRC>
#
# Argumentos:
# Handle Handle para a porta serial.
# String String a ser enviada.
# sendLRC Se 1, sera enviado um LRC de verificacao dos dados,
# se 0, nao sera enviado um LRC de verificacao dos dados.
proc serial::sendShift {{Handle ""} {String ""} {sendLRC 1}} {
variable handle
variable binarySent ""
variable asciiSent {}
# Configura as variaveis do namespace.
if {[string length $Handle] > 0} {
set handle $Handle
}
set Text ""
append Text $String
# Inclui o caractere SO.
append Text "\x0E"
# Envia o caractere SI.
serial::putchar $handle "\x0F"
# Envia a string.
serial::putstring $handle $Text
# Monta a string binaria para fins de depuracao.
append binarySent "\x0F"
append binarySent $Text
# Envia o caractere LRC.
if {$sendLRC == 1} {
serial::putchar $handle [serial::calculateLRC $Text]
append binarySent [serial::calculateLRC $Text]
}
# Monta a string em formato ASCII para fins de depuracao.
set ASCII 0
for {set i 0} {$i < [string length $binarySent]} {incr i} {
binary scan [string index $binarySent $i] c ASCII
lappend asciiSent $ASCII
}
return
}
# serial::receiveShift Handle receiveLRC
# Recebe uma string pela a porta serial usando o protocolo:
# <SI>dados<SO><LRC>
#
# Argumentos:
# Handle Handle para a porta serial.
# receiveLRC Se 1, sera calculado um LRC de verificacao dos dados,
# se 0, nao sera calculado um LRC de verificacao dos dados.
#
# Resultados:
# String recebida.
proc serial::receiveShift {{Handle ""} {receiveLRC 1}} {
variable handle
variable status "SERIAL_OK"
variable binaryReceived ""
variable asciiReceived ""
variable checkSumReceived ""
variable checkSumCalculated ""
# Configura as variaveis do namespace.
if {[string length $Handle] > 0} {
set handle $Handle
}
set Text ""
while 1 {
set Byte [serial::getchar $handle]
# Se nenhum byte for recebido, ocorreu um TIMEOUT.
if {$Byte == ""} {
if {$status == "SERIAL_OK"} {
set status "SERIAL_ERROR_TIMEOUT"
}
return
}
# Continua a receber os bytes ate encontrar um caractere SI.
if {$Byte == "\x0F"} {
# Armazena o byte recebido.
append Text $Byte
break
}
}
while 1 {
set Byte [serial::getchar $handle]
# Se nenhum byte for recebido, ocorreu um TIMEOUT.
if {$Byte == ""} {
if {$status == "SERIAL_OK"} {
set status "SERIAL_ERROR_TIMEOUT"
}
return
}
# Armazena o byte recebido.
append Text $Byte
# Continua a receber os bytes ate encontrar um caractere SO.
if {$Byte == "\x0E"} {
break
}
}
# Monta a string binaria para fins de depuracao.
append binaryReceived $Text
# Recebe o caractere LRC.
if {$receiveLRC == 1} {
set LRC [serial::getchar $handle]
# Se nenhum byte for recebido, ocorreu um TIMEOUT.
if {$LRC == ""} {
if {$status == "SERIAL_OK"} {
set status "SERIAL_ERROR_TIMEOUT"
}
return
}
set checkSumReceived $LRC
set checkSumCalculated [serial::calculateLRC [string range $Text 1 [expr [string length $Text] - 1]]]
if {$checkSumReceived != $checkSumCalculated} {
set status "SERIAL_ERROR_CHECKSUM"
return
}
# Monta a string binaria para fins de depuracao.
append binaryReceived $LRC
}
# Monta a string em formato ASCII para fins de depuracao.
set ASCII 0
for {set i 0} {$i < [string length $binaryReceived]} {incr i} {
binary scan [string index $binaryReceived $i] c ASCII
lappend asciiReceived $ASCII
}
# Retorna a string recebida.
if {[string length $Text] > 3} {
return [string range $Text 1 [expr [string length $Text] - 2]]
}
}
# serial::sendBinary Handle String sendCheckSum
# Envia uma string para a porta serial usando o protocolo:
# <STX><NBL><NBH>dados<CSL><CSH>
#
# Argumentos:
# Handle Handle para a porta serial.
# String String a ser enviada.
# sendCheckSum Se 1, sera enviado um CheckSum de verificacao dos dados,
# se 0, nao sera enviado um CheckSum de verificacao dos dados.
proc serial::sendBinary {{Handle ""} {String ""} {sendCheckSum 1}} {
variable handle
variable binarySent ""
variable asciiSent {}
# Configura as variaveis do namespace.
if {[string length $Handle] > 0} {
set handle $Handle
}
set Text ""
append Text $String
# Inclui a soma de verificacao.
if {$sendCheckSum == 1} {
append Text [join [serial::calculateCheckSum $String] ""]
}
# Inclui o numero de bytes que serao enviados.
set TextToSend ""
append TextToSend [join [serial::calculateBytes $Text] ""] $Text
# Envia o caractere STX.
serial::putchar $handle "\x02"
# Envia a string.
serial::putstring $handle $TextToSend
# Monta a string binaria para fins de depuracao.
append binarySent "\x02"
append binarySent $TextToSend
# Monta a string em formato ASCII para fins de depuracao.
set ASCII 0
for {set i 0} {$i < [string length $binarySent]} {incr i} {
binary scan [string index $binarySent $i] c ASCII
lappend asciiSent $ASCII
}
return
}
# serial::receiveTextETX Handle receiveLRC
# Recebe uma string pela a porta serial usando o protocolo:
# dados<ETX>
#
# Argumentos:
# Handle Handle para a porta serial.
#
# Resultados:
# String recebida.
proc serial::receiveTextETX {{Handle ""}} {
variable handle
variable status "SERIAL_OK"
variable binaryReceived ""
variable asciiReceived ""
# Configura as variaveis do namespace.
if {[string length $Handle] > 0} {
set handle $Handle
}
set Text ""
while 1 {
set Byte [serial::getchar $handle]
# Se nenhum byte for recebido, ocorreu um TIMEOUT.
if {$Byte == ""} {
if {$status == "SERIAL_OK"} {
set status "SERIAL_ERROR_TIMEOUT"
}
return
}
# Armazena o byte recebido.
append Text $Byte
# Continua a receber os bytes ate encontrar um caractere ETX.
if {$Byte == "\x03"} {
break
}
}
# Monta a string binaria para fins de depuracao.
append binaryReceived $Text
# Monta a string em formato ASCII para fins de depuracao.
set ASCII 0
for {set i 0} {$i < [string length $binaryReceived]} {incr i} {
binary scan [string index $binaryReceived $i] c ASCII
lappend asciiReceived $ASCII
}
return $Text
}
# serial::receiveTextCR Handle receiveLRC
# Recebe uma string pela a porta serial usando o protocolo:
# dados<CR>
#
# Argumentos:
# Handle Handle para a porta serial.
#
# Resultados:
# String recebida.
proc serial::receiveTextCR {{Handle ""}} {
variable handle
variable status "SERIAL_OK"
variable binaryReceived ""
variable asciiReceived ""
# Configura as variaveis do namespace.
if {[string length $Handle] > 0} {
set handle $Handle
}
set Text ""
while 1 {
set Byte [serial::getchar $handle]
# Se nenhum byte for recebido, ocorreu um TIMEOUT.
if {$Byte == ""} {
if {$status == "SERIAL_OK"} {
set status "SERIAL_ERROR_TIMEOUT"
}
return
}
# Armazena o byte recebido.
append Text $Byte
# Continua a receber os bytes ate encontrar um caractere CR.
if {$Byte == "\x0d"} {
break
}
}
# Monta a string binaria para fins de depuracao.
append binaryReceived $Text
# Monta a string em formato ASCII para fins de depuracao.
set ASCII 0
for {set i 0} {$i < [string length $binaryReceived]} {incr i} {
binary scan [string index $binaryReceived $i] c ASCII
lappend asciiReceived $ASCII
}
return $Text
}
# serial::binary2ascii String
# Converte uma string binaria para ASCII.
#
# Argumentos:
# String String a ser convertida.
#
# Resultados:
# String em formato ASCII.
proc serial::binary2ascii {{String ""}} {
set ASCII 0
set asciiString ""
# Monta a string em formato ASCII.
for {set i 0} {$i < [string length $String]} {incr i} {
binary scan [string index $String $i] c ASCII
append asciiString $ASCII
}
return $asciiString
}
Biblioteca para comunicação TCP/IP
# Socket.tcl --
#
# Biblioteca para envio e recebimento de bytes por um socket TCP/IP.
#
# RCS: @(#) $Id: Socket.tcl,v 1.0 2001/07/03 16:16:00 monteiro Exp $
#
# Copyright (c) 2001 Roberto Luiz Souza Monteiro.
#
# Este arquivo e distribuido nos termos da licenca GNU GPL.
# Informacoes Tecnicas
# Protocolo:
# Dependendo da aplicacao, pode-se usar um dos protocolos abaixo:
#
# <STX>dados<ETX>
# <STX>dados<ETX><LRC>
#
# <SI>dados<SO><LRC>
#
# <STX><NBL><NBH>dados
# <STX><NBL><NBH>dados<CSL><CSH>
# <STX><NBL><NBH>dados<LRC>
# dados<ETX>
# dados<CR>
#
# Onde LRC( Longitudinal Redundancy Check ) e um caractere de verificacao,
# calculado da seguinte forma:
#
# LRC = dado1 XOR dado2 XOR ... dadosN XOR ETX.
# LRC = dado1 XOR dado2 XOR ... dadosN XOR SO.
#
# NBL = Byte menos significativo da soma do numero de bytes que serao
# enviados( dados + CSL + CSH ).
# NBH = Byte mais significativo da soma do numero de bytes que serao
# enviados( dados + CSL + CSH ).
# CSL = Byte menos significativo da soma dos valores dos bytes que estao
# sendo enviados.
# CSH = Byte mais significativo da soma dos valores dos bytes que estao
# sendo enviados.
#
# Em alguns casos, pode ser conveniente que a cada byte, ou pacote
# enviados, o receptor responda com um caractere ENQ, a fim de
# sincronizar a comunicacao.
#
# Caracteres ASCII de Controle:
# NUL 00h Null.
# SOH 01h
# STX 02h Star of Text.
# ETX 03h End of Text.
# EOT 04h End of Transmission.
# ENQ 05h Enquire.
# ACK 06h Acknowledge.
# BEL 07h Soa um beep.
# BS 08h Backspace.
# HT 09h Horizontal Tabulation.
# NL 0Ah
# VT 0Bh Vertical Tabulation.
# NP, FF 0Ch Form Feed.
# CR 0Dh Carriage Return.
# SO 0Eh Shift Out.
# SI 0Fh Shift In.
# DLE 10h
# XON, DC1 11h
# DC2 12h
# XOFF, DC3 13h
# DC4 14h
# NAK 15h Negative Acknowledge.
# SYN 16h
# ETB 17h
# CAN 18h
# EM 19h
# SUB 1Ah
# ESC 1Bh Escape.
# FS 1Ch Field Separator.
# GS 1Dh
# RS 1Eh
# US 1Fh
#
# Status:
# SOCKET_OK Operacao bem sucedida.
# SOCKET_ERROR_OPEN Nao foi possivel abrir a porta TCP/IP.
# SOCKET_ERROR_CLOSE Nao foi possivel fechar a porta TCP/IP.
# SOCKET_ERROR_READ Nao foi possivel ler a porta TCP/IP.
# SOCKET_ERROR_WRITE Nao foi possivel escrever na porta TCP/IP.
# SOCKET_ERROR_TIMEOUT Ocorreu um Time Out ao tentar ler a porta TCP/IP.
# SOCKET_ERROR_CHECKSUM Soma de verificacao incorreta.
namespace eval Socket:: {
variable handle ""
variable address ""
variable port ""
variable timeout 2000
variable status "SOCKET_OK"
variable binarySent ""
variable asciiSent {}
variable binaryChar ""
variable asciiChar ""
variable binaryReceived ""
variable asciiReceived ""
variable checkSumReceived ""
variable checkSumCalculated ""
}
# Socket::init
# Cria e inicializa as variaveis do namespace.
proc Socket::init {} {
variable handle ""
variable address ""
variable port ""
variable timeout 2000
variable status "SOCKET_OK"
variable binarySent ""
variable asciiSent {}
variable binaryChar ""
variable asciiChar ""
variable binaryReceived ""
variable asciiReceived ""
variable checkSumReceived ""
variable checkSumCalculated ""
}
# Socket::openport Address Port
# Abre e configura a porta TCP/IP.
#
# Argumentos:
# Address Endereco IP do servidor.
# Port Porta no servidor.
#
# Resultados:
# Handle para a porta TCP/IP.
proc Socket::openport {{Address ""} {Port ""}} {
variable handle
variable address
variable port
variable status "SOCKET_OK"
# Configura as variaveis do namespace.
if {[string length $Address] > 0} {
set address $Address
}
if {[string length $Port] > 0} {
set port $Port
}
# Abre e configura a porta TCP/IP.
set Result [catch {
set handle [socket $address $port]
fconfigure $handle -blocking 0 -translation binary
}]
if {$Result != 0} {
set status "SOCKET_ERROR_OPEN"
}
return $handle
}
# Socket::configure Handle
# Abre e configura a porta TCP/IP.
#
# Argumentos:
# Handle Handle para a porta TCP/IP.
#
# Resultados:
# Handle para a porta TCP/IP.
proc Socket::configure {{Handle ""}} {
variable handle
variable status "SOCKET_OK"
# Configura as variaveis do namespace.
if {[string length $Handle] > 0} {
set handle $Handle
}
# Abre e configura a porta TCP/IP.
set Result [catch {
fconfigure $handle -blocking 0 -translation binary
}]
if {$Result != 0} {
set status "SOCKET_ERROR_OPEN"
}
return $handle
}
# Socket::closeport Handle
# Fecha a porta TCP/IP.
#
# Argumentos:
# Handle Handle para a porta TCP/IP.
#
# Resultados:
# 0 se a operacao for concluida com exito.
proc Socket::closeport {{Handle ""}} {
variable handle
variable status "SOCKET_OK"
# Configura as variaveis do namespace.
if {[string length $Handle] > 0} {
set handle $Handle
}
# Fecha a porta TCP/IP.
set Result [catch {
close $handle
}]
if {$Result != 0} {
set status "SOCKET_ERROR_CLOSE"
}
set handle ""
return $Result
}
# Socket::putchar Handle Byte
# Envia um byte para a porta TCP/IP.
#
# Argumento:
# Handle Handle para a porta TCP/IP.
# Byte Byte a ser enviado.
proc Socket::putchar {{Handle ""} {Byte ""}} {
variable handle
variable status "SOCKET_OK"
# Configura as variaveis do namespace.
if {[string length $Handle] > 0} {
set handle $Handle
}
# Envia o byte para a porta TCP/IP.
set Result [catch {
puts -nonewline $handle $Byte
flush $handle
}]
if {$Result != 0} {
set status "SOCKET_ERROR_WRITE"
}
}
# Socket::putstring Handle String
# Envia uma string para a porta TCP/IP.
#
# Argumento:
# Handle Handle para a porta TCP/IP.
# String String a ser enviada.
proc Socket::putstring {{Handle ""} {String ""}} {
variable handle
# Configura as variaveis do namespace.
if {[string length $Handle] > 0} {
set handle $Handle
}
for {set i 0} {$i < [string length $String]} {incr i} {
Socket::putchar $handle [string index $String $i]
}
}
# Socket::getchar Handle TimeOut
# Recebe um byte da porta TCP/IP.
#
# Argumentos:
# Handle Handle para a porta TCP/IP.
# TimeOut Tempo, em milisegundos para que ocorra um TIMEOUT.
#
# Resultados:
# Byte recebido.
proc Socket::getchar {{Handle ""} {TimeOut ""}} {
variable handle
variable timeout
variable status "SOCKET_OK"
variable binaryChar ""
variable asciiChar ""
# Configura as variaveis do namespace.
if {[string length $Handle] > 0} {
set handle $Handle
}
# Configura as variaveis do namespace.
if {[string length $TimeOut] > 0} {
set timeout $TimeOut
}
# Aguarda, time milisegundos, por um byte vindo da porta TCP/IP.
set Byte ""
set Begin [clock clicks -milliseconds]
while {[expr [clock clicks -milliseconds] - $Begin] < $timeout} {
set Result [catch {
set Byte [read $handle 1]
}]
if {$Result != 0} {
set status "SOCKET_ERROR_READ"
}
if {[string length $Byte] == 1} {
break
}
}
# Salva o byte em formato binario e ASCII para fins de depuracao.
set binaryChar $Byte
binary scan $Byte c asciiChar
return $Byte
}
# Socket::getstring Handle Size TimeOut
# Recebe uma string pela porta TCP/IP.
#
# Argumentos:
# Handle Handle para a porta TCP/IP.
# Size Tamanho em bytes.
# TimeOut Tempo, em milisegundos para que ocorra um TIMEOUT.
#
# Resultados:
# String recebida.
proc Socket::getstring {{Handle ""} {Size 254} {TimeOut ""}} {
variable handle
variable timeout
variable status "SOCKET_OK"
variable binaryReceived ""
variable asciiReceived ""
# Configura as variaveis do namespace.
if {[string length $Handle] > 0} {
set handle $Handle
}
set String ""
# Configura as variaveis do namespace.
if {[string length $TimeOut] > 0} {
set timeout $TimeOut
}
for {set i 1} {$i <= $Size} {incr i} {
# Aguarda, time milisegundos, por um byte vindo da porta TCP/IP.
set Byte [Socket::getchar $handle]
# Se nenhum byte for recebido, ocorreu um TIMEOUT.
if {$Byte == ""} {
if {$status == "SOCKET_OK"} {
set status "SOCKET_ERROR_TIMEOUT"
}
break
}
append String $Byte
}
# Monta a string binaria para fins de depuracao.
append binaryReceived $String
# Monta a string em formato ASCII para fins de depuracao.
set ASCII 0
for {set i 0} {$i < [string length $binaryReceived]} {incr i} {
binary scan [string index $binaryReceived $i] c ASCII
lappend asciiReceived $ASCII
}
# Retorna a string recebida.
return $String
}
# Socket::calculateLRC String
# Calcula o LRC ( um XOR de todos od bytes ) da string dada.
#
# Argumentos:
# String String para a qual sera calculado o LRC.
#
# Resultados:
# LRC.
proc Socket::calculateLRC {{String ""}} {
set LRC 0
set ASCII 0
for {set i 0} {$i < [string length $String]} {incr i} {
binary scan [string index $String $i] c ASCII
set LRC [expr $LRC ^ $ASCII]
}
return [binary format c $LRC]
}
# Socket::calculateCheckSum String
# Calcula o CheckSum ( soma de todos os bytes ) da string dada.
#
# Argumentos:
# String String para a qual sera calculado o CheckSum.
#
# Resultados:
# Lista contendo {CSL CSH} do CheckSum.
proc Socket::calculateCheckSum {{String ""}} {
set CheckSum 0
set ASCII 0
for {set i 0} {$i < [string length $String]} {incr i} {
binary scan [string index $String $i] c ASCII
incr CheckSum $ASCII
}
if {$CheckSum >= 256} {
set CSL [binary format c [expr "int($CheckSum % 256)"]]
set CSH [binary format c [expr "int($CheckSum / 256)"]]
} else {
set CSL [binary format c $CheckSum]
set CSH [binary format c 0]
}
return [list $CSL $CSH]
}
# Socket::calculateBytes String
# Calcula o numero de bytes da string dada.
#
# Argumentos:
# String String para a qual sera calculado o numero de bytes.
#
# Resultados:
# Lista contendo {NBL NBH} do numero de bytes.
proc Socket::calculateBytes {{String ""}} {
set Bytes 0
set ASCII 0
set Bytes [string length $String]
if {$Bytes >= 256} {
set NBL [binary format c [expr "int($Bytes % 256)"]]
set NBH [binary format c [expr "int($Bytes / 256)"]]
} else {
set NBL [binary format c $Bytes]
set NBH [binary format c 0]
}
return [list $NBL $NBH]
}
# Socket::sendText Handle String sendLRC
# Envia uma string para a porta TCP/IP usando o protocolo:
# <STX>dados<ETX><LRC>
#
# Argumentos:
# Handle Handle para a porta TCP/IP.
# String String a ser enviada.
# sendLRC Se 1, sera enviado um LRC de verificacao dos dados,
# se 0, nao sera enviado um LRC de verificacao dos dados.
proc Socket::sendText {{Handle ""} {String ""} {sendLRC 1}} {
variable handle
variable binarySent ""
variable asciiSent {}
# Configura as variaveis do namespace.
if {[string length $Handle] > 0} {
set handle $Handle
}
set Text ""
append Text $String
# Inclui o caractere ETX.
append Text "\x03"
# Envia o caractere STX.
Socket::putchar $handle "\x02"
# Envia a string.
Socket::putstring $handle $Text
# Monta a string binaria para fins de depuracao.
append binarySent "\x02"
append binarySent $Text
# Envia o caractere LRC.
if {$sendLRC == 1} {
Socket::putchar $handle [Socket::calculateLRC $Text]
append binarySent [Socket::calculateLRC $Text]
}
# Monta a string em formato ASCII para fins de depuracao.
set ASCII 0
for {set i 0} {$i < [string length $binarySent]} {incr i} {
binary scan [string index $binarySent $i] c ASCII
lappend asciiSent $ASCII
}
return
}
# Socket::receiveText Handle receiveLRC
# Recebe uma string pela a porta TCP/IP usando o protocolo:
# <STX>dados<ETX><LRC>
#
# Argumentos:
# Handle Handle para a porta TCP/IP.
# receiveLRC Se 1, sera calculado um LRC de verificacao dos dados,
# se 0, nao sera calculado um LRC de verificacao dos dados.
#
# Resultados:
# String recebida.
proc Socket::receiveText {{Handle ""} {receiveLRC 1}} {
variable handle
variable status "SOCKET_OK"
variable binaryReceived ""
variable asciiReceived ""
variable checkSumReceived ""
variable checkSumCalculated ""
# Configura as variaveis do namespace.
if {[string length $Handle] > 0} {
set handle $Handle
}
set Text ""
while 1 {
set Byte [Socket::getchar $handle]
# Se nenhum byte for recebido, ocorreu um TIMEOUT.
if {$Byte == ""} {
if {$status == "SOCKET_OK"} {
set status "SOCKET_ERROR_TIMEOUT"
}
return
}
# Continua a receber os bytes ate encontrar um caractere STX.
if {$Byte == "\x02"} {
# Armazena o byte recebido.
append Text $Byte
break
}
}
while 1 {
set Byte [Socket::getchar $handle]
# Se nenhum byte for recebido, ocorreu um TIMEOUT.
if {$Byte == ""} {
if {$status == "SOCKET_OK"} {
set status "SOCKET_ERROR_TIMEOUT"
}
return
}
# Armazena o byte recebido.
append Text $Byte
# Continua a receber os bytes ate encontrar um caractere ETX.
if {$Byte == "\x03"} {
break
}
}
# Monta a string binaria para fins de depuracao.
append binaryReceived $Text
# Recebe o caractere LRC.
if {$receiveLRC == 1} {
set LRC [Socket::getchar $handle]
# Se nenhum byte for recebido, ocorreu um TIMEOUT.
if {$LRC == ""} {
if {$status == "SOCKET_OK"} {
set status "SOCKET_ERROR_TIMEOUT"
}
return
}
set checkSumReceived $LRC
set checkSumCalculated [Socket::calculateLRC [string range $Text 1 [expr [string length $Text] - 1]]]
if {$checkSumReceived != $checkSumCalculated} {
set status "SOCKET_ERROR_CHECKSUM"
return
}
# Monta a string binaria para fins de depuracao.
append binaryReceived $LRC
}
# Monta a string em formato ASCII para fins de depuracao.
set ASCII 0
for {set i 0} {$i < [string length $binaryReceived]} {incr i} {
binary scan [string index $binaryReceived $i] c ASCII
lappend asciiReceived $ASCII
}
# Retorna a string recebida.
if {[string length $Text] > 3} {
return [string range $Text 1 [expr [string length $Text] - 2]]
}
}
# Socket::sendShift Handle String sendLRC
# Envia uma string para a porta TCP/IP usando o protocolo:
# <SI>dados<SO><LRC>
#
# Argumentos:
# Handle Handle para a porta TCP/IP.
# String String a ser enviada.
# sendLRC Se 1, sera enviado um LRC de verificacao dos dados,
# se 0, nao sera enviado um LRC de verificacao dos dados.
proc Socket::sendShift {{Handle ""} {String ""} {sendLRC 1}} {
variable handle
variable binarySent ""
variable asciiSent {}
# Configura as variaveis do namespace.
if {[string length $Handle] > 0} {
set handle $Handle
}
set Text ""
append Text $String
# Inclui o caractere SO.
append Text "\x0E"
# Envia o caractere SI.
Socket::putchar $handle "\x0F"
# Envia a string.
Socket::putstring $handle $Text
# Monta a string binaria para fins de depuracao.
append binarySent "\x0F"
append binarySent $Text
# Envia o caractere LRC.
if {$sendLRC == 1} {
Socket::putchar $handle [Socket::calculateLRC $Text]
append binarySent [Socket::calculateLRC $Text]
}
# Monta a string em formato ASCII para fins de depuracao.
set ASCII 0
for {set i 0} {$i < [string length $binarySent]} {incr i} {
binary scan [string index $binarySent $i] c ASCII
lappend asciiSent $ASCII
}
return
}
# Socket::receiveShift Handle receiveLRC
# Recebe uma string pela a porta TCP/IP usando o protocolo:
# <SI>dados<SO><LRC>
#
# Argumentos:
# Handle Handle para a porta TCP/IP.
# receiveLRC Se 1, sera calculado um LRC de verificacao dos dados,
# se 0, nao sera calculado um LRC de verificacao dos dados.
#
# Resultados:
# String recebida.
proc Socket::receiveShift {{Handle ""} {receiveLRC 1}} {
variable handle
variable status "SOCKET_OK"
variable binaryReceived ""
variable asciiReceived ""
variable checkSumReceived ""
variable checkSumCalculated ""
# Configura as variaveis do namespace.
if {[string length $Handle] > 0} {
set handle $Handle
}
set Text ""
while 1 {
set Byte [Socket::getchar $handle]
# Se nenhum byte for recebido, ocorreu um TIMEOUT.
if {$Byte == ""} {
if {$status == "SOCKET_OK"} {
set status "SOCKET_ERROR_TIMEOUT"
}
return
}
# Continua a receber os bytes ate encontrar um caractere SI.
if {$Byte == "\x0F"} {
# Armazena o byte recebido.
append Text $Byte
break
}
}
while 1 {
set Byte [Socket::getchar $handle]
# Se nenhum byte for recebido, ocorreu um TIMEOUT.
if {$Byte == ""} {
if {$status == "SOCKET_OK"} {
set status "SOCKET_ERROR_TIMEOUT"
}
return
}
# Armazena o byte recebido.
append Text $Byte
# Continua a receber os bytes ate encontrar um caractere SO.
if {$Byte == "\x0E"} {
break
}
}
# Monta a string binaria para fins de depuracao.
append binaryReceived $Text
# Recebe o caractere LRC.
if {$receiveLRC == 1} {
set LRC [Socket::getchar $handle]
# Se nenhum byte for recebido, ocorreu um TIMEOUT.
if {$LRC == ""} {
if {$status == "SOCKET_OK"} {
set status "SOCKET_ERROR_TIMEOUT"
}
return
}
set checkSumReceived $LRC
set checkSumCalculated [Socket::calculateLRC [string range $Text 1 [expr [string length $Text] - 1]]]
if {$checkSumReceived != $checkSumCalculated} {
set status "SOCKET_ERROR_CHECKSUM"
return
}
# Monta a string binaria para fins de depuracao.
append binaryReceived $LRC
}
# Monta a string em formato ASCII para fins de depuracao.
set ASCII 0
for {set i 0} {$i < [string length $binaryReceived]} {incr i} {
binary scan [string index $binaryReceived $i] c ASCII
lappend asciiReceived $ASCII
}
# Retorna a string recebida.
if {[string length $Text] > 3} {
return [string range $Text 1 [expr [string length $Text] - 2]]
}
}
# Socket::sendBinary Handle String sendCheckSum
# Envia uma string para a porta TCP/IP usando o protocolo:
# <STX><NBL><NBH>dados<CSL><CSH>
#
# Argumentos:
# Handle Handle para a porta TCP/IP.
# String String a ser enviada.
# sendCheckSum Se 1, sera enviado um CheckSum de verificacao dos dados,
# se 0, nao sera enviado um CheckSum de verificacao dos dados.
proc Socket::sendBinary {{Handle ""} {String ""} {sendCheckSum 1}} {
variable handle
variable binarySent ""
variable asciiSent {}
# Configura as variaveis do namespace.
if {[string length $Handle] > 0} {
set handle $Handle
}
set Text ""
append Text $String
# Inclui a soma de verificacao.
if {$sendCheckSum == 1} {
append Text [join [Socket::calculateCheckSum $String] ""]
}
# Inclui o numero de bytes que serao enviados.
set TextToSend ""
append TextToSend [join [Socket::calculateBytes $Text] ""] $Text
# Envia o caractere STX.
Socket::putchar $handle "\x02"
# Envia a string.
Socket::putstring $handle $TextToSend
# Monta a string binaria para fins de depuracao.
append binarySent "\x02"
append binarySent $TextToSend
# Monta a string em formato ASCII para fins de depuracao.
set ASCII 0
for {set i 0} {$i < [string length $binarySent]} {incr i} {
binary scan [string index $binarySent $i] c ASCII
lappend asciiSent $ASCII
}
return
}
# Socket::receiveTextETX Handle receiveLRC
# Recebe uma string pela a porta TCP/IP usando o protocolo:
# dados<ETX>
#
# Argumentos:
# Handle Handle para a TCP/IP Socket.
#
# Resultados:
# String recebida.
proc Socket::receiveTextETX {{Handle ""}} {
variable handle
variable status "SOCKET_OK"
variable binaryReceived ""
variable asciiReceived ""
# Configura as variaveis do namespace.
if {[string length $Handle] > 0} {
set handle $Handle
}
set Text ""
while 1 {
set Byte [Socket::getchar $handle]
# Se nenhum byte for recebido, ocorreu um TIMEOUT.
if {$Byte == ""} {
if {$status == "SOCKET_OK"} {
set status "SOCKET_ERROR_TIMEOUT"
}
return
}
# Armazena o byte recebido.
append Text $Byte
# Continua a receber os bytes ate encontrar um caractere ETX.
if {$Byte == "\x03"} {
break
}
}
# Monta a string binaria para fins de depuracao.
append binaryReceived $Text
# Monta a string em formato ASCII para fins de depuracao.
set ASCII 0
for {set i 0} {$i < [string length $binaryReceived]} {incr i} {
binary scan [string index $binaryReceived $i] c ASCII
lappend asciiReceived $ASCII
}
return $Text
}
# Socket::receiveTextCR Handle receiveLRC
# Recebe uma string pela a porta TCP/IP usando o protocolo:
# dados<CR>
#
# Argumentos:
# Handle Handle para a porta TCP/IP.
#
# Resultados:
# String recebida.
proc Socket::receiveTextCR {{Handle ""}} {
variable handle
variable status "SOCKET_OK"
variable binaryReceived ""
variable asciiReceived ""
# Configura as variaveis do namespace.
if {[string length $Handle] > 0} {
set handle $Handle
}
set Text ""
while 1 {
set Byte [Socket::getchar $handle]
# Se nenhum byte for recebido, ocorreu um TIMEOUT.
if {$Byte == ""} {
if {$status == "SOCKET_OK"} {
set status "SOCKET_ERROR_TIMEOUT"
}
return
}
# Armazena o byte recebido.
append Text $Byte
# Continua a receber os bytes ate encontrar um caractere CR.
if {$Byte == "\x0d"} {
break
}
}
# Monta a string binaria para fins de depuracao.
append binaryReceived $Text
# Monta a string em formato ASCII para fins de depuracao.
set ASCII 0
for {set i 0} {$i < [string length $binaryReceived]} {incr i} {
binary scan [string index $binaryReceived $i] c ASCII
lappend asciiReceived $ASCII
}
return $Text
}
# Socket::binary2ascii String
# Converte uma string binaria para ASCII.
#
# Argumentos:
# String String a ser convertida.
#
# Resultados:
# String em formato ASCII.
proc Socket::binary2ascii {{String ""}} {
set ASCII 0
set asciiString ""
# Monta a string em formato ASCII.
for {set i 0} {$i < [string length $String]} {incr i} {
binary scan [string index $String $i] c ASCII
append asciiString $ASCII
}
return $asciiString
}
Para aprender mais sobre programação
em Tcl/Tk adquira o livro Tcl/Tk Guia de Referência, de minha
autoria e editado pela Editora Novatech.
Para maiores informações envie e-mail para info@souzamonteiro.com.
| http://www.souzamonteiro.com |
Copyright(C) 2000 by Roberto Luiz Souza Monteiro