Contents

Universal serial port behavior

Added on 6/7/1999

Compatibilities:
behavior D6_5 Mac
Required Xtras:
DirectConnection

This item has not yet been rated

Universal serial port behavior for Director 6.5/7

--Updated version to support DirecComm 1.1
--uses the DirectCom Xtra by Tomer Berda (http://www.directxtras.com)
--Lingo is © by Detlef Beyer (d.beyer@crash.de), Cologne
--All properties should be easy to understand - one word about the callback handlers needed. The callback handlers should be the "individual" part of your serial port implementation.
--There should be no need to change this behavior. Instead you use different callback handlers for different tasks.
--There are three callback handlers that can be used for different tasks: one will be call if data was received, one will be called if data was send successfully and the third will be called if an error occured. You will allways need the first and the last but only if you send data you need also number two.
property pSprite,pSerial,pPort,pBaud,pStop,pPari,pDbit,pShak,pBuffer,pMaxBuffer,pListen,pCallBack1,pCallBack2,pCallBack3,pSendBuff,pSendState
property pLastError,pTimeOut,pLastSend,pBuff,pLogOn,pLogCollect,pRetChar,pCallBack4,pSerialReg,pHardTimeOut

on beginSprite me
  -- on beginSprite we initialize a single serial port with the defined parameters
  -- if you like to control more then one port at the same time
  -- (also if you switch between both ports frequently)
  -- you should assign this behavior to two different sprites
  -- and open the needed port with mSetListenOn

  set pListen     = FALSE
  set pBuffer     = ""
  set pSendBuff   = ""
  set pSprite     = the spriteNum of me
  set pLastError  = ""
  set pLastSend   = the ticks
  set pLogOn      = FALSE
  set pLogCollect = ""

  if the machineType = 256 then
    -- we need this char combo to save the text file on windoze
    set pRetChar = numToChar(13) & numToChar(10)
  else
    set pRetChar = RETURN
  end if

  if voidP(pBuff) then set pBuff = 512

  mInitPort(me)
end beginSprite

on endSprite me
  if objectP(pSerial) then mKillMe(me) -- if the port is open, close it
end endSprite

on exitFrame me
  -- read or send data
  if NOT(pListen) then exit
  if NOT(objectP(pSerial)) then exit

  -- send data in chunks
  if pSendBuff <> "" then mSendPart(me)

  -- read data
  set newMsg = ReadComm(pSerial)

  if not(stringP(newMsg)) then
    if pLogOn then mDoErrorLog(me,mGetDirectError(me)) -- write error log?
    set newMsg = ""
  end if

  if newMsg = "" then
    -- no data
    if pLastSend + pTimeOut <= the ticks AND pTimeOut <> 0 then
      -- time out error
      set pLastSend  = the ticks
      set pLastError = "timeout"
    end if
    exit
  else
    -- got data
    set pLastSend = the ticks
    if the number of chars in newMsg >= pBuff then
      -- buffer overflow check
      set err = GetCommError(pSerial)
      if pLogOn and err <> 0 then mDoErrorLog(me,mGetDirectError(me)) -- write error log?
    end if
  end if

  -- store new data into the internal data buffer
  if pMaxBuffer = 0 then
    -- no limited buffer
    put newMsg after pBuffer
  else
    if the number of chars in pBuffer + the number of chars in newMsg < pMaxBuffer then
      put newMsg after pBuffer
    else
      -- clear buffer and add new data
      put newMsg into pBuffer
    end if
  end if
  -- callback to inform about new data
  if pCallBack1 <> "" then do pCallBack1 & "(" & pSprite & ")"
end exitFrame

on mInitPort me
  -- here we prepare the serial port with the needed parameters
  -- if you change the port, this handler has to be called again

  if objectP(pSerial) then mKillMe(me) -- if the port is open, close it

  -- initialize the Xtra
  set pSerial = new(Xtra "DirectCommunication",pSerialReg,string(pPort), pBuff, pBuff)

  if NOT(objectP(pSerial)) then
    -- port open failed, pSerial = 0
    set pSendBuff  = "no serial"
    set pLastError = "no serial port"
    set pSerial    = VOID
    if pCallBack3 <> "" then do pCallBack3 & "(" & pSprite & ")" --error callback
    exit
  end if

  set err = mInitParameters(me)

  if pCallBack4 <> "" AND objectP(pSerial) AND err then do pCallBack4 & "(" & pSprite & ")" -- inform about the successfull start
end mInitPort

on mInitParameters me
  if NOT(objectP(pSerial)) then
    return 0
  else
    -- configuration
    mDoConfigPort(me)

    -- handshake
    case pShak of
      #XON :
        set err = SetCommFlowControl(pSerial, 2)
      #CTS :
        -- CTS/RTS
        set err = SetCommFlowControl(pSerial, 1)
      #DTR :
        -- no flow control
        set err = SetCommFlowControl(pSerial, 0)
    end case
    if err <> 0 then
      return 1
    else
      return 0
    end if
  end if
end mInitParameters

on mDoErrorLog me,newMsg
  -- write an error log
  if newMsg <> "" then
    set resultStr = ""

    set pLogCollect = pLogCollect & newMsg & pRetChar
  end if
end mDoErrorLog

on mSetLogState me,wichState
  -- switch the log on/off
  set pLogOn = wichState
  if pLogOn then
    set pLogCollect = the date && the time && "(" & the machineType & ", " & string(pPort) & ")" & pRetChar
  end if
end mSetLogState

on mGetLogFile me
  -- return log text
  return pLogCollect
end mGetLogFile

on mChangePort me,newPort
  -- this handler should be called to change the port
  if newPort = pPort then exit

  set pPort = newPort

  mInitPort(me)
end mChangePort

on mReturnError me
  return pLastError
end mReturnError

on mSetListenOn me,wichState
  -- start listening the port
  if NOT(objectP(pSerial)) then exit

  set pListen = wichState
end mSetListenOn

on mReturnBuffer me,clearBuffer
  -- return the data collected so far
  if NOT(objectP(pSerial)) then
    set retVal = ""
  else
    set retVal = pBuffer
    if clearBuffer then
      set pBuffer = ""
      set err = FlushComm(pSerial)
      if err = 0 then
        if pLogOn then mDoErrorLog(me,mGetDirectError(me)) -- write error log?
      end if
    end if
  end if

  return retVal
end mReturnBuffer

-- Send

on mSendBinary me, myhex
  -- will send a hex string as binary data
  -- like "0A FF 10 03"
  if NOT(objectP(pSerial)) then exit

  set oldDel = the itemDelimiter
  set the itemDelimiter = " "
  repeat with x = 1 to the number of items in myhex
    -- WriteComm will return the number of bytes send
    set err = WriteComm(pSerial,numtochar(mHexToDec(me,item x of myhex)))
    if err = 0 then exit repeat
  end repeat
  if err = 0 then
    -- callback informs about error
    set pSendState = GetCommError(pSerial)
    if pLogOn then mDoErrorLog(me,mGetDirectError(me)) -- write error log?
    if pCallBack3 <> "" then
      do pCallBack3 & "(" & pSprite & ")" -- error callback
    end if
  else
    set pSendState = 1
  end if
end mSendBinary

on mSendString me,wichMsg
  if NOT(objectP(pSerial)) then
    set err = -1
  else
    -- a maximum of 256 chars at once
    if the number of chars in wichMsg > 256 then
      -- store data into an output buffer
      set pSendBuff  = wichMsg
      set pSendState = 0
      set err = 2
    else
      -- send everything at once
      -- WriteComm will return the number of bytes send
      set err = WriteComm(pSerial,wichMsg)
      if err = 0 then
        set err = -1
        set pSendState = GetCommError(pSerial)
        if pLogOn then mDoErrorLog(me,mGetDirectError(me)) -- write error log?
        if pCallBack3 <> "" then
          do pCallBack3 & "(" & pSprite & ")" -- error callback
        end if
      else
        -- callback informs about finish
        if pCallBack2 <> "" then do pCallBack2 & "(" & pSprite & ")"
        set err = 1
        set pSendState = 1
      end if
    end if
  end if

  return err
end mSendString

on mSendPart me
  -- send the output buffer in chunks of 256 chars
  if NOT(objectP(pSerial)) then exit

  if the number of chars in pSendBuff > 256 then
    set newMsg    = char 1 to 256 of pSendBuff
    set pSendBuff = char 257 to length(pSendBuff) of pSendBuff
    -- WriteComm will return the number of bytes send
    set err =  WriteComm(pSerial,newMsg)
    if err = 0 then
      set pSendState = GetCommError(pSerial)
      if pLogOn then mDoErrorLog(me,mGetDirectError(me)) -- write error log?
      set pSendBuff = ""
      if pCallBack3 <> "" then
        do pCallBack3 & "(" & pSprite & ")" -- error callback
      end if
    end if
  else
    set err = WriteComm(pSerial,pSendBuff)
    set pSendBuff = ""
    if err = 0 then
      if pCallBack3 <> "" then
        do pCallBack3 & "(" & pSprite & ")" -- error callback
      end if
      set pSendState = GetCommError(pSerial)
    else
      set pSendState = 1
    end if
    -- callback informs about finish
    if pCallBack2 <> "" then do pCallBack2 & "(" & pSprite & ")"
  end if
end mSendPart

on mSendESC me,wichOne
  if NOT(objectP(pSerial)) then exit

  set para = 0

  case wichOne of
    #clearDTR :
      -- Clears the DTR (data-terminal-ready) signal.
      set para = 1
    #sendDTR :
      -- Sends the DTR (data-terminal-ready) signal.
      set para = 2
    #clearRTS :
      -- Clears the RTS (request-to-send) signal (Not available in MacOS version).
      if the machineType = 256 then set para = 3
    #sendRTS :
      -- Sends the RTS (request-to-send) signal (Not available in MacOS version).
      if the machineType = 256 then set para = 4
    #getXON :
      -- Causes transmission to act as if an XON character has been received.
      set para = 5
    #getXOFF :
      -- Causes transmission to act as if an XOFF character has been received.
      set para = 6
    #restore :
      -- Restores character transmission and places the transmission line in a nonbreak state.
      set para = 7
    #suspend :
      -- Suspends character transmission and places the transmission line in a break state until this function is called again with
      set para = 8
  end case

  if para <> 0 then EscapeComm(pSerial, para)
end mSendESC

on mGetDirectError me
  set err = GetCommError(pSerial)

  case err of
    0 :
      return ""
    -1 :
      return "An input buffer overflow has occurred"
    -2 :
      return "The hardware detected a parity error"
    -3 :
      return "A character-buffer overrun has occurred. The next character is lost"
    -4 :
      return "The hardware detected a framing error."
    -5 :
      return "The hardware detected a break condition."
  end case
end mGetDirectError

on mGetLastSendErr me
  return pSendState
end mGetLastSendErr

--

on mDoConfigPort me
  -- set the config for the DirectCom Xtra
  if NOT(objectP(pSerial)) then exit

  set err = SetCommBaudRate(pSerial, value(string(pBaud)))

  -- if we use a unusal baud-rate, let's check what has been accepted
  set pBaud = symbol(string(GetCommBaudRate(pSerial)))

  case pStop of
    #1 :
      set err = SetCommStopBits(pSerial, 0)
    #1.5 :
      set err = SetCommStopBits(pSerial, 1)
    #2 :
      set err = SetCommStopBits(pSerial, 2)
  end case

  case pPari of
    #no :
      set err = SetCommParity(pSerial, 0)
    #odd :
      set err = SetCommParity(pSerial, 1)
    #even :
      set err = SetCommParity(pSerial, 2)
  end case

  if the machineType = 256 and pHardTimeOut <> 0 then
    SetCommTimeOut(pSerial, pHardTimeOut)
  end if

  set err = SetCommDataBits(pSerial, value(string(pDbit)))
end mDoConfigPort

on mKillMe me
  -- kill the serial port object
  if objectP(pSerial) then set dummy = mReturnBuffer(me,true)
  set pSerial = 0
  set pSerial = VOID
  set pListen = FALSE
end mKillMe

-- Utilities --

on mHexToDec me,myText
  set myText = mRemoveSpaces(me,myText)

  set sum   = 0
  set len   = length(myText)
  set place = 0
  repeat with i = len down to 1
    set sum   = sum + mHexValue(me,char i of myText) * power(16, place)
    set place = place + 1
  end repeat
  if sum > the maxInteger then
    return sum
  else
    return integer(sum)
  end if
end mHexToDec

on mHexValue me, letter
  set val to value(letter)

  if NOT voidP(val) then return val
  else
    case letter of
      "A":return 10
      "B":return 11
      "C":return 12
      "D":return 13
      "E":return 14
      "F":return 15
      otherwise
        -- error
        return 0
    end case
  end if
end mHexValue

on mRemoveSpaces me,myText
  repeat while myText contains(" ")
    delete char offset(" ", myText) of myText
  end repeat

  return myText
end mRemoveSpaces

on mGetStringFrom me,myLine,myDelim,retFlag
  if myLine <> "" then
    if offset(myDelim, myLine) > 0 then
      return char 1 to (offset(myDelim, myLine) - 1) of myLine
    else
      if retFlag then
        return myLine
      else
        return ""
      end if
    end if
  else
    return ""
  end if
end mGetStringFrom

--

on mGetInfo me
  return "Serial Port:" && string(pPort) && "(" && string(pBaud) & "," & string(pDBit) & "," &¬
         string(pPari) & "," & string(pStop) & "," & string(pShak) & ")"
end mGetInfo

--

on getPropertyDescriptionList
  set description = [:]
  if the machineType <> 256 then
    addProp(description,#pPort,[#default:#modem, #format:#symbol, #comment:"Port", #range:[#modem,#printer]])
  else
    addProp(description,#pPort,[#default:#COM1, #format:#symbol, #comment:"Port", #range:[#COM1,#COM2,#COM3,#COM4,#LPT1]])
  end if
  addProp(description,#pBuff,[#default:512, #format:#integer, #comment:"Internal Buffer Size", #range:[512,1024,2048]])
  addProp(description,#pBaud,[#default:#9600, #format:#symbol, #comment:"Baudrate", #range:[#300,#600,#1200,#2400,#4800,#9600,#19200,#38400,#57600]])
  addProp(description,#pStop,[#default:#1, #format:#symbol, #comment:"Stop-bit", #range:[#1,#1.5,#2]])
  addProp(description,#pPari,[#default:#no, #format:#symbol, #comment:"Parity", #range:[#no,#odd,#even]])
  addProp(description,#pDbit,[#default:#8, #format:#symbol, #comment:"Data-bits", #range:[#5,#6,#7,#8]])
  addProp(description,#pShak,[#default:#DTR, #format:#symbol, #comment:"Handshake", #range:[#XON,#CTS,#DTR]])
  addProp(description,#pMaxBuffer,[#default:0, #format:#integer, #comment:"Buffer size", #range:[#min : 0,#max : 32000]])
  addProp(description,#pCallBack1,[#default:"", #format:#string, #comment:"Receive Callback handler"])
  addProp(description,#pCallBack2,[#default:"", #format:#string, #comment:"Send Callback handler"])
  addProp(description,#pCallBack3,[#default:"", #format:#string, #comment:"Error Callback handler"])
  addProp(description,#pCallBack4,[#default:"", #format:#string, #comment:"StartUp Callback handler"])
  addProp(description,#pTimeOut,[#default:120, #format:#integer, #comment:"TimeOut in ticks", #range:[#min : 0,#max : 3600]])
  addProp(description,#pHardTimeOut,[#default:0, #format:#integer, #comment:"Hard TimeOut in ms (Win only), 0=off"])
  addProp(description,#pSerialReg,[#default:0, #format:#integer, #comment:"Serialnumber"])

  return description
end getPropertyDescriptionList

on getBehaviorDescription
  set myDesc = "Universal serial port behavior for Director6" & RETURN
  set myDesc = myDesc & "uses the DirectCom Xtra by Tomer Berda (http://www.directxtras.com/)" & RETURN
  set myDesc = myDesc & "Lingo is © by Detlef Beyer (d.beyer@hermes.de), Cologne"

  return myDesc
end getBehaviorDescription

Contact

MMI
36 South Court Sq
Suite 300
Newnan, GA 30263
USA

Send e-mail