path: root/system/std.zusatz/1.8.7/src/free channel

PACKET free channel DEFINES                       (* Autor: J.Liedtke *)
                                                  (* Stand: 10.06.86  *)
  FCHANNEL ,
  := ,
  free channel ,
  open ,
  close ,
  out ,
  in ,
  dialogue ,
  save ,
  fetch :
 
 

LET ack                = 0 ,
    nak                = 1 ,
    error nak          = 2 ,
    empty message code = 256 ,
    long message code  = 257 ,
    file send code     = 1024 ,
    file receive code  = 2048 ,
    open code          = 1000 ,
    close code         = 1001 ,

    file type          = 1003 ;

INT CONST task not existing := - 1 ;


TYPE FCHANNEL = STRUCT (TASK server, TEXT input buffer, server name) ;

INT VAR message code , response code ;
TASK VAR partner ;
DATASPACE VAR ds ;

BOUND TEXT VAR msg ;
TEXT VAR response, char, esc char , record ;

FILE VAR file ;


OP := (FCHANNEL VAR dest, FCHANNEL CONST source) :
 
  dest.server := source.server ;
  dest.input buffer := "" ;
  dest.server name := source.server name ;
  open (dest)

ENDOP := ;

FCHANNEL PROC free channel (TEXT CONST channel name) :

  FCHANNEL:(niltask,"", channel name)

ENDPROC free channel ;

PROC open (FCHANNEL VAR channel) :

  INT VAR receipt ;
 
  initialize message dataspace ;
  send open code ;
  IF receipt <> ack
    THEN errorstop ("channel not free")
  FI .

initialize message dataspace :
  forget (ds) ;
  ds := nilspace .

send open code :
  ping pong (channel.server, open code, ds, receipt) ;
  IF receipt = task not existing
    THEN channel.server := task (channel.server name) ;
         ping pong (channel.server, open code, ds, receipt)
  FI .
 
ENDPROC open ;

PROC close (FCHANNEL VAR channel) :

  forget (ds) ;
  ds := nilspace ;
  call (channel.server, close code, ds, response code)

ENDPROC close ;

PROC close (TEXT CONST channel server) :

  forget (ds) ;
  ds := nilspace ;
  call (task (channel server), close code, ds, response code)

ENDPROC close ;


PROC out (FCHANNEL VAR channel, TEXT CONST message) :

  send message ;
  get response .

send message :
  IF message = ""
    THEN call (channel.server, empty message code, ds, response code)
    ELSE msg := ds ;
         CONCR (msg) := message ;
         call (channel.server, long message code, ds, response code)
  FI .

get response :
  IF response code < 0
    THEN errorstop ("channel not ready")
  ELIF response code < 256
    THEN channel.input buffer CAT code (response code)
  ELIF response code = long message code
    THEN msg := ds ;
         channel.input buffer CAT CONCR (msg)
  FI .

ENDPROC out ;

PROC in (FCHANNEL VAR channel, TEXT VAR response) :

  out (channel, "") ;
  response := channel.input buffer ;
  channel.input buffer := ""

ENDPROC in ;

PROC save (FCHANNEL VAR channel, TEXT CONST file name, control chars) :

  prepare ds ;
  call (channel.server, file send code, ds, response code) ;
  IF response code = error nak
    THEN BOUND TEXT VAR error msg := ds ;
         errorstop (error msg)
  FI .

prepare ds :
  forget (ds) ;
  ds := old (file name, file type) ;
  FILE VAR f := sequential file (modify, ds) ;
  headline (f, control chars) .

ENDPROC save ;

PROC fetch (FCHANNEL VAR channel, TEXT CONST file name, control chars) :

  IF NOT exists (file name) COR yes ("""" + file name + """ loeschen")
    THEN fetch first part ;
         WHILE more to fetch REP
           fetch next part
         PER
  FI .

fetch first part :
  INT VAR part := 0 ;
  receive file (channel, file name, control chars) .

fetch next part :
  part INCR 1 ;
  receive file (channel, file name + "." + text (part), control chars) .

more to fetch :  response code = file receive code .

ENDPROC fetch ;

PROC receive file (FCHANNEL VAR channel,TEXT CONST file name, control chars):

  prepare ds ;
  call (channel.server, file receive code, ds, response code);
  IF response code = error nak
    THEN BOUND TEXT VAR error msg := ds ;
         errorstop (error msg)
    ELSE forget (file name, quiet) ;
         copy (ds, file name) ;
         forget (ds) ;
         ds := nilspace ;
  FI .

prepare ds :
  forget (ds) ;
  ds := nilspace ;
  BOUND TEXT VAR ctl := ds ;
  ctl := control chars .

ENDPROC receive file ;


PROC dialogue (FCHANNEL CONST channel, TEXT CONST esc) :

  forget (ds) ;
  ds := nilspace ;
  partner := channel.server ;
  esc char := esc ;
  enable stop ;

  response code := empty message code ;
  REP
    get and send message charety ;
    out response option
  PER .

get and send message charety :
  IF response code = empty message code
    THEN char := incharety (10)
    ELSE char := incharety
  FI ;
  IF char = ""
    THEN call (partner, empty message code, ds, response code)
  ELIF char = esc char
    THEN LEAVE dialogue
  ELSE   call (partner, code (char), ds, response code)
  FI .

out response option :
  IF response code < 256
    THEN out (code (response code))
  ELIF response code = long message code
    THEN msg := ds ;
         out (CONCR (msg))
  FI .

ENDPROC dialogue ;

PROC free channel (INT CONST nr) :

  INT CONST my channel := nr ;
  break ;
  disable stop ;
  REP
    wait (ds, message code, partner) ;
    IF message code = open code
      THEN connect to my channel ;
           use channel ;
           break (quiet)
    ELIF message code >= 0
      THEN send (partner, nak, ds)
    FI
  PER .

use channel :
  ping pong (partner, ack, ds, message code) ;
  WHILE message code <> close code AND message code >= 0 REP
    IF   message code <= long message code  THEN dialogue
    ELIF message code =  file receive code  THEN receive file
    ELIF message code =  file send code     THEN send file
    ELIF message code =  open code          THEN ignore open
    ELSE errorstop ("falsche Sendung")
    FI
  UNTIL is error PER ;
  IF is error
    THEN send error message
    ELSE send handshake ack
  FI .

dialogue :
  IF message code < 256
    THEN out (code (message code))
  ELIF message code = long message code
    THEN msg := ds ;
         out (CONCR (msg))
  FI ;
  response := incharety (1) ;
  IF response = ""
    THEN ping pong (partner, empty message code, ds, message code)
    ELSE short or long response
  FI .

short or long response :
  char := incharety ;
  IF char = ""
    THEN short response
    ELSE long response
  FI .

short response :
  ping pong (partner, code (response), ds, message code) .

long response :
  msg := ds ;
  response CAT char ;
  msg := response ;
  REP
    cat input (msg, char) ;
    msg CAT char
  UNTIL char = "" OR LENGTH msg > 500 PER ;
  ping pong (partner, long message code, ds, message code) .

connect to my channel :
  continue (my channel) ;
  WHILE is error REP
    clear error ;
    pause (100) ;
    continue (my channel)
  PER .

send handshake ack :
  send (partner, ack, ds) .

send error message :
  forget (ds) ;
  ds := nilspace ;
  BOUND TEXT VAR error msg := ds ;
  error msg := error message ;
  clear error ;
  send (partner, error nak, ds) .

ignore open :
  ping pong (partner, ack, ds, message code) .

ENDPROC free channel ;

PROC send file :

  enable stop ;
  file := sequential file (input,ds) ;
  get control chars ;
  skip chars ;
  REP
    getline (file, record) ;
    out (record) ;
    end of line
  UNTIL eof (file) PER ;
  end of transmission ;
  send ack reply .

get control chars :
  TEXT CONST
  control chars := headline (file) ,
  end of file char := control chars SUB 1 ,
  end of line char := control chars SUB 2 ,
  handshake   char := control chars SUB 3 .

end of line :
  out (end of line char) ;
  IF handshake char <> ""
    THEN wait for handshake
  FI .

wait for handshake :
  REP
    char := incharety (300) ;
    IF char = ""
      THEN errorstop ("timeout")
    FI
  UNTIL char = handshake char PER .

end of transmission :
  skip chars ;
  out (end of file char) .

skip chars :
  WHILE incharety (3) <> "" REP PER .

send ack reply :
  forget (ds) ;
  ds := nilspace ;
  ping pong (partner, ack, ds, message code) .

ENDPROC send file ;

PROC receive file :

  enable stop ;
  get control chars ;
  open file ;
  INT VAR line no := 0 ;
  REP
    receive line ;
    IF eof received
      THEN ping pong (partner, ack, ds, message code) ;
           LEAVE receive file
    FI ;
    putline (file, record) ;
    line no INCR 1
  UNTIL near file overflow PER ;
  ping pong (partner, file receive code, ds, message code) .

get control chars :
  BOUND TEXT VAR control chars := ds ;
  TEXT CONST
  end of file char := control chars SUB 1 ,
  end of line char := control chars SUB 2 ,
  handshake   char := control chars SUB 3 ,
  handshake prompt := control chars SUB 4 .

open file :
  forget (ds) ;
  ds := nilspace ;
  file := sequential file (output, ds) .

receive line :
  record := "" ;
  REP
    cat input (record, char) ;
    IF char = ""
      THEN wait for char
    FI ;
    IF   char = handshake prompt THEN out (handshake char)
    ELIF char = ""9""            THEN expand tabs
    ELIF char = ""12""           THEN page
    FI
  UNTIL char = end of line char OR char = end of file char PER .

wait for char :
  char := incharety (300) ;
  IF char = ""
    THEN errorstop ("timeout")
  ELIF char >= ""32""
    THEN record CAT char
  FI .

expand tabs:
  record CAT (8-(LENGTH record MOD 8)) * " " .

page:
  record := "#page# " .

eof received :
  char = end of file char OR (record SUB LENGTH record ) = end of file char .

near file overflow :
  line no > 3999 OR (line no > 3800 AND record = "#page# ") .

ENDPROC receive file ;

ENDPACKET free channel ;