Programma di esempio CB1000DB.PRT
; CB1000DB
;
; Programma per Proteus
;
; (C) 2003 Simone Zanella Productions
;
; Salva sul database CODICI.MDB i dati in arrivo da un dispositivo connesso attraverso Ethernet
; Client Bridge (tipo Symbol CB1000). Per il corretto funzionamento è necessario che il CB1000
; sia configurato in modo da accettare connessioni dal PC sul quale viene fatto girare questo 
; programma, il quale può essere installato anche come script associato al servizio Proteus.
;
; I parametri di comunicazione si trovano all'inizio del programma e sono:
; - NETADDR = indirizzo del CB1000
; - NETPORT = porta sulla quale il CB1000 attende la connessione
;
; Il database CODICI.MDB deve avere il seguente formato:
;
; Tabella: Letture
;          Campi: Lettura, tipo testo 50 caratteri, indice "Lettura" univoco
;                 DataOra, tipo Data/ora
;                 Qt, tipo numerico intero lungo

#!proteus -z -j

!include "win32.prt"
!include "socket.prt"
!include "daodefs.prt"

CONST NETADDR = "172.16.0.90"
CONST NETPORT = 4000

HSock = -1

Connetti()
NumBytes = 0
LastTime = W32GETTICKCOUNT()

DBHandle = RSHandle = 0
ApriDB(@DBHandle, "c:\\szp\\codici.mdb")
ApriTab(DBHandle, @RSHandle, "Letture")

WHILE 1
  N = W32IOCTLSOCKET(HSock, FIONREAD, @NumBytes)
  IF AND(EQ(N, 0), GT(NumBytes, 0))
    LastTime = W32GETTICKCOUNT()
    Buffer = REPLICATE(" ", NumBytes)
    N = W32RECV(HSock, @Buffer, 0)
    IF LT(N, 0)
      Connetti()
    ELSE
      RTRIM(@Buffer, CHR(13))
      
      ; Seleziona l'indice "Lettura" sulla tabella "Letture" aperta
      DAORSATTRIB(RSHandle, DAORSATTSETCURRENTINDEX, "Lettura")

      ; Cerca attraverso l'indice il valore acquisito
      IF EQ(DAORSSEEK(RSHandle, "=", Buffer), 1)
        ; Trovato: aumenta di 1 la quantità, aggiorna data e ora di ultima lettura
        DAORSEDIT(RSHandle)
        DAORSSETFIELDVAL(RSHandle, "Qt", INC(DAORSGETFIELDVAL(RSHandle, "Qt")))
        DAORSSETFIELDVAL(RSHandle, "DataOra", DATE() " " TIME())
        DAORSUPDATE(RSHandle)
      ELSE
        ; Non trovato: salva con qt = 1, data e ora correnti
        DAORSADDNEW(RSHandle)
        DAORSSETFIELDVAL(RSHandle, "Lettura", Buffer)
        DAORSSETFIELDVAL(RSHandle, "Qt", 1)
        DAORSSETFIELDVAL(RSHandle, "DataOra", DATE() " " TIME())
        DAORSUPDATE(RSHandle)
      FI      
    FI
  ELSE
    IF LT(N, 0)
      Connetti()
    ELSE
      IF GT(SUB(W32GETTICKCOUNT(), LastTime), 4000)
        IF LT(PING(NETADDR), 0)
          Connetti()
        FI
        LastTime = W32GETTICKCOUNT()
      FI
    FI
  FI
  !ifndef SERVICE  
    IF KBDHIT()
      IF EQ(GETCH(0), 27)
        W32SHUTDOWN(HSock, SD_BOTH)
        W32CLOSESOCKET(HSock)
        ChiudiDB(DBHandle, RSHandle)
        ABORT 0
      FI
    FI    
  !endif
LOOP

ABORT 0


FUNCTION Connetti()

; Se c'era un socket precedentemente aperto, lo chiude
IF NEQ(_HSock, -1)
  W32SHUTDOWN(_HSock, _SD_BOTH)
  W32CLOSESOCKET(_HSock)
FI     
_HSock = -1
WHILE EQ(_HSock, -1)
  ; Crea il socket
  WHILE EQ(_HSock, -1)
    _HSock = W32SOCKET(_AF_INET, _SOCK_STREAM, _IPPROTO_TCP)
    IF EQ(_HSock, -1)
      ; Attende un secondo
      SLEEP(1)
    FI
  LOOP
  
  ; Prova a risolvere l'indirizzo
  nome = netaddr = _NETADDR
  alias = ""
  tipo = 0
  indirizzi = ""
  result = W32GETHOSTBYNAME(@nome, @alias, @tipo, @indirizzi)
  IF EQ(result, 0)
    netaddr = TOKEN(indirizzi, 1, "\t")
  FI 
  
  ; Connette il socket all'indirizzo/porta specificati
  result = W32CONNECT(_HSock, _AF_INET, _NETPORT, netaddr)
  IF EQ(result, -1)
    W32SHUTDOWN(_HSock, _SD_BOTH)
    W32CLOSESOCKET(_HSock)
    _HSock = -1
    ; Attende un secondo
    SLEEP(1)
  FI
LOOP
RETURN


FUNCTION Ping(netaddr)

; Crea il socket
hsock = W32SOCKET(_AF_INET, _SOCK_RAW, _IPPROTO_ICMP)
IF EQ(hsock, -1)
  RETURN -1
FI

; Imposta i timeout in invio e ricezione
IF EQ(W32SETSOCKOPT(hsock, _SOL_SOCKET, _SO_RCVTIMEO, 1000), -1)
  RETURN -2
FI
IF EQ(W32SETSOCKOPT(hsock, _SOL_SOCKET, _SO_SNDTIMEO, 1000), -1)
  RETURN -3
FI

; Prova a risolvere l'indirizzo
nome = netaddr
alias = ""
tipo = 0
indirizzi = ""
result = W32GETHOSTBYNAME(@nome, @alias, @tipo, @indirizzi)
IF EQ(result, 0)
  netaddr = TOKEN(indirizzi, 1, "\t")
FI

; IcmpHeader:
; BYTE i_type  (ECHO = 8)
; BYTE i_code  (= 0)
; WORD i_cksum (= 0)
; WORD i_id    (= ID del processo corrente)
; WORD i_seq   (= 0)
; DWORD timestamp (= Tick Count)

seq = 0
buffer = CHR(8) CHR(0) CHR(0) CHR(0) Word2String(W32GETPROCESSID()) Word2String(seq) LongWord2String(W32GETTICKCOUNT()) \
         REPLICATE("E", SUB(44, 12))
buffer = LEFT(buffer, 2) Word2String(CHECKSUM(buffer)) RESTFROM(buffer, 5)

; Invia il pacchetto di ping  
result = W32SENDTO(hsock, buffer, 0, _AF_INET, 0, netaddr)
IF EQ(result, -1)
  RETURN -4
FI
  
; Riceve la risposta, con timeout
buffer = REPLICATE(" ", 1024)
indirizzo = ""
porta = 0
famiglia = 0
result = W32RECVFROM(hsock, @buffer, 0, @famiglia, @porta, @indirizzo)
IF EQ(result, -1)
  RETURN -5
FI
  
l = MUL(NAND(ASC(LEFT(buffer,1)), 0xF), 4)

; Tipo non-echo
NEWBUF = RESTFROM(buffer, INC(l))
IF NEQ(ASC(SUBSTR(NEWBUF, 1, 1)), 0)
  RETURN -6
FI

; Destinatario errato
IF NEQ(String2Word(SUBSTR(NEWBUF, 5, 2)), W32GETPROCESSID())
  RETURN -7
FI

; Tempo di round-trip in millisecondi
diff = SUB(W32GETTICKCOUNT(), String2LongWord(SUBSTR(NEWBUF, 9, 4)))

; Chiude il socket e ritorna il tempo di round-trip
W32SHUTDOWN(hsock, _SD_BOTH)
W32CLOSESOCKET(hsock)
RETURN diff


FUNCTION CheckSum(s)

; Calcola il checksum sul pacchetto
l = STRLEN(s)
chk = 0
x = 1
WHILE GT(l, 1)
  ADD(@chk, ASC(SUBSTR(s, x, 1)), MUL(ASC(SUBSTR(s, INC(x), 1)), 256))
  SUB(@l, 2)
  ADD(@x, 2)
LOOP
IF l
  ADD(@chk, ASC(SUBSTR(s, x, 1)))
FI
chk = ADD(SHIFTRT(chk, 16), NAND(chk, 0xFFFF))
ADD(@chk, SHIFTRT(chk, 16))
RETURN NAND(NNOT(chk), 0xFFFF)


FUNCTION String2Word(s)

; Converte da binario a word
RETURN NOR( ASC(LEFT(s, 1)), SHIFTLT(ASC(SUBSTR(s, 2, 1)), 8) )


FUNCTION Word2String(n)

; Converte da word a binario
RETURN CHR(NAND(n, 0xFF)) CHR(NAND(SHIFTRT(n, 8), 0xFF))


FUNCTION String2LongWord(s)

; Converte da binario a long word
RETURN NOR(ASC(LEFT(s, 1)), \
           SHIFTLT(ASC(SUBSTR(s, 2, 1)), 8), \
           SHIFTLT(ASC(SUBSTR(s, 3, 1)), 16), \
           SHIFTLT(ASC(SUBSTR(s, 4, 1)), 24))


FUNCTION LongWord2String(n)

; Converte da long word a binario
RETURN CHR(NAND(n, 0xFF)) CHR(NAND(SHIFTRT(n, 8), 0xFF)) CHR(NAND(SHIFTRT(n, 16), 0xFF)) \
       CHR(NAND(SHIFTRT(n, 24), 0xFF))


FUNCTION ApriDB(dbhandle, S)

; Apre il database e segnala eventuali errori
dbhandle = DAODBNEW()
res = DAODBOPEN(dbhandle, S, 0, 0, "") 

; Esempio di apertura database con password:
; res = DAODBOPEN(dbhandle2, "c:\\szp\\letture_protetto.mdb", 0, 0, \
;                 ";PWD=Wg3Tha912;UID=Admin") 

IF EQ(res, -1)
  ; Errore
  PrintErr(dbhandle)
  ABORT 1
FI
RETURN

FUNCTION ApriTab(dbhandle, rshandle, T)

; Apre la tabella del database; segnala eventuali errori
rshandle = DAORSNEW(dbhandle)
res = DAORSOPEN(rshandle, _DAOCOpenTable, T, 0)
IF EQ(res, -1)
  ; Errore
  PrintErr(dbhandle)
  ABORT 1
FI
RETURN

FUNCTION PrintErr(dbhandle)

numerr = DAOERRCOUNT(dbhandle)
FOR x = 1 TO numerr
  CONSOLELN "Errore " x ": " 
  CONSOLELN "Codice     : " DAOGETERRORNUM(dbhandle, x)
  CONSOLELN "Descrizione: " DAOGETERRORDESC(dbhandle, x)
  CONSOLELN "Sorgente   : " DAOGETERRORSRC(dbhandle, x)
  CONSOLELN ""
NEXT
RETURN

FUNCTION ChiudiDB(dbhandle, rshandle)

DAORSCLOSE(rshandle)
DAORSFREE(rshandle)
DAODBCLOSE(dbhandle)
DAODBFREE(dbhandle)
RETURN
Indice esempi Prossimo esempio Esempio precedente Indice per argomenti Indice analitico
Midnight Lake iPhone Case Black Women Shoes Black Flat Shoes Leather Flats Black Patent Ballerinas Black Ballet Shoes Casual Shoes Black Shoes Women Balle Record Player Cufflinks Best iPhone XR Clear Cases iPhone XS/XS Max Leather Cases Sale Best iPhone 8/8 Plus Silicone Cases iPhone 7/7 Plus Cases & Screen Protector New Cases For iPhone 6/6 Plus iPhone 8 Case Sale iPhone Xr Case Online iPhone 7 Case UK Online iPhone X Case UK Sale iPhone X Case Deals iPhone Xs Case New Case For iPhone Xr UK Online Case For iPhone 8 UK Outlet Fashion Silver Cufflinks For Men Best Mens Cufflinks Outlet Online The Gold Cufflinks Shop Online Cheap Shirt Cufflinks On Sale Nice Wedding Cufflinks UK Online Top Black Cufflinks UK Online Mens Cufflinks Online Silver Cufflinks For Men Men Cufflinks UK Sale Gold Cufflinks UK Online Gold Cufflinks UK Silver Cufflinks UK Shirt Cufflinks Discount Online Mens Cufflinks Deals & Sales Girls Shoes For Dance Fashion Ballet Dance Shoes Best Ballet Flats Shoes UK Online Cheap Ballet Pointe Shoes UK Online Best Ballet Shoes Outlet Best Dance Shoes Sale Cheap Ballet Flats Sale UK Best Pointe Shoes Online UK Ballet Dance Shoes UK Shoes For Dance UK Best Ballet Slippers Shop Best Yoga Shoes Hotsell