text:
Oberon/ETH Oberon/2.3.7/FTP.Mod

(* ETH Oberon, Copyright 1990-2003 Computer Systems Institute, ETH Zurich, CH-8092 Zurich. Refer to the license.txt file provided with this distribution. *) MODULE FTP; (** portable *)	(* ejz, *) IMPORT Files, Strings, Input, Display, Fonts, Texts, Oberon, NetSystem; (** A simple single session FTP Tool using commands. Useful for transfering many files to or from the 		same server. *) CONST MaxLine = 1024; BufLen = MaxLine; Tab = 9X; Esc = 01BX; BreakChar = Esc; Done = 0; NotReady = 1; NotConnected = 2; WrongUser = 3; WrongPassword = 4; TimedOut = 5; LocFileNotFound = 6; Interrupted = 7; Disconnected = 8; Failed = MAX(INTEGER); MinDataPort = 1100; MaxDataPort = 1500; Unknown = -1; UNIX = 0; VMS = 1; DefConPort = 21; TYPE Session = POINTER TO SessionDesc; SessionDesc = RECORD C: NetSystem.Connection; dataC: NetSystem.Connection; reply: ARRAY MaxLine OF CHAR; usr, passw, host, portIPAddress: ARRAY 64 OF CHAR; dataIP: NetSystem.IPAdr; dataPort, status, system, res: INTEGER; ack: BOOLEAN END; EnumProc = PROCEDURE (entry: ARRAY OF CHAR); VAR S: Session; W: Texts.Writer; log: Texts.Text; line: ARRAY MaxLine OF CHAR; buffer: ARRAY BufLen OF CHAR; timeOut: LONGINT; dataPort, col: INTEGER; PROCEDURE Connected(C: NetSystem.Connection; mode: INTEGER): BOOLEAN; VAR state: INTEGER; BEGIN state := NetSystem.State(C); RETURN state IN {mode, NetSystem.inout} END Connected; PROCEDURE Disconnect(VAR C: NetSystem.Connection); BEGIN IF C # NIL THEN NetSystem.CloseConnection(C) END; C := NIL END Disconnect; PROCEDURE Connect(VAR C: NetSystem.Connection; port: INTEGER; host: ARRAY OF CHAR): BOOLEAN; VAR adr: NetSystem.IPAdr; res: INTEGER; BEGIN NetSystem.GetIP(host, adr); IF adr = NetSystem.anyIP THEN C := NIL; RETURN FALSE END; NetSystem.OpenConnection(C, NetSystem.anyport, adr, port, res); IF res # NetSystem.done THEN C := NIL END; RETURN res = NetSystem.done END Connect; PROCEDURE UserBreak: BOOLEAN; VAR ch: CHAR; BEGIN IF Input.Available > 0 THEN Input.Read(ch); IF ch = BreakChar THEN Texts.WriteString(W, "interrupted"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); RETURN TRUE END END; RETURN FALSE END UserBreak; PROCEDURE ReadResponse(S: Session; VAR sline: ARRAY OF CHAR); VAR time, i, j, cpos: LONGINT; code: ARRAY 8 OF CHAR; line: ARRAY MaxLine OF CHAR; BEGIN IF ~Connected(S.C, NetSystem.in) THEN COPY("Connection closed by server.", sline); COPY(sline, S.reply); S.status := 0; S.res := Disconnected; RETURN END; time := NetSystem.Available(S.C); NetSystem.ReadString(S.C, line); IF log # NIL THEN Texts.WriteString(W, line); Texts.WriteLn(W); Texts.Append(log, W.buf) END; Strings.StrToInt(line, time); S.status := SHORT(time); Strings.IntToStr(time, code); cpos := 0; WHILE code[cpos] # 0X DO 			INC(cpos) END; i := cpos+1; j := 0; WHILE line[i] # 0X DO 			sline[j] := line[i]; INC(j); INC(i) END; sline[j] := 0X; time := Input.Time; IF line[cpos] = "-" THEN LOOP IF NetSystem.Available(S.C) > 0 THEN line[cpos] := 0X; NetSystem.ReadString(S.C, line); IF log # NIL THEN Texts.WriteString(W, line); Texts.WriteLn(W); Texts.Append(log, W.buf) END; IF line[cpos] # "-" THEN line[cpos] := 0X; IF line = code THEN EXIT END END; time := Input.Time ELSIF (Input.Time-time) >= timeOut THEN S.res := TimedOut; RETURN ELSIF UserBreak THEN S.res := Interrupted; RETURN END END END; S.ack := TRUE END ReadResponse; PROCEDURE SendString(C: NetSystem.Connection; str: ARRAY OF CHAR); VAR i: LONGINT; BEGIN i := 0; WHILE str[i] # 0X DO 			INC(i) END; NetSystem.WriteBytes(C, 0, i, str) END SendString; PROCEDURE SendLine(C: NetSystem.Connection; VAR str: ARRAY OF CHAR); BEGIN SendString(C, str); NetSystem.WriteBytes(C, 0, 2, Strings.CRLF) END SendLine; PROCEDURE SendCmd(S: Session; str: ARRAY OF CHAR); BEGIN IF ~S.ack THEN ReadResponse(S, line) ELSE S.ack := FALSE END; SendLine(S.C, str) END SendCmd; PROCEDURE CloseS(S: Session); BEGIN S.ack := TRUE; SendCmd(S, "QUIT"); ReadResponse(S, S.reply); Disconnect(S.dataC); Disconnect(S.C); S.res := Done END CloseS; PROCEDURE Close2(S: Session); BEGIN S.ack := TRUE; SendCmd(S, "QUIT"); Disconnect(S.dataC); Disconnect(S.C) 	END Close2; PROCEDURE QuerySystem(S: Session); VAR pos: LONGINT; BEGIN S.system := UNIX; SendCmd(S, "SYST"); ReadResponse(S, line); IF (S.status >= 200) & (S.status < 300) THEN pos := 0; Strings.Search("VMS", line, pos); IF pos >= 0 THEN S.system := VMS END END END QuerySystem; PROCEDURE QueryString(key: ARRAY OF CHAR; VAR s: ARRAY OF CHAR): BOOLEAN; VAR S: Texts.Scanner; lKey: ARRAY 32 OF CHAR; BEGIN lKey := "NetSystem."; Strings.Append(lKey, key); Oberon.OpenScanner(S, lKey); IF S.class IN {Texts.Name, Texts.String} THEN COPY(S.s, s) 		ELSE COPY("", s) 		END; RETURN s # "" END QueryString; PROCEDURE GetLogin(VAR host, usr, passw: ARRAY OF CHAR); BEGIN IF (usr = "ftp") OR (usr = "anonymous") OR (usr = "") THEN IF ~QueryString("EMail", passw) OR (passw[0] = "<") THEN COPY("anonymous@host.nowhere", passw) END; IF usr = "" THEN COPY("anonymous", usr) END ELSIF passw = "" THEN NetSystem.GetPassword("ftp", host, usr, passw) END END GetLogin; PROCEDURE OpenS(server, user, passwd: ARRAY OF CHAR; port: INTEGER; VAR S: Session); BEGIN NEW(S); S.dataC := NIL; COPY(server, S.host); S.dataPort := -1; COPY(user, S.usr); COPY(passwd, S.passw); GetLogin(server, S.usr, S.passw); IF NetSystem.hostIP = NetSystem.anyIP THEN S.C := NIL; S.reply := "invalid NetSystem.hostIP"; S.res := Failed; RETURN END; S.system := Unknown; S.reply := "connecting failed"; S.portIPAddress := ""; S.ack := TRUE; IF (S.usr = "") OR (S.passw = "") THEN S.res := Failed; S.reply := "no password or username specified"; RETURN END; IF Connect(S.C, port, server) THEN ReadResponse(S, S.reply); IF (S.status >= 200) & (S.status < 300) THEN line := "USER "; Strings.Append(line, S.usr); SendCmd(S, line); ReadResponse(S, line); IF (S.status = 330) OR (S.status = 331) THEN line := "PASS "; Strings.Append(line, S.passw); SendCmd(S, line); ReadResponse(S, line); IF (S.status = 230) OR (S.status= 330) THEN S.res := Done ELSE S.res := WrongPassword; COPY(line, S.reply); Close2(S) END ELSIF S.status # 230 THEN S.res := WrongUser; COPY(line, S.reply); Close2(S) ELSE S.res := Done END; IF S.res # Done THEN NetSystem.DelPassword("ftp", S.usr, server) END ELSE S.res := NotReady; Close2(S) END ELSE S.res := NotConnected END; IF S.res = Done THEN SendCmd(S, "TYPE I"); ReadResponse(S, line); IF S.status # 200 THEN (* should not happen *) END; QuerySystem(S); S.res := Done END END OpenS; PROCEDURE ChangeDirS(S: Session; newDir: ARRAY OF CHAR); BEGIN S.reply := "CWD "; Strings.Append(S.reply, newDir); SendCmd(S, S.reply); ReadResponse(S, S.reply); IF S.status = 250 THEN S.res := Done ELSE S.res := Failed END END ChangeDirS; PROCEDURE SetDataPort(S: Session); VAR str: ARRAY 4 OF CHAR; p0, p1: LONGINT; i, j, k: INTEGER; done: BOOLEAN; BEGIN SendCmd(S, "PASV"); ReadResponse(S, line); IF (S.status >= 200) & (S.status < 300) THEN S.res := Interrupted; i := 0; WHILE (line[i] # 0X) & ~Strings.IsDigit(line[i]) DO INC(i) END; j := 0; k := 0; WHILE (line[i] # 0X) & (k < 4) DO 				IF line[i] # "," THEN S.portIPAddress[j] := line[i] ELSE S.portIPAddress[j] := "."; INC(k) END; INC(i); INC(j) END; IF (j <= 0) & (k < 4) THEN RETURN END; S.portIPAddress[j-1] := 0X; NetSystem.ToHost(S.portIPAddress, S.dataIP, done); IF ~done THEN RETURN END; WHILE (line[i] # 0X) & ((line[i] <= " ") OR (line[i] = ",")) DO INC(i) END; Strings.StrToIntPos(line, p0, i); WHILE (line[i] # 0X) & ((line[i] <= " ") OR (line[i] = ",")) DO INC(i) END; Strings.StrToIntPos(line, p1, i); S.dataPort := SHORT(256*p0+p1); S.res := Done ELSE S.dataIP := NetSystem.anyIP; S.dataPort := dataPort; REPEAT IF S.dataPort >= MaxDataPort THEN S.dataPort := MinDataPort END; INC(S.dataPort); (* not 100% safe *) NetSystem.OpenConnection(S.dataC, S.dataPort, NetSystem.anyIP, NetSystem.anyport, S. res) UNTIL (S.res = NetSystem.done) OR UserBreak; IF S.res = NetSystem.done THEN dataPort := S.dataPort; S.res := Failed; NetSystem.ToNum(NetSystem.hostIP, S.portIPAddress); i := 0; WHILE S.portIPAddress[i] # 0X DO IF S.portIPAddress[i] = "." THEN S.portIPAddress[i] := "," END; INC(i) END; Strings.AppendCh(S.portIPAddress, ","); Strings.IntToStr(S.dataPort DIV 256, str); Strings.Append(S.portIPAddress, str); Strings.AppendCh(S.portIPAddress, ","); Strings.IntToStr(S.dataPort MOD 256, str); Strings.Append(S.portIPAddress, str); line := "PORT "; Strings.Append(line, S.portIPAddress); SendCmd(S, line) ELSE Disconnect(S.dataC); S.dataC := NIL; S.reply := "Interrupted"; S.res := Interrupted END END END SetDataPort; PROCEDURE WaitDataCon(S: Session): NetSystem.Connection; VAR C1: NetSystem.Connection; time: LONGINT; BEGIN IF S.dataIP = NetSystem.anyIP THEN time := Input.Time; REPEAT UNTIL NetSystem.Requested(S.dataC) OR ((Input.Time-time) > timeOut) OR UserBreak; IF NetSystem.Requested(S.dataC) THEN NetSystem.Accept(S.dataC, C1, S.res); Disconnect(S.dataC); IF S.res = NetSystem.done THEN S.res := Done; RETURN C1 				ELSE S.res := Failed END ELSIF (Input.Time-time) > timeOut THEN S.res := TimedOut ELSE S.res := Interrupted END; Disconnect(S.dataC) ELSE NetSystem.OpenConnection(C1, NetSystem.anyport, S.dataIP, S.dataPort, S.res); IF S.res = Done THEN RETURN C1 END END; RETURN NIL END WaitDataCon; PROCEDURE EnumDir(S: Session; enum: EnumProc); VAR C: NetSystem.Connection; len: LONGINT; BEGIN S.reply := ""; SetDataPort(S); C := NIL; IF S.res = Interrupted THEN RETURN END; IF S.dataIP = NetSystem.anyIP THEN ReadResponse(S, line) ELSE C := WaitDataCon(S); IF S.res = Done THEN S.status := 200 END END; IF S.status = 200 THEN IF S.system = VMS THEN SendCmd(S, "NLST") ELSE SendCmd(S, "LIST") END; ReadResponse(S, S.reply); IF (S.status = 150) OR (S.status = 250) THEN IF S.dataIP = NetSystem.anyIP THEN C := WaitDataCon(S) END; IF S.res = Done THEN S.res := Done; len := NetSystem.Available(C); WHILE ((len > 0) OR Connected(C, NetSystem.in)) & ~UserBreak DO 						IF len > 0 THEN NetSystem.ReadString(C, line); enum(line) END; len := NetSystem.Available(C) END END; Disconnect(C);	(* before ReadResponse *) ReadResponse(S, S.reply) ELSE S.res := Failed END END; IF C # NIL THEN Disconnect(C) END; IF S.dataC # NIL THEN Disconnect(S.dataC) END END EnumDir; PROCEDURE GetCurDir(S: Session; VAR curdir: ARRAY OF CHAR); VAR i, j: INTEGER; BEGIN SendCmd(S, "PWD"); ReadResponse(S, S.reply); IF S.status = 257 THEN IF S.system = VMS THEN COPY(S.reply, curdir); i := 0; WHILE curdir[i] > " " DO 					INC(i) END; curdir[i] := 0X ELSE i := 0; WHILE (S.reply[i] # 0X) & (S.reply[i] # 22X) DO 					INC(i) END; j := 0; IF S.reply[i] = 22X THEN INC(i); WHILE (S.reply[i] # 0X) & (S.reply[i] # 22X) DO 						curdir[j] := S.reply[i]; INC(j); INC(i) END END; curdir[j] := 0X END; S.res := Done ELSE COPY("", curdir); S.res := Failed END END GetCurDir; PROCEDURE MakeDirS(S: Session; newDir: ARRAY OF CHAR); BEGIN S.reply := "MKD "; Strings.Append(S.reply, newDir); SendCmd(S, S.reply); ReadResponse(S, S.reply); IF S.status = 257 THEN S.res := Done ELSE S.res := Failed END END MakeDirS; PROCEDURE RmDirS(S: Session; dir: ARRAY OF CHAR); BEGIN S.reply := "RMD "; Strings.Append(S.reply, dir); SendCmd(S, S.reply); ReadResponse(S, S.reply); IF S.status = 250 THEN S.res := Done ELSE S.res := Failed END END RmDirS; PROCEDURE DeleteFile(S: Session; remName: ARRAY OF CHAR); BEGIN S.reply := "DELE "; Strings.Append(S.reply, remName); SendCmd(S, S.reply); ReadResponse(S, S.reply); IF S.status = 250 THEN S.res := Done ELSE S.res := Failed END END DeleteFile; PROCEDURE ReadData(S: Session; C: NetSystem.Connection; VAR R: Files.Rider); VAR len, rlen: LONGINT; BEGIN len := NetSystem.Available(C); WHILE (len > 0) OR Connected(C, NetSystem.in) DO 			IF len > BufLen THEN rlen := BufLen ELSE rlen := len END; NetSystem.ReadBytes(C, 0, rlen, buffer); Files.WriteBytes(R, buffer, rlen); DEC(len, rlen); IF len <= 0 THEN IF UserBreak THEN RETURN END; len := NetSystem.Available(C) END END END ReadData; PROCEDURE GetF(S: Session; remName: ARRAY OF CHAR; VAR R: Files.Rider); VAR C: NetSystem.Connection; BEGIN S.reply := ""; SetDataPort(S); C := NIL; IF S.res = Interrupted THEN RETURN END; IF S.dataIP = NetSystem.anyIP THEN ReadResponse(S, line) ELSE C := WaitDataCon(S); IF S.res = Done THEN S.status := 200 END END; IF S.status = 200 THEN line := "RETR "; Strings.Append(line, remName); SendCmd(S, line); ReadResponse(S, line); COPY(line, S.reply); IF (S.status = 150) OR (S.status = 250) THEN IF S.dataIP = NetSystem.anyIP THEN C := WaitDataCon(S) END; IF S.res = Done THEN ReadData(S, C, R) 				END; Disconnect(C);	(* before ReadResponse *) ReadResponse(S, S.reply); IF S.res = Interrupted THEN ReadResponse(S, line) END; ELSE S.res := Failed END END; IF C # NIL THEN Disconnect(C) END; IF S.dataC # NIL THEN Disconnect(S.dataC) END END GetF; PROCEDURE GetFile(S: Session; remName, locName: ARRAY OF CHAR); VAR F: Files.File; R: Files.Rider; BEGIN F := Files.New(locName); IF F # NIL THEN Files.Set(R, F, 0); GetF(S, remName, R); IF (S.status >= 200) & (S.status < 300) THEN Files.Register(F); IF log # NIL THEN Texts.WriteString(W, "Received: "); Texts.WriteString(W, locName); Texts.WriteString(W, " "); Texts.WriteInt(W, Files.Length(F), 1); Texts.WriteString(W, " bytes"); Texts.WriteLn(W); Texts.Append(log, W.buf) END ELSE Texts.WriteLn(W)	(* error message on new line *) END ELSE S.reply := "Bad file name" END END GetFile; PROCEDURE WriteData(C: NetSystem.Connection; VAR R: Files.Rider); BEGIN Files.ReadBytes(R, buffer, BufLen); WHILE ~R.eof DO 			NetSystem.WriteBytes(C, 0, BufLen, buffer); Files.ReadBytes(R, buffer, BufLen) END; IF R.res > 0 THEN NetSystem.WriteBytes(C, 0, BufLen-R.res, buffer) END END WriteData; PROCEDURE PutFile(S: Session; remName, locName: ARRAY OF CHAR); VAR C: NetSystem.Connection; F: Files.File; R: Files.Rider; BEGIN S.reply := ""; C := NIL; F := Files.Old(locName); IF F # NIL THEN SetDataPort(S); IF S.res = Interrupted THEN RETURN END; IF S.dataIP = NetSystem.anyIP THEN ReadResponse(S, line) ELSE C := WaitDataCon(S); IF S.res = Done THEN S.status := 200 END END; IF S.status = 200 THEN line := "STOR "; Strings.Append(line, remName); SendCmd(S, line); ReadResponse(S, S.reply); IF (S.status = 150) OR (S.status = 250) THEN IF S.dataIP = NetSystem.anyIP THEN C := WaitDataCon(S) END; IF S.res = Done THEN Files.Set(R, F, 0); WriteData(C, R) 					END; Disconnect(C);	(* before ReadResponse *) ReadResponse(S, S.reply) ELSE S.res := Failed END END ELSE COPY(locName, S.reply); Strings.Append(S.reply, " not found"); S.res := LocFileNotFound END; IF C # NIL THEN Disconnect(C) END; IF S.dataC # NIL THEN Disconnect(S.dataC) END END PutFile; PROCEDURE ReadText(C: NetSystem.Connection; VAR W: Texts.Writer); VAR len, rlen, i: LONGINT; ch: CHAR; exit: BOOLEAN; BEGIN len := NetSystem.Available(C); exit := FALSE; WHILE (len > 0) OR Connected(C, NetSystem.in) DO 			IF len > (BufLen-2) THEN rlen := BufLen-2 ELSE rlen := len END; NetSystem.ReadBytes(C, 0, rlen, buffer); i := 0; WHILE i < rlen DO 				ch := buffer[i]; IF ch = Strings.CR THEN (* ignore CR *) ELSIF ch = Strings.LF THEN Texts.WriteLn(W) ELSE ch := Strings.ISOToOberon[ORD(ch)]; Texts.Write(W, ch) END; INC(i) END; DEC(len, rlen); IF len <= 0 THEN len := NetSystem.Available(C) END END END ReadText; PROCEDURE GetText(S: Session; remName: ARRAY OF CHAR; VAR W: Texts.Writer); VAR C: NetSystem.Connection; BEGIN S.reply := ""; C := NIL; SendCmd(S, "TYPE A"); ReadResponse(S, line); SetDataPort(S); IF S.res = Interrupted THEN SendCmd(S, "TYPE I"); ReadResponse(S, line); RETURN END; IF S.dataIP = NetSystem.anyIP THEN ReadResponse(S, line) ELSE C := WaitDataCon(S); IF S.res = Done THEN S.status := 200 END END; IF S.status = 200 THEN line := "RETR "; Strings.Append(line, remName); SendCmd(S, line); ReadResponse(S, line); COPY(line, S.reply); IF (S.status = 150) OR (S.status = 250) THEN IF S.dataIP = NetSystem.anyIP THEN C := WaitDataCon(S) END; IF S.res = Done THEN ReadText(C, W) 				END; Disconnect(C);	(* before ReadResponse *) ReadResponse(S, S.reply); IF S.res = Interrupted THEN ReadResponse(S, line) END ELSE S.res := Failed END END; IF C # NIL THEN Disconnect(C) END; IF S.dataC # NIL THEN Disconnect(S.dataC) END; SendCmd(S, "TYPE I"); ReadResponse(S, line) END GetText; PROCEDURE WriteText(C: NetSystem.Connection; T: Texts.Text); VAR R: Texts.Reader; ch: CHAR; BEGIN Texts.OpenReader(R, T, 0); Texts.Read(R, ch); WHILE ~R.eot DO 			IF R.lib IS Fonts.Font THEN IF ch = Strings.CR THEN NetSystem.WriteBytes(C, 0, 2, Strings.CRLF) ELSIF ch # Strings.LF THEN ch := Strings.OberonToISO[ORD(ch)]; NetSystem.Write(C, ch) END END; Texts.Read(R, ch) END END WriteText; PROCEDURE PutText(S: Session; remName: ARRAY OF CHAR; text: Texts.Text); VAR C: NetSystem.Connection; BEGIN S.reply := ""; C := NIL; SendCmd(S, "TYPE A"); ReadResponse(S, line); IF (S.status < 200) OR (S.status >= 300) THEN RETURN END; SetDataPort(S); IF S.res = Interrupted THEN SendCmd(S, "TYPE I"); ReadResponse(S, line); RETURN END; IF S.dataIP = NetSystem.anyIP THEN ReadResponse(S, line) ELSE C := WaitDataCon(S); IF S.res = Done THEN S.status := 200 END END; IF S.status = 200 THEN line := "STOR "; Strings.Append(line, remName); SendCmd(S, line); ReadResponse(S, S.reply); IF (S.status = 150) OR (S.status = 250) THEN IF S.dataIP = NetSystem.anyIP THEN C := WaitDataCon(S) END; IF S.res = Done THEN WriteText(C, text) END; Disconnect(C);	(* before ReadResponse *) ReadResponse(S, S.reply) ELSE S.res := Failed END END; IF C # NIL THEN Disconnect(C) END; IF S.dataC # NIL THEN Disconnect(S.dataC) END; SendCmd(S, "TYPE I"); ReadResponse(S, line) END PutText; PROCEDURE ShowRes; BEGIN Texts.WriteString(W, S.reply); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) END ShowRes; PROCEDURE OpenScanner(VAR S: Texts.Scanner); VAR beg, end, time: LONGINT; text: Texts.Text; BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S); IF (S.class = Texts.Char) & (S.c = "^") THEN time := -1; text := NIL; Oberon.GetSelection(text, beg, end, time); IF (text # NIL) & (time >= 0) THEN Texts.OpenScanner(S, text, beg); Texts.Scan(S) END END END OpenScanner; PROCEDURE SplitFTPAdr(VAR url, host, path, user, passwd: ARRAY OF CHAR; VAR type: CHAR; VAR port: INTEGER): BOOLEAN; VAR i, j, l: LONGINT; service: ARRAY 8 OF CHAR; PROCEDURE Blanks; BEGIN WHILE (url[i] # 0X) & (url[i] <= " ") DO 				INC(i) END END Blanks; BEGIN type := 0X; port := DefConPort; COPY("", user); COPY("", passwd); i := 0; Blanks; FOR j := 0 TO 5 DO service[j] := url[i+j] END; service[6] := 0X; IF Strings.CAPPrefix("ftp://", service) THEN INC(i, 6) END; (* look ahead for @ *) j := i; 		WHILE (url[j] # 0X) & (url[j] # "@") & (url[j] # "/") DO 			INC(j) END; IF url[j] = "@" THEN (* get user *) l := LEN(user)-1; j := 0; WHILE (url[i] # 0X) & (url[i] # ":") & (url[i] # "@") DO 				IF (j < l) THEN user[j] := url[i]; INC(j) END; INC(i) END; user[j] := 0X; DEC(j); WHILE (j >= 0) & (user[j] <= " ") DO 				user[j] := 0X; DEC(j) END; IF url[i] = ":" THEN (* get password *) l := LEN(passwd); INC(i); Blanks; j := 0; WHILE (url[i] # 0X) & (url[i] # "@") DO 					IF j < l THEN passwd[j] := url[i]; INC(j) END; INC(i) END; passwd[j] := 0X; DEC(j); WHILE (j >= 0) & (passwd[j] <= " ") DO 					passwd[j] := 0X; DEC(j) END END; INC(i); Blanks END; (* get host *) l := LEN(host); j := 0; WHILE (url[i] # 0X) & (url[i] # ":") & (url[i] # "/") DO 			IF j < l THEN host[j] := url[i]; INC(j) END; INC(i) END; host[j] := 0X; DEC(j); WHILE (j >= 0) & (host[j] <= " ") DO 			host[j] := 0X; DEC(j) END; IF url[i] = ":" THEN port := 0; INC(i); WHILE (url[i] # "/") & (url[i] # 0X) DO 				IF Strings.IsDigit(url[i]) THEN port := port*10+ORD(url[i])-ORD("0") END; INC(i) END; IF port <= 0 THEN port := DefConPort END END; (* get path *) l := LEN(path); j := 0; IF url[i] # 0X THEN path[j] := url[i]; INC(j); INC(i); IF url[i] = "~" THEN j := 0 END END; WHILE (url[i] # 0X) & (url[i] # ";") DO 			IF j < l THEN path[j] := url[i]; INC(j) END; INC(i) END; path[j] := 0X; DEC(j); WHILE (j >= 0) & (path[j] <= " ") DO 			path[j] := 0X; DEC(j) END; IF url[i] = ";" THEN INC(i); Blanks; IF CAP(url[i]) # "T" THEN type := CAP(url[i]) ELSE WHILE (url[i] # 0X) & (url[i] # "=") DO 					INC(i) END; IF url[i] = "=" THEN INC(i); Blanks; type := CAP(url[i]) ELSE type := "T" END END END; RETURN (host # "") & (port > 0) END SplitFTPAdr; (** FTP.Open (server | "^") 		Open an ftp connection to server using username and password set with FTP.SetUser. *) PROCEDURE Open*; VAR Sc: Texts.Scanner; host, path, user, passwd: ARRAY 64 OF CHAR; port: INTEGER; type: CHAR; BEGIN IF S = NIL THEN OpenScanner(Sc); IF Sc.class IN {Texts.Name, Texts.String} THEN IF SplitFTPAdr(Sc.s, host, path, user, passwd, type, port) THEN OpenS(host, user, passwd, port, S); ShowRes; IF S.res # Done THEN S := NIL END END END ELSE Texts.WriteString(W, "already connected"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) END END Open; PROCEDURE Con: BOOLEAN; BEGIN IF S = NIL THEN Texts.WriteString(W, "not connected"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); RETURN FALSE ELSE RETURN TRUE END END Con; (** FTP.Close 		Close an previously opened FTP connection. *) PROCEDURE Close*; BEGIN IF Con THEN CloseS(S); ShowRes; IF S.res = Done THEN S := NIL END END END Close; (** FTP.ChangeDir (newdir | "^") 		Change the current directory on the FTP server to newdir. *) PROCEDURE ChangeDir*; VAR Sc: Texts.Scanner; BEGIN IF Con THEN OpenScanner(Sc); IF Sc.class IN {Texts.Name, Texts.String} THEN ChangeDirS(S, Sc.s); ShowRes END END END ChangeDir; PROCEDURE *ShowEntry(entry: ARRAY OF CHAR); BEGIN Texts.WriteString(W, entry); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) END ShowEntry; (** FTP.Dir 		List the contents of the current directory on the FTP server. *) PROCEDURE Dir*; BEGIN IF Con THEN EnumDir(S, ShowEntry); ShowRes END END Dir; PROCEDURE *ShowCompactEntry(entry: ARRAY OF CHAR); VAR i: INTEGER; BEGIN i := 0; WHILE entry[i] # 0X DO 			INC(i) END; IF i > 0 THEN DEC(i) ELSE RETURN END; WHILE (i > 0) & (entry[i] > " ") DO 			DEC(i) END; IF entry[i] <= " " THEN INC(i) END; WHILE entry[i] # 0X DO 			INC(col); Texts.Write(W, entry[i]); INC(i) END; INC(col); IF col >= 50 THEN Texts.WriteLn(W); col := 0 ELSE INC(col); Texts.Write(W, Tab) END; Texts.Append(Oberon.Log, W.buf) END ShowCompactEntry; (** FTP.CompactDir 		List the contents of the current directory on the FTP server in a more 		compact form. *) PROCEDURE CompactDir*; BEGIN IF Con THEN col := 0; EnumDir(S, ShowCompactEntry); IF col > 0 THEN Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) END; ShowRes END END CompactDir; (** FTP.CurDir 		Display the current path on the FTP server *) PROCEDURE CurDir*; VAR curdir: ARRAY 256 OF CHAR; BEGIN IF Con THEN GetCurDir(S, curdir); ShowRes END END CurDir; (** FTP.MakeDir (server | "^") 		Create a new directory. *) PROCEDURE MakeDir*; VAR Sc: Texts.Scanner; BEGIN IF Con THEN OpenScanner(Sc); IF Sc.class IN {Texts.Name, Texts.String} THEN MakeDirS(S, Sc.s); ShowRes END END END MakeDir; (** FTP.RmDir (server | "^") 		Remove an existing directory. *) PROCEDURE RmDir*; VAR Sc: Texts.Scanner; BEGIN IF Con THEN OpenScanner(Sc); IF Sc.class IN {Texts.Name, Texts.String} THEN RmDirS(S, Sc.s); ShowRes END END END RmDir; (** FTP.DeleteFiles ({remname} | "^") 		Delete the files remname on the FTP server. *) PROCEDURE DeleteFiles*; VAR Sc: Texts.Scanner; beg, end, time, pos: LONGINT; text: Texts.Text; BEGIN IF Con THEN end := Oberon.Par.text.len; Texts.OpenScanner(Sc, Oberon.Par.text, Oberon.Par.pos); pos := Texts.Pos(Sc); Texts.Scan(Sc); IF (Sc.class = Texts.Char) & (Sc.c = "^") THEN time := -1; text := NIL; Oberon.GetSelection(text, beg, end, time); IF (text # NIL) & (time >= 0) THEN Texts.OpenScanner(Sc, text, beg); pos := Texts.Pos(Sc); Texts.Scan(Sc) ELSE end := Oberon.Par.text.len END END; Texts.WriteString(W, "FTP.DeleteFile"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); WHILE (Sc.class IN {Texts.Name, Texts.String}) & (pos < end) & (S.res = Done) DO 				Texts.Write(W, Tab); Texts.WriteString(W, Sc.s); Texts.Write(W, Tab); Texts.Append(Oberon.Log, W.buf); DeleteFile(S, Sc.s); ShowRes; pos := Texts.Pos(Sc); Texts.Scan(Sc); Oberon.Collect END END END DeleteFiles; PROCEDURE ScanPair(VAR S: Texts.Scanner; VAR name1, name2: ARRAY OF CHAR): BOOLEAN; BEGIN (* while loop from pieter *) Oberon.Collect; WHILE ~(S.class IN {Texts.Name, Texts.String}) & ((S.class # Texts.Char) OR (S.c # "~")) & ~S.eot DO 			Texts.Scan(S) END; IF S.class IN {Texts.Name, Texts.String} THEN COPY(S.s, name1); Texts.Scan(S); IF (S.class = Texts.Char) & (S.c = "=") THEN Texts.Scan(S); IF (S.class = Texts.Char) & (S.c = ">") THEN Texts.Scan(S); IF S.class IN {Texts.Name, Texts.String} THEN COPY(S.s, name2); Texts.Scan(S); RETURN TRUE END END ELSE COPY(name1, name2); RETURN TRUE END END; RETURN FALSE END ScanPair; (** FTP.GetFiles ({remname "=>" locname} | "^") 		Get files remname from the FTP server and store them as locname. *) PROCEDURE GetFiles*; VAR Sc: Texts.Scanner; loc, rem: ARRAY LEN(Sc.s) OF CHAR; BEGIN IF Con THEN OpenScanner(Sc); Texts.WriteString(W, "FTP.GetFiles"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); WHILE ScanPair(Sc, rem, loc) & (S.res = Done) DO 				Texts.Write(W, Tab); Texts.WriteString(W, rem); Texts.WriteString(W, " => "); Texts.WriteString(W, loc); Texts.Write(W, Tab); Texts.Append(Oberon.Log, W.buf); GetFile(S, rem, loc); ShowRes END END END GetFiles; (** FTP.GetTexts ({remname "=>" locname} | "^") 		Get text-files remname from the FTP server and store them as locname. *) PROCEDURE GetTexts*; VAR Sc: Texts.Scanner; loc, rem: ARRAY LEN(Sc.s) OF CHAR; T: Texts.Text; F: Files.File; len: LONGINT; Wr: Texts.Writer; BEGIN IF Con THEN OpenScanner(Sc); Texts.WriteString(W, "FTP.GetTexts"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); WHILE ScanPair(Sc, rem, loc) & (S.res = Done) DO 				Texts.Write(W, Tab); Texts.WriteString(W, rem); Texts.WriteString(W, " => "); Texts.WriteString(W, loc); Texts.Write(W, Tab); Texts.Append(Oberon.Log, W.buf); Texts.OpenWriter(Wr); GetText(S, rem, Wr); NEW(T); Texts.Open(T, ""); Texts.Append(T, Wr.buf); IF (S.status >= 200) & (S.status < 300) THEN F := Files.New(loc); IF F # NIL THEN Texts.Store(T, F, 0, len); Files.Register(F); IF log # NIL THEN Texts.WriteString(W, "Received: "); Texts.WriteString(W, loc); Texts.WriteString(W, " "); Texts.WriteInt(W, Files.Length(F), 1); Texts.WriteString(W, " bytes"); Texts.WriteLn(W); Texts.Append(log, W.buf) END ELSE S.reply := "Bad file name" END ELSE Texts.WriteLn(W)	(* error message on new line *) END; ShowRes END END END GetTexts; (** FTP.PutFiles ({locname "=>" remname} | "^") 		Put files locname as remname on the FTP server. *) PROCEDURE PutFiles*; VAR Sc: Texts.Scanner; loc, rem: ARRAY LEN(Sc.s) OF CHAR; BEGIN IF Con THEN OpenScanner(Sc); Texts.WriteString(W, "FTP.PutFiles"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); WHILE ScanPair(Sc, loc, rem) & (S.res = Done) DO 				Texts.Write(W, Tab); Texts.WriteString(W, loc); Texts.WriteString(W, " => "); Texts.WriteString(W, rem); Texts.Write(W, Tab); Texts.Append(Oberon.Log, W.buf); PutFile(S, rem, loc); ShowRes END END END PutFiles; (** FTP.PutTexts ({locname "=>" remname} | "^") 		Put text-files locname as remname on the FTP server. *) PROCEDURE PutTexts*; VAR Sc: Texts.Scanner; loc, rem: ARRAY LEN(Sc.s) OF CHAR; text: Texts.Text; BEGIN IF Con THEN OpenScanner(Sc); Texts.WriteString(W, "FTP.PutTexts"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); WHILE ScanPair(Sc, loc, rem) & (S.res = Done) DO 				Texts.Write(W, Tab); Texts.WriteString(W, loc); Texts.WriteString(W, " => "); Texts.WriteString(W, rem); Texts.Write(W, Tab); Texts.Append(Oberon.Log, W.buf); NEW(text); Texts.Open(text, loc); PutText(S, rem, text); ShowRes END END END PutTexts; (** Open a separate log text for FTP. *) PROCEDURE OpenLog*; BEGIN IF (log = Oberon.Log) OR (log = NIL) THEN NEW(log); Texts.Open(log, "") END; Oberon.OpenText("FTP.Log", log, Display.Width DIV 8 * 3, Display.Height DIV 3) END OpenLog; BEGIN S := NIL; log := NIL; Texts.OpenWriter(W); timeOut := 5*60*Input.TimeUnit; dataPort := MinDataPort END FTP. System.Free FTP ~ Configuration.DoCommands FTP.Open muller@ice ~ FTP.ChangeDir "~muller/ftp.inf/pub/ETHOberon/Native/Update/Alpha/" FTP.PutFiles Oberon0.Dsk=>Temp.Dsk ~ FTP.PutFiles Temp.Dsk ~ FTP.Close ~ System.Directory *.Dsk\d System.CopyFiles Oberon0.Dsk => Rfs:Temp.Dsk ~

title: Oberon/ETH Oberon/2.3.7/FTP.Mod


text:
Oberon/ETH Oberon/2.3.7/NetSystem.Mod

(* ETH Oberon, Copyright 1990-2003 Computer Systems Institute, ETH Zurich, CH-8092 Zurich. Refer to the license.txt file provided with this distribution. *) MODULE NetSystem;	(** portable *)	(* mg 16.08.96 *) (* A Portable Oberon Interface to Internet Protocols *) IMPORT SYSTEM, Kernel, Modules, NetBase, NetPorts, NetIP, NetUDP, NetTCP, NetDNS, Input, Texts, Oberon, TextFrames, Strings, Fonts; CONST anyport* = 0;	(** any port value *) (** result values *) done* = 0;	(** everything went ok *) error* = 1;	(** failure occured *) (** return values of procedure State *) closed* = 0;	(** connection is closed (neither sending nor receiving) *) listening* = 1;	(** passive connection is listening for a request *) in* = 2;	(** receiving only *) out* = 3;	(** sending only *) inout* = 4;	(** sending and receiving is possible *) waitCon* = 5;	(** still waiting to be connected *) errorCon* = 6;	(** connecting failed *) CR = 0DX; LF = 0AX; Trace = FALSE; TYPE Connection* = POINTER TO ConnectionDesc;	(** handle for TCP connections *) ConnectionDesc* = RECORD port: NetPorts.Port; res*: INTEGER;	(** result of last operation on a connection (error indication) *) state: INTEGER; Available: PROCEDURE (C: Connection; VAR res: INTEGER): LONGINT; Receive: PROCEDURE (C: Connection; VAR buf: ARRAY OF SYSTEM.BYTE; beg, len: LONGINT; VAR res: INTEGER); Send: PROCEDURE (C: Connection; VAR buf: ARRAY OF SYSTEM.BYTE; beg, len: LONGINT; VAR res: INTEGER); END; IPAdr* = LONGINT; (** IP address in network byte order *) Socket* = POINTER TO SocketDesc;	(** handle for UDP "connections" *) SocketDesc* = RECORD C: NetUDP.Connection; res*: INTEGER;	(** result of last operation on a connection (error indication) *) state: INTEGER END; Password = POINTER TO PasswordDesc; PasswordDesc = RECORD service, user, host, passwd: ARRAY 64 OF CHAR; next: Password END; VAR anyIP*: IPAdr;	(** "NIL" ip-number *) allIP*: IPAdr;	(** broadcast ip-number *) hostIP*: IPAdr;	(** main ip-number of local machine *) hostName*: ARRAY 64 OF CHAR;	(** main name of local machine *) started: BOOLEAN; W: Texts.Writer; passwords: Password; hex: ARRAY 17 OF CHAR; task: Oberon.Task; PROCEDURE GetEntry (key, name: ARRAY OF CHAR; VAR arg0, arg1: ARRAY OF CHAR); VAR S: Texts.Scanner; key0: ARRAY 64 OF CHAR; i, j: INTEGER; BEGIN COPY(key, key0); i := 0; WHILE key0[i] # 0X DO INC(i) END; j := 0; WHILE name[j] # 0X DO key0[i] := name[j]; INC(i); INC(j) END; key0[i] := 0X; Oberon.OpenScanner(S, key0); IF S.class IN {Texts.Name, Texts.String} THEN COPY(S.s, arg0); Texts.Scan(S) ELSE COPY("", arg0) END; IF (S.class = Texts.Char) & (S.c = ",") THEN Texts.Scan(S); IF S.class IN {Texts.Name, Texts.String} THEN COPY(S.s, arg1) ELSE COPY("", arg1) END ELSE COPY("", arg1) END END GetEntry; PROCEDURE GetEntry0 (key, name: ARRAY OF CHAR; VAR arg: ARRAY OF CHAR); VAR S: Texts.Scanner; key0: ARRAY 64 OF CHAR;  i, j: INTEGER; BEGIN COPY(key, key0); i := 0; WHILE key0[i] # 0X DO INC(i) END; j := 0; WHILE name[j] # 0X DO key0[i] := name[j]; INC(i); INC(j) END; key0[i] := 0X; Oberon.OpenScanner(S, key0); IF S.class IN {Texts.Name, Texts.String} THEN COPY(S.s, arg); Texts.Scan(S) ELSE COPY("", arg) END END GetEntry0; PROCEDURE ToNum0 (num: ARRAY OF CHAR; VAR n: INTEGER; VAR done: BOOLEAN); VAR i: INTEGER; BEGIN n := 0; i := 0; WHILE ("0" <= num[i]) & (num[i] <= "9") DO 		n := n * 10 + ORD(num[i]) - ORD("0"); INC(i) END; done := num[i] = 0X END ToNum0; PROCEDURE ToHost0 (num: ARRAY OF CHAR; VAR adr: NetIP.Adr; VAR done: BOOLEAN); VAR addr: IPAdr; buf: ARRAY 32 OF CHAR; i, j, k, n: INTEGER; BEGIN done := TRUE; addr := 0; i := 0; j := 0; WHILE done & (j < 4) & (num[i] # 0X) DO 		k := 0; WHILE (num[i] # ".") & (num[i] # 0X) DO 			buf[k] := num[i]; INC(k); INC(i) END; buf[k] := 0X; ToNum0(buf, n, done); addr := ASH(addr, 8) + n; done := done & (n <= 256); IF num[i] = "." THEN INC(i) END; INC(j) END; adr := SYSTEM.VAL(NetIP.Adr, addr); NetBase.HostLToNet(adr); done := done & (j = 4) & (num[i] = 0X) END ToHost0; PROCEDURE AdrToStr(netAdr: ARRAY OF SYSTEM.BYTE; VAR net: ARRAY OF CHAR); VAR i, j: LONGINT; BEGIN j := 0; FOR i := 0 TO NetBase.MacAdrLen-1 DO 		net[j] := hex[ORD(netAdr[i]) DIV 10H MOD 10H]; net[j+1] := hex[ORD(netAdr[i]) MOD 10H]; net[j+2] := ":"; INC(j, 3) END; DEC(j); net[j] := 0X END AdrToStr; (* Look up an ethernet address to find ip address and hostname. *) PROCEDURE FindAddress(key: ARRAY OF CHAR; netAdr: ARRAY OF SYSTEM.BYTE;  VAR hostname, num: ARRAY OF CHAR); VAR net: ARRAY 20 OF CHAR; s: Texts.Scanner;  found: BOOLEAN; BEGIN AdrToStr(netAdr, net); num[0] := 0X; hostname[0] := 0X; IF net # "00:00:00:00:00:00" THEN Oberon.OpenScanner(s, key); found := FALSE; WHILE (s.class = Texts.String) & ~found DO 			found := s.s = net; Texts.Scan(s); IF (s.class = Texts.Char) & (s.c = ",") THEN Texts.Scan(s); IF s.class = Texts.String THEN COPY(s.s, hostname); Texts.Scan(s); IF (s.class = Texts.Char) & (s.c = ",") THEN Texts.Scan(s); IF s.class = Texts.String THEN IF found THEN COPY(s.s, num) END; Texts.Scan(s) END ELSE s.class := Texts.Inval END END ELSE s.class := Texts.Inval END END; IF num[0] = 0X THEN hostname[0] := 0X; Texts.WriteString(W, "NetSystem.Route#.Host setting not found in Oberon.Text"); Texts.WriteLn(W); Texts.WriteString(W, net); Texts.WriteString(W, " not found in "); Texts.WriteString(W, key); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) END ELSE (* MAC adr all zero, ignore *) END END FindAddress; (** -- Adressing/Naming section. *) (** Convert a dotted IP address string (e.g. "1.2.3.4") to an IPAdr value. *) PROCEDURE ToHost* (num: ARRAY OF CHAR; VAR adr: IPAdr; VAR done: BOOLEAN); BEGIN ToHost0(num, SYSTEM.VAL(NetIP.Adr, adr), done); IF ~done THEN adr := anyIP END END ToHost; (** Convert an IPAdr value to a dotted IP address string *) PROCEDURE ToNum*(adr: IPAdr; VAR num: ARRAY OF CHAR); VAR i, j, n: LONGINT; PROCEDURE Digit(d: LONGINT); BEGIN num[j] := CHR(ORD("0")+d); INC(j) END Digit; BEGIN j := 0; FOR i := 0 TO 3 DO 		n := adr MOD 256; adr := adr DIV 256; IF n >= 100 THEN Digit(n DIV 100); Digit((n DIV 10) MOD 10) ELSIF n >= 10 THEN Digit(n DIV 10) END; Digit(n MOD 10); num[j] := "."; INC(j) END; num[j-1] := 0X END ToNum; (** Procedure delivers the ip-number of a named host. If a symbolic name is given, it will be resolved by use of domain name 	servers. *) PROCEDURE GetIP* (name: ARRAY OF CHAR; VAR IP: IPAdr); VAR hostName, hostIP: ARRAY 64 OF CHAR; res: INTEGER; done: BOOLEAN; BEGIN IF (CAP(name[0]) >= "A") & (CAP(name[0]) <= "Z") THEN GetEntry("NetSystem.Hosts.", name, hostName, hostIP); IF hostIP # "" THEN ToHost0(hostIP, SYSTEM.VAL(NetIP.Adr, IP), done) ELSE IF started THEN IF hostName # "" THEN NetDNS.HostByName(hostName, SYSTEM.VAL(NetIP.Adr, IP), res) ELSE NetDNS.HostByName(name, SYSTEM.VAL(NetIP.Adr, IP), res) END; done := (res = NetDNS.Done) ELSE done := FALSE END END ELSIF (name[0] >= "0") & (name[0] <= "9") THEN ToHost0(name, SYSTEM.VAL(NetIP.Adr, IP), done) ELSE done := FALSE END; IF ~done THEN IP := anyIP END END GetIP; (** GetName is the reverse of GetIP. Given an ip-number, it delivers the name of a host. *) PROCEDURE GetName* (IP: IPAdr; VAR name: ARRAY OF CHAR); VAR adr: NetIP.Adr; res: INTEGER; BEGIN IF started THEN adr := SYSTEM.VAL(NetIP.Adr, IP); NetDNS.HostByNumber(adr, name, res) END; IF ~started OR (res # NetDNS.Done) THEN COPY("", name) END END GetName; (** -- TCP section. *) (* Stream oriented communication *) (* PROCEDURE TCPSetState (C: Connection); BEGIN 	IF C.state IN {in, inout} THEN 		IF ~NetTCP.Connected(C.port(NetTCP.Connection)) THEN 			IF C.state = inout THEN C.state := out 			ELSIF C.state = in THEN C.state := closed 			END 		END 	END END TCPSetState; *) PROCEDURE TCPAvailable (C: Connection; VAR res: INTEGER): LONGINT; VAR len: LONGINT; BEGIN len := NetTCP.Available(C.port(NetTCP.Connection)); IF len < 0 THEN len := 0; res := error ELSE res := done END; (*TCPSetState(C);*) RETURN len END TCPAvailable; PROCEDURE TCPReceive (C: Connection; VAR buf: ARRAY OF SYSTEM.BYTE; beg, len: LONGINT; VAR res: INTEGER); VAR l: LONGINT; BEGIN l := 0; REPEAT l := len; NetTCP.Receive(C.port(NetTCP.Connection), buf, beg, l); IF l > 0 THEN beg := beg + l; len := len - l END UNTIL (len = 0) OR (l < 0); IF l < 0 THEN res := error ELSE res := done END; (*TCPSetState(C)*) END TCPReceive; PROCEDURE TCPSend (C: Connection; VAR buf: ARRAY OF SYSTEM.BYTE; beg, len: LONGINT; VAR res: INTEGER); BEGIN NetTCP.Send(C.port(NetTCP.Connection), buf, beg, len); IF len < 0 THEN res := error ELSE res := done END; (*TCPSetState(C)*) END TCPSend; PROCEDURE DmyAvailable (C: Connection; VAR res: INTEGER): LONGINT; BEGIN res := error; RETURN 0 END DmyAvailable; PROCEDURE DmyReceive (C: Connection; VAR buf: ARRAY OF SYSTEM.BYTE; beg, len: LONGINT; VAR res: INTEGER); BEGIN res := error END DmyReceive; PROCEDURE DmySend (C: Connection; VAR buf: ARRAY OF SYSTEM.BYTE; beg, len: LONGINT; VAR res: INTEGER); BEGIN res := error END DmySend; PROCEDURE ^Cleanup(c: SYSTEM.PTR); (** Procedure opens a connection. locPort, remPort, remIP are contained in the quadrupel  	which determines a connection uniquely. As locIP is always the current machine, it is omitted. If remPort is equal to 	anyport or remIP is equal to anyIP, a passive connection will be opened. After execution, C is a brand new connection. 	res indicates any error. *) PROCEDURE OpenConnection* (VAR C: Connection; locPort: INTEGER; remIP: IPAdr; remPort: INTEGER; VAR res: INTEGER); VAR conC: NetTCP.Connection; listC: NetTCP.Listener; remAdr: NetIP.Adr; BEGIN IF started THEN remAdr := SYSTEM.VAL(NetIP.Adr, remIP); NEW(C); IF (SYSTEM.VAL(LONGINT, remIP) = SYSTEM.VAL(LONGINT, NetIP.IPany)) OR (remPort = NetPorts.anyport) THEN NetTCP.Listen(listC, locPort, remAdr, remPort, C.res); IF C.res = NetTCP.Done THEN C.port := listC; C.state := listening; C.Available := DmyAvailable; C.Send := DmySend; C.Receive := DmyReceive; Kernel.RegisterObject(C, Cleanup, FALSE) ELSIF C.res # NetTCP.Timeout THEN C.res := error END; res := C.res ELSIF ~NetIP.IsBroadcast(remAdr) THEN NetTCP.Connect(conC, locPort, remAdr, remPort, C.res); IF C.res = NetTCP.Done THEN C.port := conC; C.state := inout; C.Available := TCPAvailable; C.Send := TCPSend; C.Receive := TCPReceive; Kernel.RegisterObject(C, Cleanup, FALSE) ELSIF C.res # NetTCP.Timeout THEN C.res := error END; res := C.res ELSE res := error END ELSE res := error END END OpenConnection; (** Like OpenConnection, but this procedure may return immediately and delay the actual opening of the connection.  	In this case State should be checked to wait for the connection status to change from waitCon. *) PROCEDURE AsyncOpenConnection*(VAR C: Connection; locPort: INTEGER; remIP: IPAdr; remPort:INTEGER; VAR res: INTEGER); VAR conC: NetTCP.Connection; remAdr: NetIP.Adr; BEGIN IF ~started OR (SYSTEM.VAL(LONGINT, remIP) = SYSTEM.VAL(LONGINT, NetIP.IPany)) OR 			(remPort = NetPorts.anyport) OR NetIP.IsBroadcast(remAdr) THEN OpenConnection(C, locPort, remIP, remPort, res)	(* same as synchronous case *) ELSE	(* to do : make truly asynchronous. current same as OpenConnection. *) remAdr := SYSTEM.VAL(NetIP.Adr, remIP); NEW(C); NetTCP.Connect(conC, locPort, remAdr, remPort, C.res); IF C.res = NetTCP.Done THEN C.port := conC; C.state := inout; C.Available := TCPAvailable; C.Send := TCPSend; C.Receive := TCPReceive; Kernel.RegisterObject(C, Cleanup, FALSE) ELSIF C.res # NetTCP.Timeout THEN C.res := error END; res := C.res END END AsyncOpenConnection; (** Procedure closes the connection. Connection can not be used for send operations afterwards. *) PROCEDURE CloseConnection* (C: Connection); BEGIN IF C # NIL THEN IF C.port IS NetTCP.Listener THEN C.state := closed; NetTCP.Close(C.port(NetTCP.Listener)) ELSIF C.port IS NetTCP.Connection THEN IF C.state = inout THEN C.state := in 			ELSIF C.state = out THEN C.state := closed END; NetTCP.Disconnect(C.port(NetTCP.Connection)) ELSE HALT(99) END; C.res := done END END CloseConnection; PROCEDURE Cleanup(c: SYSTEM.PTR); VAR s: ARRAY 20 OF CHAR; BEGIN WITH c: Connection DO 		IF c.state # closed THEN IF Trace THEN Kernel.WriteString("NetSystem: Cleanup "); ToNum(SYSTEM.VAL(IPAdr, c.port.rip), s); Kernel.WriteString(s); Kernel.WriteChar(":"); Kernel.WriteInt(c.port.rport, 1); Kernel.WriteLn END; CloseConnection(c) END END END Cleanup; (** Indicates whether there exists a remote machine which wants to connect to the local one. This Procedure is only useful 	on passive connections. For active connections (State(C) # listen), it always delivers FALSE. *) PROCEDURE Requested* (C: Connection): BOOLEAN; BEGIN RETURN (C.port IS NetTCP.Listener) & NetTCP.Requested(C.port(NetTCP.Listener)) END Requested; (** Procedure accepts a new waiting, active connection (newC) on a passive one (State(C) = listen). If no connection is 	waiting, accept blocks until there is one or an error occurs. If C is not a passive connection, Accept does nothing 	but res is set to Done. *) PROCEDURE Accept* (C: Connection; VAR newC: Connection; VAR res: INTEGER); VAR conC: NetTCP.Connection; BEGIN res := NetTCP.NotDone; IF C.port IS NetTCP.Listener THEN NetTCP.Accept(C.port(NetTCP.Listener), conC, res); IF res = NetTCP.Done THEN NEW(newC); newC.port := conC; newC.state := inout; newC.Available := TCPAvailable; newC.Send := TCPSend; newC.Receive := TCPReceive END END; C.res := res END Accept; (** Procedure returns the state of a connection (see constant section). *) PROCEDURE State* (C: Connection): INTEGER; BEGIN IF C.state IN {in, inout} THEN IF NetTCP.Connected(C.port(NetTCP.Connection)) THEN (* skip *) ELSE IF NetTCP.Available(C.port(NetTCP.Connection)) # 0 THEN	(* workaround for client errors *) (* skip *) ELSE IF C.state = inout THEN C.state := out ELSIF C.state = in THEN C.state := closed END END END END; RETURN C.state END State; (** Returns the number of bytes which may be read without blocking. *) PROCEDURE Available* (C: Connection): LONGINT; BEGIN RETURN C.Available(C, C.res) END Available; (** Blocking read a single byte. *) PROCEDURE Read* (C: Connection; VAR ch: CHAR); BEGIN C.Receive(C, ch, 0, 1, C.res) END Read; (** Blocking read len bytes of data (beginning at pos in buf) to buf. *) PROCEDURE ReadBytes* (C: Connection; pos, len: LONGINT; VAR buf: ARRAY OF SYSTEM.BYTE); BEGIN C.Receive(C, buf, pos, len, C.res); END ReadBytes; (** Blocking read two bytes in network byte ordering. *) PROCEDURE ReadInt* (C: Connection; VAR x: INTEGER); BEGIN C.Receive(C, x, 0, 2, C.res); NetBase.NetToHost(x) END ReadInt; (** Blocking read four bytes in network byte ordering. *) PROCEDURE ReadLInt* (C: Connection; VAR x: LONGINT); BEGIN C.Receive(C, x, 0, 4, C.res); NetBase.NetLToHost(x); END ReadLInt; (** Blocking read a string terminated by ( [CR]LF | 0X ). *) PROCEDURE ReadString* (C: Connection; VAR s: ARRAY OF CHAR); VAR ch, ch0: CHAR; i: INTEGER; BEGIN i := -1; ch := 0X; REPEAT INC(i); ch0 := ch; C.Receive(C, ch, 0, 1, C.res); s[i] := ch; UNTIL (C.res = error) OR (ch = 0X) OR (ch = LF); IF (ch = LF) & (ch0 = CR) THEN s[i - 1] := 0X ELSE s[i] := 0X END END ReadString; (** Blocking write a single byte to C. *) PROCEDURE Write* (C: Connection; ch: CHAR); BEGIN C.Send(C, ch, 0, 1, C.res) END Write; (** Blocking write len bytes of data (beginning at pos in buf) to C. *) PROCEDURE WriteBytes* (C: Connection; pos, len: LONGINT; VAR buf: ARRAY OF SYSTEM.BYTE); BEGIN C.Send(C, buf, pos, len, C.res) END WriteBytes; (** Blocking write two bytes in network byte ordering to C. *) PROCEDURE WriteInt* (C: Connection; x: INTEGER); BEGIN NetBase.HostToNet(x); C.Send(C, x, 0, 2, C.res) END WriteInt; (** Blocking write four bytes in network byte ordering to C. *) PROCEDURE WriteLInt* (C: Connection; x: LONGINT); BEGIN NetBase.HostLToNet(x); C.Send(C, x, 0, 4, C.res) END WriteLInt; (** Blocking write a string without "0X" and terminated by "CRLF" to C. *) PROCEDURE WriteString* (C: Connection; s: ARRAY OF CHAR); VAR cs: ARRAY 2 OF CHAR; i: INTEGER; BEGIN i := 0; WHILE s[i] # 0X DO INC(i) END; C.Send(C, s, 0, i, C.res); cs[0] := CR; cs[1] := LF; C.Send(C, cs, 0, 2, C.res) END WriteString; (** Procedure delivers the ip-number and port number of a connection's remote partner. *) PROCEDURE GetPartner* (C: Connection; VAR remIP: IPAdr; VAR remPort: INTEGER); BEGIN remPort := C.port.rport; remIP := SYSTEM.VAL(IPAdr, C.port.rip) END GetPartner; (** -- UDP section. *) (* Datagram oriented communication *) (** Opens a socket which is dedicated to datagram services. locPort is registered to receive datagrams 	from any port and any host. *) PROCEDURE OpenSocket* (VAR S: Socket; locPort: INTEGER; VAR res: INTEGER); BEGIN IF started THEN NEW(S); NetUDP.Open(S.C, locPort, NetIP.IPany, NetPorts.anyport, S.res); IF S.res = NetUDP.Done THEN S.state := inout ELSE S.C := NIL; S.res := error END; res := S.res ELSE res := error END END OpenSocket; (** Closes the socket. You can not receive datagrams anymore. *) PROCEDURE CloseSocket* (S: Socket); BEGIN S.state := closed; NetUDP.Close(S.C); S.C := NIL; S.res := done END CloseSocket; (** Sends len bytes of data (beginning at pos in buf) to the host specified by remIP and remPort. *) PROCEDURE SendDG* (S: Socket; remIP: IPAdr; remPort: INTEGER; pos, len: LONGINT; VAR buf: ARRAY OF SYSTEM.BYTE); BEGIN NetUDP.Send(S.C, SYSTEM.VAL(NetIP.Adr, remIP), remPort, buf, pos, len); S.res := done END SendDG; (** Stores an entire datagram in buf beginning at pos. On success (S.res = done), remIP and remPort indicate the sender, 	len indicate the length of valid data. *) PROCEDURE ReceiveDG*(S: Socket; VAR remIP: IPAdr; VAR remPort: INTEGER; pos: LONGINT; VAR len: LONGINT; 	VAR buf: ARRAY OF SYSTEM.BYTE); BEGIN NetUDP.Receive(S.C, SYSTEM.VAL(NetIP.Adr, remIP), remPort, buf, pos, len); IF len >= 0 THEN S.res := done ELSE S.res := error END END ReceiveDG; (** Returns the size of the first available datagram on the socket. *) PROCEDURE AvailableDG* (S: Socket): LONGINT; BEGIN RETURN NetUDP.Available(S.C) END AvailableDG; (* Conversions *) (** Write 2 bytes in network byte ordering to buf[pos]. *) PROCEDURE PutInt* (VAR buf: ARRAY OF SYSTEM.BYTE; pos: INTEGER; x: INTEGER); BEGIN NetBase.HostToNet(x); SYSTEM.PUT(SYSTEM.ADR(buf[pos]), x) END PutInt; (** Write 4 bytes in network byte ordering to buf[pos]. *) PROCEDURE PutLInt* (VAR buf: ARRAY OF SYSTEM.BYTE; pos: INTEGER; x: LONGINT); BEGIN NetBase.HostLToNet(x); SYSTEM.PUT(SYSTEM.ADR(buf[pos]), x) END PutLInt; (** Read 2 bytes in network byte ordering from buf[pos]. *) PROCEDURE GetInt* (VAR buf: ARRAY OF SYSTEM.BYTE; pos: INTEGER; VAR x: INTEGER); BEGIN SYSTEM.GET(SYSTEM.ADR(buf[pos]), x); NetBase.NetToHost(x) END GetInt; (** Read 4 bytes in network byte ordering from buf[pos]. *) PROCEDURE GetLInt* (VAR buf: ARRAY OF SYSTEM.BYTE; pos: INTEGER; VAR x: LONGINT); BEGIN SYSTEM.GET(SYSTEM.ADR(buf[pos]), x); NetBase.NetLToHost(x) END GetLInt; (** -- Passwords section. *) PROCEDURE WriteURL(VAR service, user, host: ARRAY OF CHAR); BEGIN Texts.WriteString(W, "NetSystem.SetUser "); Texts.WriteString(W, service); Texts.Write(W, ":"); Texts.WriteString(W, user);  Texts.Write(W, "@"); Texts.WriteString(W, host); Texts.WriteString(W, " ~"); Texts.WriteLn(W) END WriteURL; (** Retrieve the password for user using service on host. Parameters service, host and user must be specified.  Parameter user is in/out.  If empty, it returns the first (user,password) pair found, otherwise it returns the specified user's password. *) PROCEDURE GetPassword*(service, host: ARRAY OF CHAR; VAR user, password: ARRAY OF CHAR); VAR pass: Password; r: Texts.Reader;  ch: CHAR; BEGIN Strings.Lower(service, service); Strings.Lower(host, host); pass := passwords; WHILE (pass # NIL) & ~((pass.service = service) & (pass.host = host) & ((user = "") OR (pass.user = user))) DO 		pass := pass.next END; IF pass # NIL THEN COPY(pass.user, user); COPY(pass.passwd, password) ELSE IF (service # "") & (user # "") THEN IF Oberon.Log.len > 0 THEN Texts.OpenReader(r, Oberon.Log, Oberon.Log.len-1); Texts.Read(r, ch); IF ch # CHR(13) THEN Texts.WriteLn(W) END END; WriteURL(service, user, host); Texts.Append(Oberon.Log, W.buf) END; COPY("", user); COPY("", password) END END GetPassword; (** Remove password for user using service on host. *) PROCEDURE DelPassword*(service, user, host: ARRAY OF CHAR); VAR ppass, pass: Password; BEGIN Strings.Lower(service, service); Strings.Lower(host, host); ppass := NIL; pass := passwords; WHILE (pass # NIL) & ((pass.service # service) & (pass.host # host) & (pass.user # user)) DO 		ppass := pass; pass := pass.next END; IF pass # NIL THEN IF ppass # NIL THEN ppass.next := pass.next ELSE passwords := pass.next END END END DelPassword; PROCEDURE Reboot; VAR cmd: Modules.Command; m: Modules.Module; BEGIN m := Modules.ThisMod("System"); IF m # NIL THEN cmd := Modules.ThisCommand(m, "Reboot"); IF cmd # NIL THEN cmd END END END Reboot; PROCEDURE InputRead(VAR ch: CHAR);	(* not really clean *) BEGIN WHILE Input.Available = 0 DO NetBase.Poll END; Input.Read(ch); IF ch = 0FFX THEN Reboot END END InputRead; (** Command NetSystem.SetUser { service ":" ["//"] [ user [ ":" password ] "@" ] host [ "/" ] } "~" 		If password is not specified in-line, prompts for the password for the (service, host, user) triple.  		The (service, host, user, password) 4-tuple is stored in memory for retrieval with GetPassword.  		Multiple identical passwords may be set with one command. *) PROCEDURE SetUser*; VAR R: Texts.Reader; service, usr, host, pwd, entered: ARRAY 64 OF CHAR; ok, verbose: BOOLEAN; ch: CHAR; pass: Password; PROCEDURE Next(VAR str: ARRAY OF CHAR); VAR i: LONGINT; BEGIN Texts.Read(R, ch); WHILE ~R.eot & ((ch <= " ") OR (ch = ":") OR (ch = "@") OR (ch = "/") OR ~(R.lib IS Fonts.Font)) DO 			Texts.Read(R, ch) END; i := 0; WHILE ~R.eot & (ch > " ") & (ch # ":") & (ch # "@") & (ch # "/") & (ch # "~") & (R.lib IS Fonts.Font) DO 			str[i] := ch; INC(i); Texts.Read(R, ch) END; str[i] := 0X END Next; PROCEDURE InputStr(prompt: ARRAY OF CHAR; show: BOOLEAN; VAR str: ARRAY OF CHAR); VAR i: LONGINT; ch: CHAR; BEGIN Texts.SetColor(W, 1); Texts.WriteString(W, prompt); Texts.SetColor(W, 15); Texts.Append(Oberon.Log, W.buf); InputRead(ch); i := 0; WHILE (ch # 0DX) & (ch # 1AX) DO 			IF ch = 7FX THEN IF i > 0 THEN Texts.Delete(Oberon.Log, Oberon.Log.len-1, Oberon.Log.len); DEC(i) END ELSE IF show THEN Texts.Write(W, ch) ELSE Texts.Write(W, "*") END; Texts.Append(Oberon.Log, W.buf); str[i] := ch; INC(i) END; InputRead(ch) END; IF ch # 0DX THEN i := 0 END; str[i] := 0X; Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) END InputStr; PROCEDURE Replace(p: Password); VAR q, prev: Password; msg: ARRAY 12 OF CHAR; BEGIN q := passwords; prev := NIL; WHILE (q # NIL) & ~((q.service = p.service) & (q.host = p.host) & (q.user = p.user)) DO 			prev := q; q := q.next END; IF q # NIL THEN	(* password exists, delete old one first *) IF prev = NIL THEN passwords := passwords.next ELSE prev.next := q.next END; msg := "replaced" ELSE msg := "set" END; p.next := passwords; passwords := p; 		IF verbose THEN Texts.WriteString(W, p.service); Texts.Write(W, ":"); Texts.WriteString(W, p.user); Texts.Write(W, "@");  Texts.WriteString(W, p.host); Texts.WriteString(W, " password "); Texts.WriteString(W, msg); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) END END Replace; BEGIN Texts.OpenReader(R, Oberon.Par.text, Oberon.Par.pos); ok := TRUE; entered[0] := 0X;  verbose := FALSE; WHILE ~R.eot & ok DO 		ok := FALSE; Next(service); IF service = "\v" THEN verbose := TRUE; Next(service) END; Strings.Lower(service, service); IF ch = ":" THEN Next(usr); IF ch = ":" THEN	(* password specified in-line *) Next(pwd); IF ch = "@" THEN Next(host) ELSE COPY(pwd, host); pwd[0] := 0X END ELSIF ch = "@" THEN	(* no password specified in-line *) pwd[0] := 0X; Next(host) ELSE	(* no user or password specified *) COPY(usr, host); usr[0] := 0X; pwd[0] := 0X END; Strings.Lower(host, host); IF host[0] # 0X THEN IF (usr[0] = 0X) OR ((pwd[0] = 0X) & (entered[0] = 0X)) THEN Texts.WriteString(W, service); Texts.WriteString(W, "://"); IF usr[0] # 0X THEN Texts.WriteString(W, usr); Texts.Write(W, "@") END; Texts.WriteString(W, host); Texts.WriteLn(W) END; IF usr[0] = 0X THEN	(* no user specified, prompt *) InputStr("Enter user name: ", TRUE, usr); IF usr[0] = 0X THEN RETURN END END; IF pwd[0] = 0X THEN	(* no pwd specified *) IF entered[0] = 0X THEN	(* prompt first time *) InputStr("Enter password: ", FALSE, entered); IF entered[0] = 0X THEN RETURN END	(* esc *) END; pwd := entered END; NEW(pass); COPY(service, pass.service); COPY(host, pass.host); COPY(usr, pass.user); COPY(pwd, pass.passwd); Replace(pass); ok := TRUE END END END END SetUser; (** Command NetSystem.ClearUser ~ Clear all passwords from memory. *) PROCEDURE ClearUser*; BEGIN passwords := NIL END ClearUser; (** -- Initialisation section. *) PROCEDURE SetDevices; VAR T: Texts.Text; device, name, arg: ARRAY 32 OF CHAR;  i: INTEGER; F: TextFrames.Frame; BEGIN NEW(T); i := 0; device := "Device0"; GetEntry("NetSystem.Hosts.", device, name, arg); WHILE (i < NetBase.MaxDevices) & (name # "") & (name[0] # "<") DO 		Texts.Open(T, ""); Texts.WriteString(W, name); Texts.Write(W, " ");  Texts.WriteString(W, arg); Texts.WriteLn(W); Texts.Append(T, W.buf); F := TextFrames.NewText(T, 0); TextFrames.Call(F, 0, FALSE); INC(i); device[6] := CHR(i+ORD("0")); GetEntry("NetSystem.Hosts.", device, name, arg) END END SetDevices; PROCEDURE SetRoutes; VAR route: NetIP.Route; key: ARRAY 64 OF CHAR; hostname, num, device, arp, dmy, gateway: ARRAY 64 OF CHAR; i, j, devnum: LONGINT; done: BOOLEAN; dev: NetBase.Device; BEGIN key := "NetSystem.Hosts.Route0."; i := 0; GetEntry0(key, "Device", device); WHILE (i < NetIP.MaxRoutes) & (device # "") DO 		Strings.Lower(device, device); IF device = "default" THEN devnum := 0 ELSIF Strings.Prefix("device", device) & (device[6] >= "0") & (device[6] <= "9") & (device[7] = 0X) THEN devnum := ORD(device[6])-ORD("0") ELSE devnum := -1 END; dev := NetBase.FindDevice(devnum); IF dev # NIL THEN NEW(route); route.dev := dev;  (*log := FALSE;*) GetEntry0(key, "Mode", arp); IF arp = "arp" THEN INCL(route.options, NetIP.arpopt) END; GetEntry(key, "Host", hostname, num); ToHost0(num, route.adr, done); IF ~done THEN	(* try using table *) FindAddress("NetSystem.Hosts.Table", route.dev.hostAdr, hostname, num); ToHost0(num, route.adr, done); (*log := log OR done*) END; IF ~done THEN (* ok if still to be assigned, e.g. PPP *) route.adr := NetIP.IPany	(* must be assigned later *) ELSE IF i = 0 THEN	(* first host *) COPY(hostname, hostName); hostIP := SYSTEM.VAL(IPAdr, route.adr) END END; GetEntry(key, "Gateway", gateway, num); ToHost0(num, route.gway, done); IF ~done THEN	(* ok if not arp, e.g. SLIP or PPP *) route.gway := NetIP.IPany END; GetEntry(key, "Netmask", dmy, num); ToHost0(num, route.subnet, done); IF ~done THEN	(* ok if not arp, e.g. SLIP or PPP *) route.subnet := NetIP.IPany	(* all destinations local *) END; IF (SYSTEM.VAL(LONGINT, anyIP) = SYSTEM.VAL(LONGINT, route.gway)) & (SYSTEM.VAL(LONGINT, anyIP) # SYSTEM.VAL(LONGINT, route.adr)) THEN (* gateway not set, but host adr set - attempt auto setting *) FOR j := 0 TO NetIP.AdrLen-1 DO	(* take host address AND subnet mask *) route.gway[j] := SYSTEM.VAL(CHAR, SYSTEM.VAL(SET, route.adr[j]) * 							SYSTEM.VAL(SET, route.subnet[j])) END; (* add .1 at end (common convention) *) route.gway[3] := SYSTEM.VAL(CHAR, SYSTEM.VAL(SET, route.gway[3]) + {0}); (*log := TRUE*) END; (* 			IF log THEN 				ToNum(SYSTEM.VAL(IPAdr, route.adr), s); 				Texts.WriteString(W, "IP: "); Texts.WriteString(W, s); 				ToNum(SYSTEM.VAL(IPAdr, route.subnet), s); 				Texts.WriteString(W, ", Subnet: ");  Texts.WriteString(W, s); 				ToNum(SYSTEM.VAL(IPAdr, route.gway), s); 				Texts.WriteString(W, ", Gateway: ");  Texts.WriteString(W, s); 				Texts.WriteLn(W);  Texts.Append(Oberon.Log, W.buf) 			END; *) NetIP.InstallRoute(route) ELSE Texts.WriteString(W, "Device ["); Texts.WriteString(W, device); Texts.WriteString(W, "] not found"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) END; INC(i); key[21] := CHR(i+ORD("0")); GetEntry0(key, "Device", device) END END SetRoutes; PROCEDURE SetDns; VAR name, num, dns: ARRAY 64 OF CHAR; i, nodns: INTEGER; adr: NetIP.Adr; done: BOOLEAN; BEGIN nodns := 0; dns := "DNS0"; FOR i := 0 TO 3 DO 		dns[3] := CHR(i + ORD("0")); GetEntry("NetSystem.Hosts.", dns, name, num); IF (num # "") & (num[0] # "<") THEN ToHost0(num, adr, done); IF done THEN NetDNS.InstallDNS(name, adr); INC(nodns) END END END; IF nodns = 0 THEN ToHost0("129.132.98.12", adr, done); NetDNS.InstallDNS("dns1.ethz.ch", adr) END; END SetDns; PROCEDURE PollDevices(me: Oberon.Task); BEGIN NetBase.Poll END PollDevices; (** Command NetSystem.Start ~ Start up NetSystem. *) PROCEDURE Start*; VAR name, num: ARRAY 64 OF CHAR; pos: LONGINT;  ch: CHAR; BEGIN IF ~started THEN SetDevices; IF NetBase.FindDevice(0) # NIL THEN SetRoutes; NetDNS.Init; GetEntry("NetSystem.Hosts.", "Domain", name, num); IF name # "" THEN IF hostName # "" THEN	(* check hostname *) pos := 0; Strings.Search(".", hostName, pos); IF pos = -1 THEN	(* append domain name *) Strings.AppendCh(hostName, "."); Strings.Append(hostName, name) END END; NetDNS.InstallDom(name); ELSE NetDNS.InstallDom("ethz.ch") END; SetDns; started := NetIP.nofRoutes > 0; IF started THEN NetIP.SetDirectedCast(NetIP.routes[0]); NetBase.Start; NetIP.Start; NetPorts.Init; NetUDP.Start; NetTCP.Start; NEW(task); task.safe := TRUE; task.time := Oberon.Time;  task.handle := PollDevices; Oberon.Install(task); IF (hostName = "") & (SYSTEM.VAL(LONGINT, anyIP) # (SYSTEM.VAL(LONGINT, hostIP))) THEN (*Texts.WriteString(W, "Host: "); Texts.Append(Oberon.Log, W.buf);*) GetName(hostIP, hostName); pos := 0; LOOP ch := hostName[pos]; IF ch = 0X THEN EXIT END; IF (ch >= "A") & (ch <= "Z") THEN ch := CHR(ORD(ch)+32) END; hostName[pos] := ch; INC(pos) END; IF pos = 0 THEN hostName := "x.oberon.ethz.ch" END; (*Texts.WriteString(W, hostName); Texts.WriteLn(W)*) END; Texts.WriteString(W, "NetSystem started"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) ELSE Texts.WriteString(W, "Oberon.Text - NetSystem not configured"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) END ELSE Texts.WriteString(W, "Oberon.Text - No network driver configured"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) END END END Start; (** Command NetSystem.Stop ~ Shut down NetSystem. *) PROCEDURE Stop*; BEGIN IF Kernel.shutdown = 0 THEN IF task # NIL THEN Oberon.Remove(task); task := NIL END; NetTCP.Stop; NetUDP.Stop; NetIP.Stop; NetBase.Stop; hostName := ""; started := FALSE; Texts.WriteString(W, "NetSystem stopped"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) END END Stop; (** Command NetSystem.Show ~ Display status. *) PROCEDURE Show*; VAR s: ARRAY 32 OF CHAR; r: NetIP.Route;  dev: NetBase.Device;  i: LONGINT;  p: Password; BEGIN IF started THEN p := passwords; WHILE p # NIL DO WriteURL(p.service, p.user, p.host); p := p.next END; Texts.WriteString(W, "Host: "); ToNum(hostIP, s);  Texts.WriteString(W, s); Texts.WriteString(W, " / "); Texts.WriteString(W, hostName); Texts.WriteString(W, " / "); Texts.WriteString(W, NetDNS.dom[0]); Texts.WriteLn(W); i := 0; LOOP dev := NetBase.FindDevice(i); IF dev = NIL THEN EXIT END; Texts.WriteString(W, "Device"); Texts.WriteInt(W, i, 1); Texts.WriteString(W, ": "); CASE dev.state OF 				NetBase.closed: Texts.WriteString(W, "closed") |NetBase.open: Texts.WriteString(W, "open") |NetBase.pending: Texts.WriteString(W, "pending") ELSE Texts.WriteInt(W, dev.state, 1) END; Texts.Write(W, " "); AdrToStr(dev.hostAdr, s); Texts.WriteString(W, s);  Texts.WriteString(W, " / "); AdrToStr(dev.castAdr, s); Texts.WriteString(W, s); Texts.WriteLn(W); INC(i) END; FOR i := 0 TO NetIP.nofRoutes-1 DO 			r := NetIP.routes[i]; Texts.WriteString(W, "Route"); Texts.WriteInt(W, i, 1);  Texts.WriteString(W, ": "); ToNum(SYSTEM.VAL(IPAdr, r.adr), s); Texts.WriteString(W, s);  Texts.WriteString(W, " / "); ToNum(SYSTEM.VAL(IPAdr, r.subnet), s); Texts.WriteString(W, s);  Texts.WriteString(W, " / "); ToNum(SYSTEM.VAL(IPAdr, r.gway), s); Texts.WriteString(W, s);  Texts.WriteString(W, " -> "); Texts.WriteInt(W, r.dev.num, 1); IF NetIP.arpopt IN r.options THEN Texts.WriteString(W, " arp") ELSE Texts.WriteString(W, " noarp") END; Texts.WriteLn(W) END; Texts.WriteString(W, "DNS: "); FOR i := 0 TO NetDNS.nofdns-1 DO 			ToNum(SYSTEM.VAL(IPAdr, NetDNS.server[i].adr), s); Texts.WriteString(W, s); IF i = NetDNS.dns THEN Texts.Write(W, "*") END; IF i # NetDNS.nofdns-1 THEN Texts.WriteString(W, " / ") END END; Texts.WriteLn(W) END; Texts.Append(Oberon.Log, W.buf) END Show; BEGIN task := NIL; anyIP := SYSTEM.VAL(IPAdr, NetIP.IPany); allIP := SYSTEM.VAL(IPAdr, NetIP.IPall); hostName := ""; hex := "0123456789ABCDEF"; Texts.OpenWriter(W); started := FALSE; passwords := NIL; Start; Kernel.InstallTermHandler(Stop) END NetSystem. Tasks NetBase.Poll for all devices, if Available then allocate item, Receive, multiplex upcall: NetIP.ArpReceive - send arp queued packets & reply to arp request NetIP.IPReceive - queue up to 30 packets in NetIP.ipq NetIP.IPDemux for all items in NetIP.ipq, check header, multiplex upcall: NetUDP.Input - find connection c & put up to 20 items to c.rq 			NetTCP.Demux - handle some items or put up to 30 items in c.rq 	NetTCP.TcpReceive one task per connection. for all items in c.rq, call c.handle NetIP.Timer every 3 seconds, process arp cache NetTCP.Timer process events in NetTCP.sq (deleteev, sendev, retransev, persistev) Install NetIP.StartTimer NetBase.InstallProtocol(ArpReceive, arpid)	(* 806H *) timer.handle := Timer; Oberon.Install(timer) NetIP.StartIP NetBase.InstallProtocol(IPReceive, ipid)	(* 800H *) NetUDP.Start NetIP.InstallDemux(Input, NetIP.UDP)	(* 17 *) NetTCP.Start NetIP.InstallDemux(Demux, NetIP.TCP)	(* 6 *) timer.handle := Timer; Oberon.Install(timer) NetTCP.ProcListen (from NetTCP.Demux) T.handle := TcpReceive; Oberon.Install(T) NetTCP.Connect T.handle := TcpReceive; Oberon.Install(T) Modification NetSystem.TCPSetState fold into State bug: NetTCP.Poll does not check window... ? Other uses of Oberon & Texts NetSystem Oberon.Par, Oberon.Log, Oberon.OpenScanner, Texts.* SLIP.InstallDevice Oberon.Par, Texts.Scanner PPPHDLC Timeout task PPPMain Oberon.OpenScanner Connect task Connection state (old) closed, listening, in, out, inout, waitCon, errorCon inout -> out	TCPSetState	~NetTCP.Connected in -> closed	TCPSetState	~NetTCP.Connected * -> listening	OpenConnection	listening connection * -> inout	OpenConnection	talking connection * -> closed	CloseConnection	listening connection inout -> in	CloseConnection	talking connection out -> closed	CloseConnection	talking connection * -> inout	Accept	arriving connection * -> waitCon	AsyncOpenConnection waitCon -> inout waitCon -> errorCon * -> inout	OpenSocket * -> closed	CloseSocket Dialer.Dial Dialer.Hangup NetSystem.Stop System.Free NetSystem SLIP NetTCP NetDNS NetUDP NetPorts NetIP NetBase ~ NetSystem.Start Find.All ^ Find.Domain NetBase.Mod NetIP.Mod NetPorts.Mod NetUDP.Mod NetTCP.Mod NetDNS.Mod NetSystem.Mod ~ Compiler.Compile NetBase.Mod\s NetIP.Mod\s NetPorts.Mod\s NetUDP.Mod\s NetTCP.Mod\s NetDNS.Mod\s NetSystem.Mod Net3Com509.Mod ~ Compiler.Compile *\x

license: Creative Commons - Attribution Share-Alike - https://creativecommons.org/licenses/by-sa/4.0/

title: Oberon/ETH Oberon/2.3.7/NetSystem.Mod


text:
Oberon/ETH Oberon/2.3.7/PSPrinter.Mod

(* ETH Oberon, Copyright 1990-2003 Computer Systems Institute, ETH Zurich, CH-8092 Zurich. Refer to the license.txt file provided with this distribution. *) MODULE PSPrinter; (** portable *)	(*UNIX version: JT 11.5.90, RC 2.7.93, JS 29.4.9, Windows version: jm 20.12.95 *) (* 		wdm 2000-02-21 duplex printing: uses option "x" 		jm 20.12.95 EPS support added 		ps 4.8.96 added border to page (left, right: 2cm / top, bottom: 1.5 cm) 	*) IMPORT Files, Modules, Printer, Objects, Fonts, Texts, Strings, Oberon, Pictures; CONST N = 20;	(* max spline points *) maxFonts = 64; headerFileName = "PSHeader.Text"; bold = 0; italics = 1; medium = 2; oneup = 0; twoup = 1;  fourup = 2;  rotated = 3; TYPE Name* = ARRAY 32 OF CHAR; PSPrinter* = POINTER TO PSPrinterDesc; PSPrinterDesc* = RECORD (Printer.PrinterDesc) Escape*: PROCEDURE (P: Printer.Printer; s: ARRAY OF CHAR); printF*: Files.File; eps*: BOOLEAN; (** Is EPS output being written? *) pno*: INTEGER; (** Current page being printer on (starts with 1) *) l, t, r, b: LONGINT; sx, sy: INTEGER; (* current string pos *) mode, location: SHORTINT; duplex: BOOLEAN; (* Print duplex pages *) anonymous: BOOLEAN END; FontDesc = RECORD name: Name; used: ARRAY 8 OF SET; END; RealVector = ARRAY N OF REAL; Poly = RECORD a, b, c, d, t: REAL END ; PolyVector = ARRAY N OF Poly; TYPE FontDef = POINTER TO FontDefDesc; FontDefDesc = RECORD name: ARRAY 64 OF CHAR; family: ARRAY 32 OF CHAR; size: INTEGER; attr: CHAR; next: FontDef END; VAR (* to do: many of these variables should be local to the printer object *) fontTable: ARRAY maxFonts OF FontDesc; fontIndex, curFont: INTEGER; listFont: Name; headerT: Texts.Text; bodyF: Files.File; bodyR: Files.Rider; ppos: LONGINT; hexArray: ARRAY 17 OF CHAR; curR, curG, curB, setR, setG, setB: INTEGER; metric: Objects.Library; fontMapDict: FontDef; fontMapDictN: INTEGER; default: Objects.Name; (* -- Output procedures -- *) PROCEDURE Ch (VAR R: Files.Rider; ch: CHAR); BEGIN Files.Write(R, ch) END Ch; PROCEDURE Str (VAR R: Files.Rider; s: ARRAY OF CHAR); VAR i: INTEGER; BEGIN i := 0; WHILE s[i] # 0X DO Ch(R, s[i]); INC(i) END; END Str; PROCEDURE Int (VAR R: Files.Rider; i: LONGINT); VAR j: LONGINT; BEGIN IF i = 0 THEN Ch(R, "0") ELSIF i < 0 THEN i := -i; Ch(R, "-") END; j := 1; WHILE (i DIV j) # 0 DO j := j * 10 END; WHILE j >= 10 DO j := j DIV 10; Ch(R, CHR(30H + (i DIV j) MOD 10)) END; END Int; PROCEDURE Hex2(VAR R: Files.Rider; ch: CHAR); BEGIN Ch(R, hexArray[ORD(ch) DIV 16]); Ch(R, hexArray[ORD(ch) MOD 16]); END Hex2; PROCEDURE Real(VAR R: Files.Rider; x: REAL); VAR n, i, xi: INTEGER; d: ARRAY 4 OF CHAR; BEGIN xi := SHORT(ENTIER(x)); IF x = xi THEN Int(R, xi); RETURN END; IF x < 0 THEN Files.Write(R, "-"); x := -x; xi := -xi END; Int(R, xi); Files.Write(R, "."); x := x-xi; n := SHORT(ENTIER(x*1000)); i := 0; REPEAT d[i] := CHR(n MOD 10+30H); n := n DIV 10; INC(i) UNTIL i = 3; WHILE i > 0 DO DEC(i); Files.Write(R, d[i]) END END Real; PROCEDURE Ln(VAR R: Files.Rider); BEGIN Ch(R, 0DX); Ch(R, 0AX); END Ln; (* -- Error handling -- *) PROCEDURE Error(s0, s1: ARRAY OF CHAR); VAR error, f: ARRAY 32 OF CHAR; BEGIN COPY(s0, error); COPY(s1, f); HALT(99) END Error; (* -- Bounding Box -- *) PROCEDURE Min(x, y: LONGINT): LONGINT; BEGIN IF x < y THEN RETURN x ELSE RETURN y END END Min; (* Increase the size of the bounding box. *) PROCEDURE Box*(P: PSPrinter; x, y, w, h: LONGINT); BEGIN IF x < P.l THEN P.l := x END; IF x + w - 1 > P.r THEN P.r := x + w - 1 END; IF y < P.b THEN P.b := y END; IF y + h - 1 > P.t THEN P.t := y + h - 1 END; END Box; (* -- Font Mapping -- *) PROCEDURE SetMappedFont(VAR fontR: Files.Rider; fname: ARRAY OF CHAR); VAR family: ARRAY 7 OF CHAR; BEGIN COPY(fname, family); Ch(fontR, "/"); Str(fontR, fname); IF (family = "Syntax") OR (family = "Oberon") OR (family = "Default") THEN Str(fontR, " DefineSMapFont") ELSE Str(fontR, " DefineMapFont") END; Ln(fontR); Ln(fontR); END SetMappedFont; PROCEDURE SetBitmapFont(VAR fontR, R: Files.Rider; fd: FontDesc; pRes: INTEGER); TYPE RunRec = RECORD beg, end: INTEGER END; Metrics = RECORD dx, x, y, w, h: INTEGER END; VAR ch: CHAR; pixmapDX, n, b: LONGINT; k, m: INTEGER; height, minX, maxX, minY, maxY: INTEGER; nOfBoxes, nOfRuns: INTEGER; run: ARRAY 16 OF RunRec; metrics: ARRAY 256 OF Metrics; PROCEDURE Flip(ch: CHAR): CHAR; VAR i, s, d: INTEGER; BEGIN i := 0; s := ORD(ch); d := 0; WHILE i < 8 DO 				IF s MOD 2 = 1 THEN d := d * 2 + 1 ELSE d := d * 2 END; s := s DIV 2; INC(i) END; RETURN CHR(d); END Flip; PROCEDURE Name(m: INTEGER); BEGIN CASE m OF 			| 9: Str(fontR, "tab") | 32: Str(fontR, "space") | 33: Str(fontR, "exclam") | 34: Str(fontR, "quotedbl") | 35: Str(fontR, "numbersign") | 36: Str(fontR, "dollar") | 37: Str(fontR, "percent") | 38: Str(fontR, "ampersand") | 39: Str(fontR, "quotesingle") | 40: Str(fontR, "parenleft") | 41: Str(fontR, "parenright") | 42: Str(fontR, "asterisk") | 43: Str(fontR, "plus") | 44: Str(fontR, "comma") | 45: Str(fontR, "minus") | 46: Str(fontR, "period") | 47: Str(fontR, "slash") | 48: Str(fontR, "zero") | 49: Str(fontR, "one") | 50: Str(fontR, "two") | 51: Str(fontR, "three") | 52: Str(fontR, "four") | 53: Str(fontR, "five") | 54: Str(fontR, "six") | 55: Str(fontR, "seven") | 56: Str(fontR, "eight") | 57: Str(fontR, "nine") | 58: Str(fontR, "colon") | 59: Str(fontR, "semicolon") | 60: Str(fontR, "less") | 61: Str(fontR, "equal") | 62: Str(fontR, "greater") | 63: Str(fontR, "question") | 64: Str(fontR, "at") | 65..90: Ch(fontR, CHR(m)) | 91: Str(fontR, "bracketleft") | 92: Str(fontR, "backslash") | 93: Str(fontR, "bracketright") | 94: Str(fontR, "arrowup") | 95: Str(fontR, "underscore") | 96: Str(fontR, "grave") | 97..122: Ch(fontR, CHR(m)) | 123: Str(fontR, "braceleft") | 124: Str(fontR, "bar") | 125: Str(fontR, "braceright") | 126: Str(fontR, "tilde") | 128: Str(fontR, "Adieresis") | 129: Str(fontR, "Odieresis") | 130: Str(fontR, "Udieresis") | 131: Str(fontR, "adieresis") | 132: Str(fontR, "odieresis") | 133: Str(fontR, "udieresis") | 134: Str(fontR, "acircumflex") | 135: Str(fontR, "ecircumflex") | 136: Str(fontR, "icircumflex") | 137: Str(fontR, "oicircumflex") | 138: Str(fontR, "uicircumflex") | 139: Str(fontR, "agrave") | 140: Str(fontR, "egrave") | 141: Str(fontR, "igrave") | 142: Str(fontR, "ograve") | 143: Str(fontR, "ugrave") | 144: Str(fontR, "eacute") | 145: Str(fontR, "edieresis") | 146: Str(fontR, "idieresis") | 147: Str(fontR, "ccedilla") | 148: Str(fontR, "aacute") | 149: Str(fontR, "ntilde") | 150: Str(fontR, "germandbls") | 155: Str(fontR, "endash") | 159: Str(fontR, "hyphen") ELSE Str(fontR, "ascii"); Ch(fontR, CHR(30H + (m DIV 100) MOD 10)); Ch(fontR, CHR(30H + (m DIV 10) MOD 10)); Ch(fontR, CHR(30H + m MOD 10)) END END Name; BEGIN Str(fontR, "% Conversion of the Oberon font "); Str(fontR, fd.name); Ln(fontR); Files.Read(R, ch); IF ch = Fonts.FontId THEN Files.Read(R, ch); Str(fontR, "% abstraction: "); Int(fontR, ORD(ch)); Files.Read(R, ch); Str(fontR, ", family: "); Ch(fontR, ch); Files.Read(R, ch); Str(fontR, ", variant: "); Int(fontR, ORD(ch)); Ln(fontR); Files.ReadInt(R, height); Str(fontR, "% height: "); Int(fontR, height); Ln(fontR); Ln(fontR); Files.ReadInt(R, minX); Files.ReadInt(R, maxX); Files.ReadInt(R, minY); Files.ReadInt(R, maxY); Files.ReadInt(R, nOfRuns); nOfBoxes := 0; k := 0; WHILE k # nOfRuns DO 				Files.ReadInt(R, run[k].beg); Files.ReadInt(R, run[k].end); INC(nOfBoxes, run[k].end - run[k].beg); INC(k) END; Str(fontR, "9 dict begin"); Ln(fontR); Ln(fontR); Str(fontR, "/FontType 3 def"); Ln(fontR); Str(fontR, "/FontMatrix [ 72 "); Int(fontR, pRes); Str(fontR, " div "); Str(fontR, " factor1 div 0 0 "); Str(fontR, "72 "); Int(fontR, pRes); Str(fontR, " div "); Str(fontR, " factor2 div 0 0"); Str(fontR, "] def"); Ln(fontR); Str(fontR, "/FontBBox ["); Int(fontR, minX); Ch(fontR, " "); Int(fontR, minY); Ch(fontR, " "); Int(fontR, maxX); Ch(fontR, " "); Int(fontR, maxY); Str(fontR, "] def"); Ln(fontR); Ln(fontR); Str(fontR, "/Encoding 256 array def"); Ln(fontR); Str(fontR, "0 1 255 {Encoding exch /.notdef put} for"); Ln(fontR); Str(fontR, "Encoding OberonEncoding /Encoding exch def"); Ln(fontR); Ln(fontR); Str(fontR, "/CharData "); Int(fontR, nOfBoxes+1); Str(fontR, " dict def"); Ln(fontR); Str(fontR, "CharData begin"); Ln(fontR); k := 0; m := 0; WHILE k < nOfRuns DO 				m := run[k].beg; WHILE m < run[k].end DO 					Files.ReadInt(R, metrics[m].dx); Files.ReadInt(R, metrics[m].x); Files.ReadInt(R, metrics[m].y); Files.ReadInt(R, metrics[m].w); Files.ReadInt(R, metrics[m].h); INC(m); END; INC(k) END; Str(fontR, "/.notdef"); Str(fontR, " ["); Int(fontR, metrics[32].w); Str(fontR, " 0 0 0 0 1 1 0 0"); Ln(fontR); Str(fontR, "<>] bdef"); Ln(fontR); k := 0; m := 0; WHILE k < nOfRuns DO 				m := run[k].beg; WHILE m < run[k].end DO 					IF m MOD 32 IN fd.used[m DIV 32] THEN Str(fontR, "/"); Name(m); Str(fontR, " ["); Int(fontR, metrics[m].dx); Str(fontR, " "); Int(fontR, metrics[m].x); Str(fontR, " "); Int(fontR, metrics[m].y); Str(fontR, " "); Int(fontR, metrics[m].x + metrics[m].w); Str(fontR, " "); Int(fontR, metrics[m].y + metrics[m].h); Str(fontR, " "); IF metrics[m].w > 0 THEN Int(fontR, metrics[m].w); ELSE Int(fontR, 1) END; Str(fontR, " "); IF metrics[m].h > 0 THEN Int(fontR, metrics[m].h); ELSE Int(fontR, 1) END; Str(fontR, " "); Int(fontR, -metrics[m].x); Str(fontR, " "); Int(fontR, -metrics[m].y); Ln(fontR); Str(fontR, "<"); pixmapDX := (metrics[m].w + 7) DIV 8; n := pixmapDX * metrics[m].h; 						b := 0; WHILE b < n DO 							Files.Read(R, ch); Hex2(fontR, Flip(ch)); INC(b); IF b MOD 32 = 0 THEN Ln(fontR); Str(fontR, " ") END END; Str(fontR, ">] bdef"); Ln(fontR); ELSE n := (metrics[m].w + 7) DIV 8 * metrics[m].h; 						b := 0; WHILE b < n DO Files.Read(R, ch); INC(b) END; END; INC(m); END; INC(k) END; Str(fontR, " end"); Ln(fontR); Ln(fontR); Str(fontR, "/BuildGlyph {GlobalBuildGlyph} bdef"); Ln(fontR); Str(fontR, "/BuildChar {GlobalBuildChar} bdef"); Ln(fontR); Ln(fontR); Str(fontR, "/imageMaskMatrix [1 0 0 1 0 0] bdef"); Ln(fontR); Ln(fontR); Str(fontR, "currentdict"); Ln(fontR); Ln(fontR); Str(fontR, "end"); Ln(fontR); Ln(fontR); Ch(fontR, "/"); Str(fontR, fd.name); Str(fontR, " exch definefont pop"); Ln(fontR); Ln(fontR); END; END SetBitmapFont; PROCEDURE DefineFont(VAR fontR: Files.Rider; fd: FontDesc; echo: BOOLEAN); VAR family, name: ARRAY 32 OF CHAR; i, size, dpi: INTEGER; f: Files.File; R: Files.Rider; fontDef: FontDef; attr: CHAR; BEGIN dpi := SHORT(914400 DIV Printer.current.Unit); COPY(fd.name, name); i := 0; size := 0; WHILE (name[i] # 0X) & (name[i] # ".") & ((name[i] < "0") OR (name[i] > "9")) DO 			family[i] := name[i]; INC(i) END; family[i] := 0X; size := 0; WHILE (name[i] >= "0") & (name[i] <= "9") DO size := size * 10 + ORD(name[i]) - 30H; INC(i) END; attr := 0X; WHILE (name[i] # 0X) & (name[i] # ".") DO attr := CAP(name[i]); INC(i) END; fontDef := fontMapDict; WHILE (fontDef # NIL) & ~((fontDef.size = size) & (fontDef.attr = attr) & (fontDef.family = family)) DO 			fontDef := fontDef.next END; IF fontDef = NIL THEN NEW(fontDef); fontDef.next := fontMapDict; fontMapDict := fontDef; INC(fontMapDictN); COPY(name, fontDef.name); COPY(family, fontDef.family); fontDef.size := size; fontDef.attr := attr END; IF ~echo THEN RETURN END; IF (name[i] # ".") OR (name[i+1] # "S") OR (name[i+2] # "c") OR (name[i+3] # "n") THEN SetMappedFont (fontR, fd.name); ELSE name[i+1] := "P"; name[i+2] := "r"; name[i+3] := CHR((dpi DIV 100)+ORD("0")); f := Files.Old(name); IF f = NIL THEN SetMappedFont (fontR, fd.name); ELSE Files.Set(R, f, 0); SetBitmapFont(fontR, R, fd, dpi) END; END; END DefineFont; (* -- Metric Font loading -- *) PROCEDURE ParseName (VAR name, family: ARRAY OF CHAR; VAR size: LONGINT; VAR style: SET; VAR class: ARRAY OF CHAR); VAR i, j: INTEGER; BEGIN size := 0; style := {}; i := 0; WHILE (name[i] > "9") OR (name[i] = " ") DO family[i] := name[i]; INC(i) END; family[i] := 0X; WHILE ("0" <= name[i]) & (name[i] <= "9") DO size := 10*size + (ORD(name[i]) - 30H); INC(i) END; WHILE (name[i] # 0X) & (name[i] # ".") DO 			CASE CAP(name[i]) OF 				| "I": INCL(style, italics); name[i] := "i" | "B": INCL(style, bold); name[i] := "b" | "M": INCL(style, medium); name[i] := "m" ELSE END; INC(i) END; j := 0; INC(i); WHILE (name[i] # 0X) & (name[i] # ".") DO class[j] := name[i]; INC(i); INC(j) END; class[j] := 0X; END ParseName; (* -- Exported Procedures -- *) PROCEDURE GetDim(P: Printer.Printer; label: ARRAY OF CHAR;  def: INTEGER;  VAR val: INTEGER); VAR v: REAL; S: Texts.Scanner; BEGIN Oberon.OpenScanner(S, label); IF S.class IN {Texts.Int, Texts.Real} THEN IF S.class = Texts.Int THEN v := S.i 			ELSE v := S.x 			END; Texts.Scan(S); IF S.class IN {Texts.Name, Texts.String} THEN IF S.s = "cm" THEN v := v*360000.0 ELSIF S.s = "mm" THEN v := v*36000.0 ELSIF S.s = "in" THEN v := v*36000.0*25.4 ELSE v := v*36000.0	(* default mm *) END ELSE v := v*36000.0	(* default mm *) END; val := SHORT(ENTIER(v/P.Unit + 0.5)) ELSE val := SHORT(ENTIER(def*36000.0/P.Unit + 0.5)) END END GetDim; PROCEDURE Swap(VAR x, y: INTEGER); VAR t: INTEGER; BEGIN t := x; x := y;  y := t 	END Swap; PROCEDURE InitMetrics*(P: Printer.Printer); VAR S: Texts.Scanner; BEGIN Oberon.OpenScanner(S, "PSPrinter.Resolution"); IF S.class # Texts.Int THEN S.i := 300 END;	(* default *) P.Unit := 914400 DIV S.i; P.Depth := 24; GetDim(P, "PSPrinter.Width", 210, P.Width); GetDim(P, "PSPrinter.Height", 297, P.Height); GetDim(P, "PSPrinter.LeftMargin", 20, P.FrameX); GetDim(P, "PSPrinter.RightMargin", 20, P.FrameW); P.FrameW := P.Width-P.FrameX-P.FrameW; GetDim(P, "PSPrinter.BottomMargin", 15, P.FrameY); GetDim(P, "PSPrinter.TopMargin", 15, P.FrameH); P.FrameH := P.Height-P.FrameY-P.FrameH; IF P(PSPrinter).mode = rotated THEN Swap(P.Width, P.Height); Swap(P.FrameX, P.FrameY);  Swap(P.FrameW, P.FrameH) END END InitMetrics; PROCEDURE GetSuffix(VAR str(** in *), suf(** out *): ARRAY OF CHAR); VAR i, j, dot: LONGINT; BEGIN dot := -1; i := 0; WHILE str[i] # 0X DO IF str[i] = "." THEN dot := i END; INC(i) END; j := 0; IF dot > 0 THEN i := dot+1; WHILE str[i] # 0X DO 				suf[j] := str[i]; INC(j); INC(i) END END; suf[j] := 0X END GetSuffix; PROCEDURE SetColor; BEGIN IF (setR # curR) OR (setG # curG) OR (setB # curB) THEN setR := curR; setG := curG;  setB := curB; Real(bodyR, setR/255); Ch(bodyR, " "); Real(bodyR, setG/255); Ch(bodyR, " "); Real(bodyR, setB/255); Ch(bodyR, " "); Str(bodyR, "u "); Ln(bodyR) END END SetColor; PROCEDURE ResetColor; BEGIN curR := 0; curG := 0; curB := 0; setR := 0; setG := 0;  setB := 0	(* default color is black, set by /OberonInit and /p *) END ResetColor; PROCEDURE Open*(P: Printer.Printer; printer, options: ARRAY OF CHAR); VAR suffix: ARRAY 32 OF CHAR; i: LONGINT; BEGIN WITH P: PSPrinter DO 			ResetColor; P.res := 1;	(* no such printer *) P.printF := Files.New(printer); IF P.printF = NIL THEN P.printF := Files.New(""); P.anonymous := TRUE ELSE P.anonymous := FALSE END; GetSuffix(printer, suffix); P.eps := (suffix = "EPS") OR (suffix = "eps"); i := 0; P.mode := oneup;  P.location := 0; WHILE (options[i] # 0X) & (options[i] # Oberon.OptionChar) DO 				IF options[i] = "l" THEN P.mode := twoup ELSIF options[i] = "d" THEN P.mode := fourup ELSIF options[i] = "e" THEN P.eps := TRUE ELSIF options[i] = "r" THEN P.mode := rotated ELSIF options[i] = "x" THEN P.duplex := TRUE END; INC(i) END; InitMetrics(P); fontMapDict := NIL; fontMapDictN := 0; P.l := MAX(LONGINT); P.r := MIN(LONGINT); P.t := MIN(LONGINT); P.b := MAX(LONGINT); NEW(headerT); Texts.Open(headerT, headerFileName); IF headerT.len > 0 THEN bodyF := Files.New(""); Files.Set(bodyR, bodyF, 0); fontIndex := -1; curFont := -1; listFont := ""; ppos := 0; P.pno := 1; P.res := 0 ELSE Error("file not found", headerFileName) END END END Open; PROCEDURE UseListFont*(P: Printer.Printer; name: ARRAY OF CHAR); BEGIN COPY(name, listFont); curFont := -1 END UseListFont; (** Don't forget to update the bounding box of eps files by calling procedure Box. *) PROCEDURE Escape*(P: Printer.Printer; s: ARRAY OF CHAR); BEGIN WITH P: PSPrinter DO 			(* Don't make more that one page when making eps *) IF P.eps & (P.pno > 1) THEN RETURN END; SetColor; Str(bodyR, s) 		END END Escape; PROCEDURE ReplConst*(P: Printer.Printer; x, y, w, h: INTEGER); BEGIN WITH P: PSPrinter DO 			(* Don't make more that one page when making eps *) IF P.eps & (P.pno > 1) THEN RETURN END; IF (w > 0) & (h > 0) THEN SetColor; Box(P, x, y, w, h); Int(bodyR, x+1); Ch(bodyR, " "); Int(bodyR, y); Ch(bodyR, " "); Int(bodyR, w-1); Ch(bodyR, " "); Int(bodyR, h-1); Str(bodyR, " l"); Ln(bodyR); END END END ReplConst; PROCEDURE StringSize(VAR s: ARRAY OF CHAR; fnt: Fonts.Font; VAR w, h, dsr: INTEGER); VAR p: INTEGER; obj: Objects.Object; BEGIN w := 0; h := 0; dsr := 0; p := 0; IF (metric = NIL) OR (fnt.name # metric.name) THEN metric := Printer.GetMetric(fnt) END; IF (metric # NIL) & (metric(Fonts.Font).type = Fonts.metric) THEN WHILE s[p] # 0X DO 				metric.GetObj(metric, ORD(s[p]), obj); INC(w, obj(Fonts.Char).dx); INC(p) END; h := metric(Fonts.Font).height; dsr := ABS(metric(Fonts.Font).minY); END END StringSize; PROCEDURE ContString*(P: Printer.Printer; s: ARRAY OF CHAR; fnt: Fonts.Font); VAR fNo, i, n, w, h, dsr: INTEGER; ch: CHAR; family: ARRAY 7 OF CHAR; PROCEDURE Use(ch: CHAR); BEGIN INCL(fontTable[curFont].used[ORD(ch) DIV 32], ORD(ch) MOD 32); END Use; BEGIN WITH P: PSPrinter DO 			(* Don't make more that one page when making eps *) IF P.eps & (P.pno > 1) THEN RETURN END; SetColor; StringSize(s, fnt, w, h, dsr); Box(P, P.sx - dsr, P.sy, w, h); INC(P.sx, w); IF (curFont < 0) OR (fontTable[curFont].name # fnt.name) THEN COPY(fnt.name, fontTable[fontIndex+1].name); i := 0; WHILE i < 8 DO fontTable[fontIndex+1].used[i] := {}; INC(i) END; fNo := 0; WHILE fontTable[fNo].name # fnt.name DO INC(fNo) END; IF fNo > fontIndex THEN (* DefineFont(fname); *) fontIndex := fNo END; curFont := fNo; Ch(bodyR, "("); 				IF fontTable[curFont].name = listFont THEN 					Str(bodyR, "Courier8.Scn.Fnt") 				ELSE 					Str(bodyR, fontTable[curFont].name) 				END; 				Str(bodyR, ") f ") END; Ch(bodyR, "("); 			i := 0; ch := s[0]; 			WHILE ch # 0X DO 				CASE ch OF 				| "(", ")", "\": Ch(bodyR, "\"); Ch(bodyR, ch); Use(ch); 				| 9X: Str(bodyR, " "); Use(" ")	(* or Str("\tab") *) 				| 80X..95X, 0ABX: 					Str(bodyR, "\2"); n := ORD(ch)-128; 					Ch(bodyR, CHR(n DIV 8 + 48)); Ch(bodyR, CHR(n MOD 8 + 48)); Use(ch) 				| 9FX: COPY(fontTable[curFont].name, family); 					IF family = "Courie" THEN Ch(bodyR, " ") ELSE Str(bodyR, "  ") END; Use(" "); 				ELSE 					Ch(bodyR, ch); Use(ch); 				END ; 				INC(i); ch := s[i]; 			END; 			Str(bodyR, ") s"); Ln(bodyR) END END ContString; PROCEDURE String*(P: Printer.Printer; x, y: INTEGER; s: ARRAY OF CHAR; fnt: Fonts.Font); VAR w, h, dsr: INTEGER; BEGIN WITH P: PSPrinter DO 			(* Don't make more that one page when making eps *) IF P.eps & (P.pno > 1) THEN RETURN END; SetColor; StringSize(s, fnt, w, h, dsr); Box(P, x - dsr, y, w, h); P.sx := x + w; P.sy := y; 			Int(bodyR, x); Ch(bodyR, " "); Int(bodyR, y); Str(bodyR, " m "); ContString(P, s, fnt) END END String; PROCEDURE ReplPattern*(P: Printer.Printer; x, y, w, h, col: INTEGER); BEGIN WITH P: PSPrinter DO 			(* Don't make more that one page when making eps *) IF P.eps & (P.pno > 1) THEN RETURN END; SetColor; Box(P, x, y, w, h); Int(bodyR, x+1); Ch(bodyR, " "); Int(bodyR, y); Ch(bodyR, " "); Int(bodyR, w-1); Ch(bodyR, " "); Int(bodyR, h-1); Ch(bodyR, " "); Int(bodyR, col); Str(bodyR, " b"); Ln(bodyR) END END ReplPattern; (* mode is not used *) PROCEDURE Picture*(P: Printer.Printer; pict: Pictures.Picture; sx, sy, sw, sh, dx, dy, dw, dh, mode: INTEGER); VAR x, y: INTEGER; n, h0, h1, k, i: INTEGER; h: ARRAY 128 OF INTEGER; PROCEDURE WColTab(n: INTEGER); VAR i, r, g, b: INTEGER; BEGIN i := 0; WHILE i < n DO Pictures.GetColor(pict, i, r, g, b); Hex2(bodyR, CHR(r)); INC(i) END; Ln(bodyR); i := 0; WHILE i < n DO Pictures.GetColor(pict, i, r, g, b); Hex2(bodyR, CHR(g)); INC(i) END; Ln(bodyR); i := 0; WHILE i < n DO Pictures.GetColor(pict, i, r, g, b); Hex2(bodyR, CHR(b)); INC(i) END; Ln(bodyR); END WColTab; PROCEDURE H(n: INTEGER); VAR d0, d1: INTEGER; BEGIN d0 := n MOD 16; IF d0 > 9 THEN INC(d0, 7) END; d1 := n DIV 16; IF d1 > 9 THEN INC(d1, 7) END; Files.Write(bodyR, CHR(d1+30H)); Files.Write(bodyR, CHR(d0+30H)) END H; 		PROCEDURE Out; BEGIN IF n > 0 THEN IF n = 1 THEN H(0); H(h[0]) ELSIF (n = 2) & (h[0] = h[1]) THEN H(81H); H(h[0]) ELSE H(n-1); i := 0; WHILE i < n DO H(h[i]); INC(i) END END; n := 0 END; WHILE k > 128 DO H(127+128); H(h0); DEC(k, 128) END; H(127+k); H(h0) END Out; BEGIN WITH P: PSPrinter DO 			(* Don't make more that one page when making eps *) IF P.eps & (P.pno > 1) THEN RETURN END; Box(P, dx, dy, dw, dh); Str(bodyR, "gsave "); Int(bodyR, dx); Ch(bodyR, " "); Int(bodyR, dy); Str(bodyR, " translate "); Real(bodyR, dw/sw); Ch(bodyR, " "); Real(bodyR, dh/sh); Str(bodyR, " scale "); Int(bodyR, sw); Ch(bodyR, " "); Int(bodyR, sh); Str(bodyR, " rlepic "); WColTab(256); y := sy + sh - 1; WHILE y >= sy DO 				n := 0; x := sx; h0 := Pictures.Get(pict, x, y); INC(x); k := 1; WHILE x < sx + sw DO 					h1 := Pictures.Get(pict, x, y); h[n] := h1; IF h1 = h0 THEN INC(k) ELSE IF k < 3 THEN IF n + k >= 128 THEN H(127); i := 0; WHILE i < n DO H(h[i]); INC(i) END; i := 0; WHILE n + i < 128 DO H(h0); INC(i); DEC(k) END; n := 0 END; WHILE k > 0 DO DEC(k); h[n] := h0; INC(n) END ELSE Out END; h0 := h1; k := 1 END; INC(x) END; Out; DEC(y); Ln(bodyR) END; Ln(bodyR); Str(bodyR, "grestore "); Ln(bodyR) END END Picture; PROCEDURE Circle*(P: Printer.Printer; x0, y0, r: INTEGER); BEGIN WITH P: PSPrinter DO 			(* Don't make more that one page when making eps *) IF P.eps & (P.pno > 1) THEN RETURN END; SetColor; Box(P, x0 - r, y0 - r, r * 2, r * 2); Int(bodyR, x0); Ch(bodyR, " "); Int(bodyR, y0); Ch(bodyR, " "); Int(bodyR, r); Ch(bodyR, " "); Int(bodyR, r); Str(bodyR, " c"); Ln(bodyR) END END Circle; PROCEDURE Ellipse*(P: Printer.Printer; x0, y0, a, b: INTEGER); BEGIN WITH P: PSPrinter DO 			(* Don't make more that one page when making eps *) IF P.eps & (P.pno > 1) THEN RETURN END; SetColor; Box(P, x0 - a, y0 - b, a * 2, b * 2); Int(bodyR, x0); Ch(bodyR, " "); Int(bodyR, y0); Ch(bodyR, " "); Int(bodyR, a); Ch(bodyR, " "); Int(bodyR, b); Str(bodyR, " c"); Ln(bodyR) END END Ellipse; PROCEDURE Line*(P: Printer.Printer; x0, y0, x1, y1: INTEGER); BEGIN WITH P: PSPrinter DO 			(* Don't make more that one page when making eps *) IF P.eps & (P.pno > 1) THEN RETURN END; SetColor; Box(P, Min(x0, x1), Min(y0, y1), ABS(x1 - x0), ABS(y1 - y0)); Int(bodyR, x0); Ch(bodyR, " "); Int(bodyR, y0); Ch(bodyR, " "); Int(bodyR, x1-x0); Ch(bodyR, " "); Int(bodyR, y1-y0); Str(bodyR, " x"); Ln(bodyR) END END Line; PROCEDURE UseColor*(P: Printer.Printer; red, green, blue: INTEGER); BEGIN curR := red; curG := green;  curB := blue END UseColor; (* -- Spline computation -- *) PROCEDURE SolveTriDiag(VAR a, b, c, y: RealVector; n: INTEGER); VAR i: INTEGER; t, tt: REAL; BEGIN (*a, b, c of tri-diag matrix T; solve Ty' = y for y', assign y' to y*) i := 1; WHILE i < n DO t := y[i-1]; y[i] := y[i] - c[i-1]*t; INC(i) END ; i := n-1; y[i] := y[i]/a[i]; WHILE i > 0 DO DEC(i); t := a[i]; tt := b[i]*y[i+1]; y[i] := (y[i] - tt)/t END END SolveTriDiag; PROCEDURE OpenSpline(VAR x, y, d: RealVector; n: INTEGER); VAR i: INTEGER; d1, d2: REAL; a, b, c: RealVector; BEGIN (*from x, y compute d = y'*) b[0] := 1.0/(x[1] - x[0]); a[0] := 2.0*b[0]; c[0] := b[0]; d1 := (y[1] - y[0])*3.0*b[0]*b[0]; d[0] := d1; i := 1; WHILE i < n-1 DO 			b[i] := 1.0/(x[i+1] - x[i]); a[i] := 2.0*(c[i-1] + b[i]); c[i] := b[i]; d2 := (y[i+1] - y[i])*3.0*b[i]*b[i]; d[i] := d1 + d2; d1 := d2; INC(i) END ; a[i] := 2.0*b[i-1]; d[i] := d1; i := 0; WHILE i < n-1 DO c[i] := c[i]/a[i]; a[i+1] := a[i+1] - c[i]*b[i]; INC(i) END ; SolveTriDiag(a, b, c, d, n) 	END OpenSpline; PROCEDURE ClosedSpline(VAR x, y, d: RealVector; n: INTEGER); VAR i: INTEGER; d1, d2, hn, dn: REAL; a, b, c, w: RealVector; BEGIN (*from x, y compute d = y'*) hn := 1.0/(x[n-1] - x[n-2]); dn := (y[n-1] - y[n-2])*3.0*hn*hn; b[0] := 1.0/(x[1] - x[0]); a[0] := 2.0*b[0] + hn; c[0] := b[0]; d1 := (y[1] - y[0])*3.0*b[0]*b[0]; d[0] := dn + d1; w[0] := 1.0; i := 1; WHILE i < n-2 DO 			b[i] := 1.0/(x[i+1] - x[i]); a[i] := 2.0*(c[i-1] + b[i]); c[i] := b[i]; d2 := (y[i+1] - y[i])*3.0*b[i]*b[i]; d[i] := d1 + d2; d1 := d2; w[i] := 0; INC(i) END ; a[i] := 2.0*b[i-1] + hn; d[i] := d1 + dn; w[i] := 1.0; i := 0; WHILE i < n-2 DO c[i] := c[i]/a[i]; a[i+1] := a[i+1] - c[i]*b[i]; INC(i) END ; SolveTriDiag(a, b, c, d, n-1); SolveTriDiag(a, b, c, w, n-1); d1 := (d[0] + d[i])/(w[0] + w[i] + x[i+1] - x[i]); i := 0; WHILE i < n-1 DO d[i] := d[i] - d1*w[i]; INC(i) END ; d[i] := d[0] END ClosedSpline; PROCEDURE PrintPoly(P: PSPrinter; VAR p, q: Poly; lim: REAL); VAR x0, y0, x1, y1, x2, y2, x3, y3: REAL; xx0, yy0, xx1, yy1, xx2, yy2, xx3, yy3: LONGINT; BEGIN x0 := p.d; 		y0 := q.d; 		x1 := x0 + p.c*lim/3.0; y1 := y0 + q.c*lim/3.0; x2 := x1 + (p.c + p.b*lim)*lim/3.0; y2 := y1 + (q.c + q.b*lim)*lim/3.0; x3 := x0 + (p.c + (p.b + p.a*lim)*lim)*lim; y3 := y0 + (q.c + (q.b + q.a*lim)*lim)*lim; xx0 := ENTIER(x0); yy0 := ENTIER(y0); xx1 := ENTIER(x1); yy1 := ENTIER(y1); xx2 := ENTIER(x2); yy2 := ENTIER(y2); xx3 := ENTIER(x3); yy3 := ENTIER(y3); Int(bodyR, xx1); Ch(bodyR, " "); Int(bodyR, yy1); Ch(bodyR, " "); Int(bodyR, xx2); Ch(bodyR, " "); Box(P, Min(xx1, xx2), Min(yy1, yy2), ABS(xx2-xx1), ABS(yy2-yy1)); Int(bodyR, yy2); Ch(bodyR, " "); Int(bodyR, xx3); Ch(bodyR, " "); Box(P, Min(xx2, xx3), Min(yy2, yy3), ABS(xx3-xx2), ABS(yy3-yy2)); Int(bodyR, yy3); Ch(bodyR, " "); Int(bodyR, xx0); Ch(bodyR, " "); Int(bodyR, yy0); Str(bodyR, " z"); Box(P, Min(xx3, xx0), Min(yy3, yy0), ABS(xx0-xx3), ABS(yy0-yy3)); Ln(bodyR); END PrintPoly; PROCEDURE Spline*(P: Printer.Printer; x0, y0, n, open: INTEGER; VAR X, Y: ARRAY OF INTEGER); VAR i: INTEGER; dx, dy, ds: REAL; x, xd, y, yd, s: RealVector; p, q: PolyVector; BEGIN WITH P: PSPrinter DO 			(* Don't make more that one page when making eps *) IF P.eps & (P.pno > 1) THEN RETURN END; SetColor; (*from u, v compute x, y, s*) x[0] := X[0] + x0; y[0] := Y[0] + y0; s[0] := 0; i := 1; WHILE i < n DO 				x[i] := X[i] + x0; dx := x[i] - x[i-1]; y[i] := Y[i] + y0; dy := y[i] - y[i-1]; s[i] := ABS(dx) + ABS(dy) + s[i-1]; INC(i) END ; IF open = 1 THEN OpenSpline(s, x, xd, n); OpenSpline(s, y, yd, n) 			ELSE ClosedSpline(s, x, xd, n); ClosedSpline(s, y, yd, n) 			END ; (*compute coefficients from x, y, xd, yd, s*) i := 0; WHILE i < n-1 DO 				ds := 1.0/(s[i+1] - s[i]); dx := (x[i+1] - x[i])*ds; p[i].a := ds*ds*(xd[i] + xd[i+1] - 2.0*dx); p[i].b := ds*(3.0*dx - 2.0*xd[i] -xd[i+1]); p[i].c := xd[i]; p[i].d := x[i]; p[i].t := s[i]; dy := ds*(y[i+1] - y[i]); q[i].a := ds*ds*(yd[i] + yd[i+1] - 2.0*dy); q[i].b := ds*(3.0*dy - 2.0*yd[i] - yd[i+1]); q[i].c := yd[i]; q[i].d := y[i]; q[i].t := s[i]; INC(i) END ; p[i].t := s[i]; q[i].t := s[i]; (*print polynomials*) i := 0; WHILE i < n-1 DO PrintPoly(P, p[i], q[i], p[i+1].t - p[i].t); INC(i) END END END Spline; PROCEDURE Page*(P: Printer.Printer; nofcopies: INTEGER); VAR x, y: LONGINT; BEGIN WITH P: PSPrinter DO 			ResetColor; CASE P.mode OF 				oneup, rotated: IF ~P.eps THEN Int(bodyR, nofcopies); Str(bodyR, " p"); Ln(bodyR) END; curFont := -1; INC(P.pno); ppos := Files.Pos(bodyR); Str(bodyR, "%%Page: 0 "); Int(bodyR, P.pno); Ln(bodyR); |twoup: x := 2336 * 3048 DIV P.Unit; CASE P.location OF 						| 0: Int(bodyR, x); Str(bodyR, " 0 translate"); Ln(bodyR) | 1: Int(bodyR, -x); Str(bodyR, " 0 translate"); Ln(bodyR); Int(bodyR, nofcopies); Str(bodyR, " p"); Ln(bodyR); curFont := -1; INC(P.pno); ppos := Files.Pos(bodyR); Str(bodyR, "%%Page: 0 "); Int(bodyR, P.pno); Ln(bodyR) END; (* CASE *) P.location := 1-P.location |fourup: x := 2336 * 3048 DIV P.Unit; y := 3520 * 3048 DIV P.Unit; CASE P.location OF 						| 0: Int(bodyR, x); Str(bodyR, " 0 translate"); Ln(bodyR) | 1: Int(bodyR, -x); Ch(bodyR, " ");  Int(bodyR, -y);  Str(bodyR, " translate"); Ln(bodyR) | 2: Int(bodyR, x); Str(bodyR, " 0 translate"); Ln(bodyR) | 3: Int(bodyR, -x); Ch(bodyR, " ");  Int(bodyR, y);  Str(bodyR, " translate"); Ln(bodyR); Int(bodyR, nofcopies); Str(bodyR, " p"); Ln(bodyR); curFont := -1; INC(P.pno); ppos := Files.Pos(bodyR); Str(bodyR, "%%Page: 0 "); Int(bodyR, P.pno); Ln(bodyR) END; (* CASE *) P.location := (P.location+1) MOD 4 END (* CASE *) END END Page; PROCEDURE Close*(P: Printer.Printer); CONST bufSize = 4*1024; VAR dpi: LONGINT; i: INTEGER; printR, srcR: Files.Rider; buffer: ARRAY bufSize OF CHAR; S: Texts.Scanner; R: Texts.Reader; ch: CHAR; fontDef: FontDef; alias: ARRAY 64 OF CHAR; BEGIN WITH P: PSPrinter DO 			dpi := 914400 DIV Printer.current.Unit; IF (P.mode # oneup) & (P.location # 0) THEN Int(bodyR, 1); Str(bodyR, " p"); Ln(bodyR); curFont := -1; INC(P.pno); ppos := Files.Pos(bodyR) END; Files.Set(bodyR, bodyF, ppos);	(*overwrite last %%Page line*) Str(bodyR, "%%Trailer        "); Ln(bodyR); Str(bodyR, "restore"); Ln(bodyR);	(* page save *) Str(bodyR, "restore"); Ln(bodyR);	(* header file save *) Files.Set(printR, P.printF, 0); IF P.eps & (P.l <= P.r) & (P.b <= P.t) THEN Str(printR, "%!PS-Adobe-1.0"); Ln(printR); Str(printR, "%%BoundingBox: "); Int(printR, 0); Ch(printR, " "); Int(printR, 0); Ch(printR, " "); Int(printR, (P.r - P.l + 1)* 72 DIV (914400 DIV P.Unit)); Ch(printR, " "); Int(printR, (P.t - P.b + 1) * 72 DIV (914400 DIV P.Unit)); Ch(printR, " "); Ln(printR); Str(printR, "%%Creator: ETH Oberon"); Ln(printR); Str(printR, "%%EndComments"); Ln(printR); END; Texts.OpenReader(R, headerT, 0); Texts.Read(R, ch); WHILE ~R.eot DO 				Files.Write(printR, ch); IF ch = 0DX THEN Files.Write(printR, 0AX) END; Texts.Read(R, ch) END; IF P.duplex THEN Str(printR, "statusdict /setduplexmode known {statusdict begin true setduplexmode end} if"); Ln(printR); Ln(printR) END; Str(printR, "/factor1 "); Real(printR, P.Unit/12700.0); Str(printR, " def"); Ln(printR); Str(printR, "/factor2 "); Real(printR, P.Unit/12700.0); Str(printR, " def"); Ln(printR); Ln(printR); i := 0; WHILE i <= fontIndex DO DefineFont(printR, fontTable[i], FALSE); INC(i) END; IF fontMapDictN > 0 THEN Str(printR, "/FontMapDict "); Int(printR, fontMapDictN); Str(printR, " dict def"); Ln(printR); Str(printR, "FontMapDict begin"); Ln(printR); fontDef := fontMapDict; WHILE fontDef # NIL DO 					Ch(printR, "/"); Str(printR, fontDef.name); Str(printR, " [/"); IF (fontDef.family = "Syntax") OR (fontDef.family = "Oberon") OR (fontDef.family = "Default") THEN Str(printR, "Helvetica"); CASE fontDef.attr OF 							"I": Str(printR, "-Oblique") |"M", "B": Str(printR, "-Bold") ELSE END; Ch(printR, " "); Int(printR, fontDef.size*(4*dpi) DIV 300) (*Int(printR, (fontDef.size*11+2)*dpi DIV 100)*) ELSIF (fontDef.family = "Helvetica") OR (fontDef.family = "Courier") THEN Str(printR, fontDef.family); CASE fontDef.attr OF 							"I": Str(printR, "-Oblique") |"M", "B": Str(printR, "-Bold") ELSE END; Ch(printR, " "); Int(printR, fontDef.size*(4*dpi) DIV 300) ELSIF fontDef.family = "Times" THEN Str(printR, "Times"); CASE fontDef.attr OF 							"I": Str(printR, "-Italic") |"M", "B": Str(printR, "-Bold") ELSE Str(printR, "-Roman") END; Ch(printR, " "); Int(printR, fontDef.size*(4*dpi) DIV 300) ELSE buffer := "PSPrinter."; Strings.Append(buffer, fontDef.family); Oberon.OpenScanner (S, buffer); IF S.class IN {Texts.Name, Texts.String} THEN COPY(S.s, alias); Str(printR, alias) ELSE Str(printR, fontDef.family) END; CASE fontDef.attr OF 							"I": Str(printR, "-Italic") |"M", "B": Str(printR, "-Bold") ELSE END; Ch(printR, " "); Int(printR, fontDef.size*(4*dpi) DIV 300) END; Str(printR, "] def"); Ln(printR); fontDef := fontDef.next END; Str(printR, "end"); Ln(printR); fontMapDict := NIL; fontMapDictN := 0 END; Ln(printR); i := 0; WHILE i <= fontIndex DO DefineFont(printR, fontTable[i], TRUE); INC(i) END; Ln(printR); Str(printR, "OberonInit"); Ln(printR); Ln(printR); CASE P.mode OF 				oneup: (* skip *) |twoup: Str(printR, "90 rotate"); Ln(printR); Str(printR, "0.7071 0.7071 scale"); Ln(printR); Str(printR, "0 "); Int(printR, -3520 * 3048 DIV P.Unit); Str(printR, " translate"); Ln(printR) |fourup: Str(printR, "0.5 0.5 scale"); Ln(printR); Str(printR, "0 "); Int(printR, 3520 * 3048 DIV P.Unit); Str(printR, " translate"); Ln(printR) |rotated: Str(printR, "90 rotate"); Ln(printR); Str(printR, "0 "); Int(printR, -2489 * 3048 DIV P.Unit); Str(printR, " translate"); Ln(printR) END; Str(printR, "save"); Ln(printR); Ln(printR); Str(printR, "%%EndProlog"); Ln(printR); Str(printR, "%%Page: 0 1"); Ln(printR); Ln(printR); IF P.eps THEN Int(printR, -P.l); Ch(printR, " "); Int(printR, -P.b); Str(printR, " translate"); Ln(printR); END; Files.Set(srcR, bodyF, 0); REPEAT Files.ReadBytes(srcR, buffer, bufSize); Files.WriteBytes(printR, buffer, bufSize-srcR.res) UNTIL srcR.eof; IF ~P.anonymous THEN Printer.Spool(P.printF) END; P.res := Printer.res; Files.Set(bodyR, NIL, 0); headerT := NIL; bodyF := NIL END END Close; PROCEDURE GetMetric* (P: Printer.Printer; fnt: Fonts.Font): Fonts.Font; VAR name: ARRAY 32 OF CHAR; i: INTEGER; metric: Fonts.Font; BEGIN COPY(fnt.name, name); i := 0; WHILE (name[i] # ".") & (name[i] # 0X) DO INC(i) END; (* look for Mdx *) name[i] := "."; name[i+1] := "M"; name[i+2] := "d"; name[i+3] := CHR(30H + 914400 DIV (100 * P.Unit)); name[i+4] := "."; name[i+5] := "F"; name[i+6] := "n"; name[i+7] := "t"; name[i+8] := 0X; metric := Fonts.This(name); IF metric.type = Fonts.substitute THEN metric := NIL END; RETURN metric END GetMetric; PROCEDURE NewPrinter*: Printer.Printer; VAR P: PSPrinter; BEGIN NEW(P); P.name := "PSPrinter.Install"; P.InitMetrics := InitMetrics; P.Escape := Escape; P.Open := Open; P.Close := Close; P.Page := Page; P.ReplConst := ReplConst; P.ReplPattern := ReplPattern; P.Line := Line; P.Circle := Circle; P.Ellipse := Ellipse; P.Spline := Spline; P.Picture := Picture; P.UseListFont := UseListFont; P.String := String; P.ContString := ContString; P.UseColor := UseColor; P.GetMetric := GetMetric; RETURN P  END NewPrinter; PROCEDURE Install*; BEGIN Printer.Install(NewPrinter); END Install; PROCEDURE Init; VAR class: Objects.Name; size: LONGINT; style: SET; BEGIN ParseName(Fonts.Default.name, default, size, style, class) END Init; PROCEDURE Cleanup; BEGIN IF (Printer.current # NIL) & (Printer.current IS PSPrinter) THEN Printer.current := NIL END END Cleanup; BEGIN hexArray := "0123456789ABCDEF"; metric := NIL; Init; Modules.InstallTermHandler(Cleanup) END PSPrinter. System.Free PSPrinter ~ PSPrinter.Install EmptyPrinter.Install System.Free EamonPrinter LPRPrinter PSPrinter ~ LPRPrinter.Install

title: Oberon/ETH Oberon/2.3.7/PSPrinter.Mod


text: World Stamp Catalogue/Malaysia/1980

title: World Stamp Catalogue/Malaysia/1980


text: World Stamp Catalogue/Malaysia/1991

title: World Stamp Catalogue/Malaysia/1991