From 04e68443040c7abad84d66477e98f93bed701760 Mon Sep 17 00:00:00 2001 From: Lars-Dominik Braun Date: Mon, 4 Feb 2019 13:09:03 +0100 Subject: Initial import --- system/std.zusatz/1.8.7/src/free channel | 430 +++++++++++++++++++++++++++++++ 1 file changed, 430 insertions(+) create mode 100644 system/std.zusatz/1.8.7/src/free channel (limited to 'system/std.zusatz/1.8.7/src/free channel') diff --git a/system/std.zusatz/1.8.7/src/free channel b/system/std.zusatz/1.8.7/src/free channel new file mode 100644 index 0000000..3814f9d --- /dev/null +++ b/system/std.zusatz/1.8.7/src/free channel @@ -0,0 +1,430 @@ +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 ; + -- cgit v1.2.3