Oberon/ETH Oberon/2.3.7/FTPDocs.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 FTPDocs; (** portable *)	(* ejz, 05.01.03 20:13:25, some tips by bh & pm *) IMPORT Files, Objects, Fonts, Display, NetSystem, Strings, HyperDocs, NetTools, Input, Texts, Display3, Oberon, Links, Gadgets, Attributes, TextGadgets, Documents, TextDocs, Desktops, Streams, MIME; (** This module implements an API-interface and a interactive interface to FTP (RFC 959). 		The FTPDocs-modul supports ftp urls. The following line should be added to the LinkSchemes section of the Registry: 			ftp = FTPDocs.NewLinkScheme 		And the following line to the Documents section: 			ftp = FTPDocs.NewDoc 		To ensure that anonymous ftp works correctly your e-mail address should be defined in the NetSystem section of 		the Registry. e.g.: EMail = "me@home" 		To access FTP within a firewall, add the proxy to the NetSystem section of the Registry: 			FTPProxy = host [ ":" port ] . *) CONST DefConPort* = 21; FixedFont = "Courier10.Scn.Fnt"; (** res codes *) Done* = NetTools.Done; NotReady* = 1; NotConnected* = 2; WrongUser* = 3; WrongPassword* = 4; TimedOut* = 5; LocFileNotFound* = 6; Interrupted* = 7; Disconnected* = 8; Failed* = NetTools.Failed; (* systems *) Unknown = -1; UNIX = 0; VMS = 1; TempFile = "Temp.FTP"; Menu = "HyperDocs.Back[Back] FTPDocs.DeleteDocFile[Del] FTPDocs.GetDocFile[Get] FTPDocs.PutDocFile[Put] TextDocs.Search[Search]"; SysMenu = "HyperDocs.Back[Back] FTPDocs.GetDocFile[Get] FTPDocs.PutDocFile[Put]"; MinDataPort = 1100; MaxDataPort = 1500; TYPE (** The connection to an ftp server is controlled by a session handle. *) Session* = POINTER TO SessionDesc; SessionDesc* = RECORD (NetTools.SessionDesc) dataC: NetSystem.Connection; log: Texts.Text; curDir: ARRAY NetTools.PathStrLen OF CHAR; system, dataPort: INTEGER; dataIP: NetSystem.IPAdr; portIPAddress: ARRAY 64 OF CHAR; usr, passw, host: ARRAY NetTools.ServerStrLen OF CHAR; port: INTEGER; ack, bin: BOOLEAN END; EnumProc* = PROCEDURE (entry: ARRAY OF CHAR); Frame = POINTER TO FrameDesc; FrameDesc = RECORD (TextGadgets.FrameDesc) S: Session END; VAR system: INTEGER; W, dirW: Texts.Writer; line, link: ARRAY NetTools.MaxLine OF CHAR; cacheS, curS: Session; curF: Frame; message: BOOLEAN; proxyHost: ARRAY NetTools.ServerStrLen OF CHAR; proxyPort, dataPort: INTEGER; proxy: BOOLEAN; PROCEDURE ReadResponse(S: Session; VAR sline: ARRAY OF CHAR); VAR time, i, j, cpos: LONGINT; code: ARRAY 8 OF CHAR; line: ARRAY NetTools.MaxLine OF CHAR; BEGIN IF ~NetTools.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 S.log # NIL THEN Texts.WriteString(W, line); Texts.WriteLn(W); Texts.Append(S.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 S.log # NIL THEN Texts.WriteString(W, line); Texts.WriteLn(W); Texts.Append(S.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) >= NetTools.TimeOut THEN S.res := TimedOut; RETURN ELSIF NetTools.UserBreak THEN S.res := Interrupted; RETURN END END END; S.ack := TRUE END ReadResponse; PROCEDURE SendLine(C: NetSystem.Connection; VAR str: ARRAY OF CHAR); BEGIN NetTools.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; (** Close connection for session S. 	res: allways = Done *) PROCEDURE Close*(S: Session); BEGIN S.ack := TRUE; SendCmd(S, "QUIT"); ReadResponse(S, S.reply); NetTools.Disconnect(S.dataC); NetTools.Disconnect(S.C); S.res := Done END Close; PROCEDURE Close2(S: Session); BEGIN S.ack := TRUE; SendCmd(S, "QUIT"); NetTools.Disconnect(S.dataC); NetTools.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 GetLogin(VAR host, usr, passw: ARRAY OF CHAR); BEGIN IF (usr = "ftp") OR (usr = "anonymous") OR (usr = "") THEN IF ~NetTools.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; (** Open a new ftp session S to server using USER=user and PASS=passwd. 	If user is either ftp or anonymous, passwd defaults to the e-mail address set in the 	Registry (NetSystem.EMail). 	port gives the Telnet-port of the FTP server, most FTP servers use FTPDocs.DefConPort. 	If log # NIL all responses from the server will be appended to log. NetSystem.hostIP 	must be set correctly. 	res: 		Done: all ok 		WrongPassword: the password given is incorrect 		WrongUser: the given user is not allowed to use this server 		NotReady: the server is busy, retry later 		NotConnected: server not found 		Failed: NetSystem.hostIP not set *) PROCEDURE Open*(server, user, passwd: ARRAY OF CHAR; port: INTEGER; log: Texts.Text; VAR S: Session); BEGIN NEW(S); S.dataC := NIL; COPY(server, S.host); S.port := port; 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.log := log; S.ack := TRUE; IF (S.usr = "") OR (S.passw = "") THEN S.res := Failed; S.reply := "no password or username specified"; RETURN END; IF NetTools.Connect(S.C, port, server, FALSE) 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"); S.bin := TRUE; ReadResponse(S, line); IF S.status # 200 THEN (* should not happen *) END; QuerySystem(S); S.res := Done END END Open; (** Change the current directory. 		res: 			Done: all ok 			Failed: directory not changed *) PROCEDURE ChangeDir*(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 ChangeDir; 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 NetTools.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 NetTools.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) > NetTools.TimeOut) OR NetTools.UserBreak; IF NetSystem.Requested(S.dataC) THEN NetSystem.Accept(S.dataC, C1, S.res); NetTools.Disconnect(S.dataC); IF S.res = NetSystem.done THEN S.res := Done; RETURN C1 				ELSE S.res := Failed END ELSIF (Input.Time-time) > NetTools.TimeOut THEN S.res := TimedOut ELSE S.res := Interrupted END; NetTools.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; (** Retrieve a list of the current directory and call enum for each entry in the list. 		res: 			Done: all ok 			TimeOut: server did not answer in time 			Failed: see S.reply(Line) *) 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 NetTools.Connected(C, NetSystem.in)) & ~NetTools.UserBreak DO 						IF len > 0 THEN NetSystem.ReadString(C, line); enum(line) END; len := NetSystem.Available(C) END END; NetTools.Disconnect(C);	(* before ReadResponse *) ReadResponse(S, S.reply) ELSE S.res := Failed END END; IF C # NIL THEN NetTools.Disconnect(C) END; IF S.dataC # NIL THEN NetTools.Disconnect(S.dataC) END END EnumDir; PROCEDURE ScanLen(VAR reply: ARRAY OF CHAR; VAR len: LONGINT); VAR i, d: INTEGER; last: BOOLEAN; BEGIN last := FALSE; d := -1; i := 0; WHILE reply[i] # 0X DO 			IF Strings.IsDigit(reply[i]) THEN IF ~last THEN d := i; last := TRUE END ELSE last := FALSE END; INC(i) END; IF d > 0 THEN Strings.StrToIntPos(reply, len, d) 		ELSE len := 0 END END ScanLen; 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 ScanLen(S.reply, NetTools.curLen); NetTools.curPos := 0; NetTools.ReadData(C, R, MAX(LONGINT)) END; NetTools.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 NetTools.Disconnect(C) END; IF S.dataC # NIL THEN NetTools.Disconnect(S.dataC) END END GetF; (** Retrieve the file remName from the server and store it as local file locName. 		res: 			Done: all ok 			TimeOut: server did not answer in time 			Failed: file not found or no permission, see S.reply(Line) *) PROCEDURE GetFile*(S: Session; remName, locName: ARRAY OF CHAR); VAR F: Files.File; R: Files.Rider; BEGIN S.bin := TRUE; F := Files.New(locName); Files.Set(R, F, 0); GetF(S, remName, R); Files.Register(F) END GetFile; (** Retrieve the text file remName from the server and write it to writer W. 		The text is converted from iso-8859-1 to the Oberon-code. 		res: 			Done: all ok 			TimeOut: server did not answer in time 			Failed: file not found or no permission, see S.reply(Line) *) PROCEDURE GetText*(S: Session; remName: ARRAY OF CHAR; VAR W: Texts.Writer); VAR C: NetSystem.Connection; in: Streams.Stream; BEGIN S.reply := ""; C := NIL; SendCmd(S, "TYPE A"); S.bin := FALSE; 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 ScanLen(S.reply, NetTools.curLen); NetTools.curPos := 0; in := NetTools.OpenStream(C); MIME.textCont.len := MAX(LONGINT); MIME.ReadText(in, W, MIME.textCont, FALSE) END; NetTools.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 NetTools.Disconnect(C) END; IF S.dataC # NIL THEN NetTools.Disconnect(S.dataC) END; SendCmd(S, "TYPE I"); ReadResponse(S, line) END GetText; (** Store the local file locName as remName on the server. 		res: 			Done: all ok 			TimeOut: server did not answer in time 			Failed: no permission or bad file name 			LocFileNotFound: could not open the local file *) PROCEDURE PutFile*(S: Session; remName, locName: ARRAY OF CHAR); VAR C: NetSystem.Connection; F: Files.File; R: Files.Rider; BEGIN S.reply := ""; S.bin := TRUE; 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 NetTools.curLen := Files.Length(F); NetTools.curPos := 0; Files.Set(R, F, 0); NetTools.WriteData(C, R) 					END; NetTools.Disconnect(C); 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 NetTools.Disconnect(C) END; IF S.dataC # NIL THEN NetTools.Disconnect(S.dataC) END END PutFile; (** Store text as remName on the server. 		The text is converted to iso-8859-1. All none ascii content is ignored (colors, fonts, objects, ...). 		res: 			Done: all ok 			TimeOut: server did not answer in time 			Failed: no permission or bad file name *) PROCEDURE PutText*(S: Session; remName: ARRAY OF CHAR; text: Texts.Text); VAR C: NetSystem.Connection; out: Streams.Stream; BEGIN S.reply := ""; C := NIL; SendCmd(S, "TYPE A"); S.bin := FALSE; 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 NetTools.curLen := text.len; NetTools.curPos := 0; out := NetTools.OpenStream(C); MIME.textCont.len := MAX(LONGINT); MIME.WriteText(text, 0, text.len, out, MIME.textCont, FALSE, FALSE) END; NetTools.Disconnect(C); ReadResponse(S, S.reply) ELSE S.res := Failed END END; IF C # NIL THEN NetTools.Disconnect(C) END; IF S.dataC # NIL THEN NetTools.Disconnect(S.dataC) END; SendCmd(S, "TYPE I"); ReadResponse(S, line) END PutText; (** Delete the file remName from the server. 		res: 			Done: all ok 			Failed: file not found or no permission, see S.reply(Line) *) 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; (** Query the current dir (path). 		res: 			Done: all ok 			Failed: see S.reply(Line) *) 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; (** Create a new directory. 		res: 			Done: all ok 			Failed: see S.reply(Line) *) PROCEDURE MakeDir*(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 MakeDir; (** Remove an existing directory. 		res: 			Done: all ok 			Failed: see S.reply(Line) *) PROCEDURE RmDir*(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 RmDir; PROCEDURE *DocHandler(D: Objects.Object; VAR M: Objects.ObjMsg); BEGIN WITH D: Documents.Document DO 			IF M IS Objects.AttrMsg THEN WITH M: Objects.AttrMsg DO 					IF (M.id = Objects.get) & (M.name = "Gen") THEN M.class := Objects.String; M.s := "FTPDocs.NewDoc"; M.res := 0 ELSE TextDocs.DocHandler(D, M) 					END END ELSIF M IS Objects.LinkMsg THEN WITH M: Objects.LinkMsg DO 					IF M.id = Objects.get THEN IF M.name = "DeskMenu" THEN M.obj := Gadgets.CopyPublicObject("NetDocs.FTPDeskMenu", TRUE); IF M.obj = NIL THEN M.obj := Desktops.NewMenu(Menu) END; M.res := 0 ELSIF M.name = "SystemMenu" THEN M.obj := Gadgets.CopyPublicObject("NetDocs.FTPSystemMenu", TRUE); IF M.obj = NIL THEN M.obj := Desktops.NewMenu(SysMenu) END; M.res := 0 ELSIF M.name = "UserMenu" THEN M.obj := Gadgets.CopyPublicObject("NetDocs.FTPUserMenu", TRUE); IF M.obj = NIL THEN M.obj := Desktops.NewMenu(Menu) END; M.res := 0 ELSE TextDocs.DocHandler(D, M) 						END ELSE TextDocs.DocHandler(D, M) 					END END ELSE TextDocs.DocHandler(D, M) 			END END END DocHandler; (** Register a ftp URL and get a unique key for it. *) PROCEDURE RegisterFTPAdr*(host, path, user, passwd: ARRAY OF CHAR; type: CHAR; port: INTEGER): LONGINT; VAR portS: ARRAY 8 OF CHAR; key: LONGINT; BEGIN COPY("ftp:&#47;/", line); IF user # "" THEN HyperDocs.ESC(user, "@"); Strings.Append(line, user); IF passwd # "" THEN HyperDocs.ESC(passwd, "@"); Strings.AppendCh(line, ":"); Strings.Append(line, passwd) END; Strings.AppendCh(line, "@") END; Strings.Lower(host, host); Strings.Append(line, host); IF port # DefConPort THEN Strings.AppendCh(line, ":"); Strings.IntToStr(port, portS); Strings.Append(line, portS) END; IF path # "" THEN Strings.Append(line, path); IF type # 0X THEN Strings.Append(line, ";type="); Strings.AppendCh(line, type) END END; key := HyperDocs.RegisterLink(line); RETURN key END RegisterFTPAdr; (** Parsing of an ftp url. *) PROCEDURE SplitFTPAdr*(VAR url, host, path, user, passwd: ARRAY OF CHAR; VAR type: CHAR; VAR port: INTEGER): LONGINT; VAR key, i, j, l: LONGINT; iskey: BOOLEAN; PROCEDURE Blanks; BEGIN WHILE (url[i] # 0X) & (url[i] <= " ") DO 				INC(i) END END Blanks; BEGIN (* Pre: url must be a ftp url *) type := 0X; port := DefConPort; COPY("", user); COPY("", passwd); i := 0; Blanks; (* skip ftp *) WHILE (url[i] # 0X) & (url[i] # ":") DO 			INC(i) END; (* skip :&#47;/ *) IF url[i] = ":" THEN INC(i) END; Blanks; WHILE (url[i] = "/") & (url[i] # 0X) DO 			INC(i) END; Blanks; (* 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 *) iskey := (user = "") & (passwd = ""); l := LEN(host); j := 0; WHILE (url[i] # 0X) & (url[i] # ":") & (url[i] # "/") DO 			IF (url[i] > " ") & ~Strings.IsDigit(url[i]) THEN iskey := FALSE END; 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] = 0X) & iskey THEN IF host # "" THEN Strings.StrToInt(host, key); HyperDocs.RetrieveLink(key, line); key := SplitFTPAdr(line, host, path, user, passwd, type, port); RETURN key ELSE RETURN HyperDocs.UndefKey END 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; HyperDocs.UnESC(host); HyperDocs.UnESC(path); HyperDocs.UnESC(user); HyperDocs.UnESC(passwd); key := RegisterFTPAdr(host, path, user, passwd, type, port); RETURN key END SplitFTPAdr; PROCEDURE *LinkSchemeHandler(L: Objects.Object; VAR M: Objects.ObjMsg); VAR usr, passw, host: ARRAY NetTools.ServerStrLen OF CHAR; path: ARRAY NetTools.PathStrLen OF CHAR; port: INTEGER; type: CHAR; BEGIN WITH L: HyperDocs.LinkScheme DO 			IF M IS HyperDocs.RegisterLinkMsg THEN WITH M: HyperDocs.RegisterLinkMsg DO 					IF (M.base = NIL) OR (HyperDocs.CheckPrefix(M.link) >= 0) THEN M.key := SplitFTPAdr(M.link, host, path, usr, passw, type, port) ELSIF M.base.prefix = "ftp" THEN link := "ftp:&#47;/"; Strings.Append(link, M.base.host); IF M.base.port > 0 THEN Strings.AppendCh(link, ":"); Strings.IntToStr(M.base.port, path); Strings.Append(link, path) END; HyperDocs.Path(M.base, link, M.link); M.key := HyperDocs.RegisterLink(link) ELSE HyperDocs.LinkSchemeHandler(L, M) 					END; IF M.key # HyperDocs.UndefKey THEN M.res := 0 END END ELSIF M IS HyperDocs.FetchMsg THEN WITH M: HyperDocs.FetchMsg DO 					IF M.key # HyperDocs.UndefKey THEN HyperDocs.RetrieveLink(M.key, line); M.key := SplitFTPAdr(line, host, path, usr, passw, type, port); (*GetLogin(host, usr, passw);*) Texts.WriteString(W, "ftp:&#47;/"); Texts.WriteString(W, host); Texts.WriteString(W, path); Texts.Append(Oberon.Log, W.buf); IF (cacheS # NIL) & ((cacheS.host # host) OR (cacheS.port # port) OR (cacheS.usr # usr) OR (cacheS.passw # passw)) THEN Close(cacheS); cacheS := NIL END; IF cacheS = NIL THEN Open(host, usr, passw, port, NIL, cacheS) END; IF cacheS.res = Done THEN GetF(cacheS, path, M.R); IF cacheS.res # Done THEN Texts.WriteString(W, cacheS.reply) ELSE Texts.WriteString(W, " done"); M.res := 0 END ELSE Texts.WriteString(W, cacheS.reply) END; Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) ELSE IF cacheS # NIL THEN Close(cacheS); cacheS := NIL; END; M.res := 0 END END ELSIF M IS Objects.AttrMsg THEN WITH M: Objects.AttrMsg DO 					IF (M.id = Objects.get) & (M.name = "Gen") THEN M.class := Objects.String; M.s := "FTPDocs.NewLinkScheme"; M.res := 0 ELSE HyperDocs.LinkSchemeHandler(L, M) 					END END ELSE HyperDocs.LinkSchemeHandler(L, M) 			END END END LinkSchemeHandler; PROCEDURE NewLinkScheme*; VAR L: HyperDocs.LinkScheme; BEGIN NEW(L); L.handle := LinkSchemeHandler; L.usePath := TRUE; Objects.NewObj := L 	END NewLinkScheme; PROCEDURE TrimmVMS(VAR name: ARRAY OF CHAR); VAR i: INTEGER; BEGIN i := 0; WHILE (name[i] # 0X) & (name[i] # ";") DO 			INC(i) END; name[i] := 0X END TrimmVMS; PROCEDURE GetDoc(F: Frame; name: ARRAY OF CHAR; type: CHAR): Documents.Document; VAR i, j: LONGINT; D: Documents.Document; tempName: ARRAY 64 OF CHAR; T: Texts.Text; tW: Texts.Writer; obj: Objects.Object; bin: BOOLEAN; BEGIN IF type # 0X THEN bin := ~((type = "A") OR (type = "T")) ELSE obj := Gadgets.FindObj(Gadgets.context, "Ascii"); IF obj # NIL THEN Attributes.GetBool(obj, "Value", bin); bin := ~bin ELSE bin := TRUE END END; IF bin THEN Texts.WriteString(W, "FTPDocs.GetFile ") ELSE Texts.WriteString(W, "FTPDocs.GetText ") END; Texts.WriteString(W, name); Texts.Write(W, " "); Texts.Append(Oberon.Log, W.buf); j := -1; i := 0; WHILE name[i] # 0X DO IF name[i] = "." THEN j := i 			END; INC(i) END; IF ~bin THEN type := "A"; Texts.OpenWriter(tW); GetText(F.S, name, tW); NEW(T); Texts.Open(T, ""); Texts.Append(T, tW.buf) ELSE COPY(TempFile, tempName); IF j > 0 THEN i := 0; WHILE tempName[i] # 0X DO 					INC(i) END; WHILE name[j] # 0X DO 					tempName[i] := name[j]; INC(i); INC(j) END; tempName[i] := 0X; IF F.S.system = VMS THEN TrimmVMS(tempName) END END; GetFile(F.S, name, tempName) END; Texts.WriteLn(W); Texts.WriteString(W, F.S.reply); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); IF F.S.res = Done THEN IF type = "A" THEN NEW(D); TextDocs.InitDoc(D); D.W := HyperDocs.docW; D.H := HyperDocs.docH; Links.SetLink(D.dsc, "Model", T); COPY(name, D.name) ELSE D := Documents.Open(tempName) END ELSE D := NIL END; RETURN D 	END GetDoc; PROCEDURE *ShowEntry(entry: ARRAY OF CHAR); VAR link: Objects.Object; i, j, beg0, beg1, beg2, begL, key: LONGINT; name: ARRAY 64 OF CHAR; BEGIN begL := -1; IF entry = "" THEN RETURN END; IF system = UNIX THEN i := 0; beg0 := 0; beg1 := 0; beg2 := 0; WHILE entry[i] # 0X DO 				IF entry[i] <= " " THEN beg0 := beg1; beg1 := beg2; beg2 := i 				END; INC(i) END; i := 0; WHILE entry[i] # 0X DO 				IF (i >= beg2) & ((entry[0] = "d") OR (entry[0] = "-")) THEN Texts.SetColor(dirW, SHORT(HyperDocs.linkC)); IF begL < 0 THEN Texts.Append(curF.text, dirW.buf); begL := curF.text.len END ELSIF (i >= beg0) & (entry[0] = "l") THEN Texts.SetColor(dirW, SHORT(HyperDocs.linkC)); IF begL < 0 THEN Texts.Append(curF.text, dirW.buf); begL := curF.text.len END END; Texts.Write(dirW, entry[i]); INC(i) END; Texts.SetColor(dirW, SHORT(Display3.textC)); IF begL >= 0 THEN i := 0; INC(beg2); WHILE (entry[beg2] > " ") & (i < 63) DO 					name[i] := entry[beg2]; INC(i); INC(beg2) END; name[i] := 0X; IF name = ".message" THEN message := TRUE END; IF name[0] # "/" THEN COPY(curS.curDir, line); IF curS.curDir # "/" THEN Strings.AppendCh(line, "/") END; Strings.Append(line, name); IF entry[0] = "d" THEN Strings.AppendCh(line, "/") END ELSE COPY(name, line) END; key := RegisterFTPAdr(curS.host, line, "", "", 0X, curS.port); IF HyperDocs.Visited(key) THEN Texts.Append(curF.text, dirW.buf); Texts.ChangeLooks(curF.text, begL, curF.text.len, {1}, NIL, SHORT(HyperDocs.oldLinkC), 0) END; link := HyperDocs.LinkControl(key); Texts.WriteObj(dirW, link) END; Texts.WriteLn(dirW) ELSIF system = VMS THEN beg0 := 0; Strings.Search(".dir;", entry, beg0); IF beg0 < 0 THEN Strings.Search(".DIR;", entry, beg0) END; i := 0; IF beg0 > 0 THEN Texts.SetColor(dirW, SHORT(HyperDocs.linkC)); WHILE (entry[i] # 0X) & (i < beg0) DO 					Texts.Write(dirW, entry[i]); INC(i) END; Texts.SetColor(dirW, SHORT(Display3.textC)); beg1 := i; entry[beg1] := 0X; COPY(curS.curDir, line); line[0] := "/"; i := 0; WHILE (line[i] # 0X) & (line[i] # "]") DO 					INC(i) END; line[i] := 0X; Strings.AppendCh(line, "."); Strings.Append(line, entry); Strings.AppendCh(line, "]"); key := RegisterFTPAdr(curS.host, line, "", "", 0X, curS.port); link := HyperDocs.LinkControl(key); Texts.WriteObj(dirW, link); entry[beg1] := "."; i := beg1 ELSE beg0 := 0; Strings.Search(";", entry, beg0); IF beg0 > 0 THEN j := 0; Texts.SetColor(dirW, SHORT(HyperDocs.linkC)); WHILE (entry[i] # 0X) & (i < beg0) & (j < 63) DO 						name[j] := entry[i]; INC(j); Texts.Write(dirW, entry[i]); INC(i) END; name[j] := 0X; beg1 := i; 					Texts.SetColor(dirW, SHORT(Display3.textC)); COPY(curS.curDir, line); line[0] := "/"; i := 0; WHILE (line[i] # 0X) & (line[i] # "]") DO 						INC(i) END; line[i] := 0X; Strings.AppendCh(line, "]"); Strings.Append(line, name); key := RegisterFTPAdr(curS.host, line, "", "", 0X, curS.port); link := HyperDocs.LinkControl(key); Texts.WriteObj(dirW, link); i := beg1 END END; WHILE entry[i] # 0X DO 				Texts.Write(dirW, entry[i]); INC(i) END; Texts.WriteLn(dirW) END; Texts.SetColor(W, SHORT(Display3.textC)) END ShowEntry; PROCEDURE HorzRule: Objects.Object; VAR obj: Objects.Object; BEGIN obj := Gadgets.CreateObject("BasicFigures.NewRect3D"); Attributes.SetBool(obj, "Filled", TRUE); Attributes.SetInt(obj, "Color", Display3.textbackC); Gadgets.ModifySize(obj(Display.Frame), Display.Width, 4); RETURN obj END HorzRule; PROCEDURE DoDir(D: Documents.Document; F: Frame); VAR f, o: Objects.Object; pos: LONGINT; msgW: Texts.Writer; U: Gadgets.UpdateMsg; h: INTEGER; oldBin: BOOLEAN; BEGIN Texts.Delete(F.text, 0, F.text.len); system := F.S.system; GetCurDir(F.S, F.S.curDir); f := Gadgets.CreateObject("TextFields.NewTextField"); Attributes.SetString(f, "Value", F.S.curDir); Attributes.SetString(f, "Cmd", "FTPDocs.ChangeDocDir '#Value '"); WITH f: Display.Frame DO 			f.W := 3*f.W; h := f.H 		END; Texts.WriteObj(dirW, f); Texts.Write(dirW, Strings.Tab); o := Gadgets.CreateObject("BasicGadgets.NewInteger"); f := Gadgets.CreateObject("BasicGadgets.NewCheckBox"); WITH f: Gadgets.Frame DO 			f.H := h; f.obj := o 		END; Gadgets.NameObj(f, "Bin"); Attributes.SetInt(f, "SetVal", 0); Attributes.SetString(f, "YesVal", "I"); Texts.WriteObj(dirW, f); Texts.WriteString(dirW, " binary"); Texts.Write(dirW, 09X); f := Gadgets.CreateObject("BasicGadgets.NewCheckBox"); WITH f: Gadgets.Frame DO 			f.H := h; f.obj := o 		END; Gadgets.NameObj(f, "Ascii"); Attributes.SetInt(f, "SetVal", 1); Attributes.SetString(f, "YesVal", "A"); Texts.WriteObj(dirW, f); Attributes.SetBool(f, "Value", ~F.S.bin); Texts.WriteString(dirW, " ascii"); Texts.WriteLn(dirW); Texts.WriteObj(dirW, HorzRule); Texts.WriteLn(dirW); Texts.Append(F.text, dirW.buf); pos := F.text.len-1; message := FALSE; curS := F.S; curF := F; 		EnumDir(F.S, ShowEntry); curS := NIL; curF := NIL; Attributes.SetInt(F, "LinkColor", HyperDocs.linkC); Attributes.SetInt(F, "OldLinkColor", HyperDocs.oldLinkC); F.do := HyperDocs.linkMethods; IF F.S.res # Done THEN Texts.WriteString(W, F.S.reply); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) ELSE D.name := "ftp:&#47;/"; Strings.Append(D.name, F.S.host); Strings.Append(D.name, F.S.curDir); Attributes.SetString(D, "DocumentName", D.name); U.obj := D; U.F := NIL; Display.Broadcast(U) END; IF message THEN Texts.OpenWriter(msgW); Texts.WriteObj(msgW, HorzRule); Texts.SetFont(msgW, Fonts.This(FixedFont)); Texts.WriteLn(msgW); oldBin := F.S.bin; GetText(F.S, ".message", msgW); F.S.bin := oldBin; Texts.Insert(F.text, pos-1, msgW.buf) END; Texts.Append(F.text, dirW.buf) END DoDir; PROCEDURE GetContext(VAR F: Frame; VAR D: Documents.Document); BEGIN D := Desktops.CurDoc(Gadgets.context); IF (D.dsc # NIL) & (D.dsc IS Frame) & (D.dsc(Frame).S # NIL) THEN F := D.dsc(Frame) ELSE F := NIL END END GetContext; PROCEDURE ScanName(context: Objects.Object; VAR name: ARRAY OF CHAR; VAR bin: BOOLEAN); VAR R: Texts.Reader; S: Texts.Scanner; obj: Objects.Object; T: Texts.Text; i, beg, end, time: LONGINT; ch: CHAR; BEGIN bin := TRUE; COPY("", name); Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S); IF (S.class = Texts.Char) & (S.c = Oberon.OptionChar) THEN Texts.Scan(S); bin := (CAP(S.s[0]) # "A") & (CAP(S.s[0]) # "T"); Texts.Scan(S) ELSE obj := Gadgets.FindObj(context, "Ascii"); IF obj # NIL THEN Attributes.GetBool(obj, "Value", bin); bin := ~bin ELSE bin := TRUE END END; IF ((S.class = Texts.Char) & (S.c = "^")) OR Desktops.IsInMenu(Gadgets.context)THEN T := NIL; time := -1; Oberon.GetSelection(T, beg, end, time); IF (time >= 0) & (T # NIL) THEN Texts.OpenReader(R, T, beg); Texts.Read(R, ch); WHILE ~R.eot & (~(R.lib IS Fonts.Font) OR (ch <= " ")) DO 					Texts.Read(R, ch) END ELSE COPY("", name); RETURN END; IF ~R.eot & (R.lib IS Fonts.Font) & (ch = 22X) THEN Texts.Read(R, ch) END; i := 0; WHILE ~R.eot & (R.lib IS Fonts.Font) & (ch > " ") & (ch # 22X) DO 				name[i] := ch; INC(i); Texts.Read(R, ch) END; name[i] := 0X ELSIF S.class IN {Texts.Name, Texts.String} THEN COPY(S.s, name) END END ScanName; (** Used by the interactive interface to retrieve the selected file and store it under the same name. *) PROCEDURE GetDocFile*; VAR D: Documents.Document; F: Frame; name: ARRAY NetTools.MaxLine OF CHAR; lname: ARRAY 128 OF CHAR; T: Texts.Text; Wr: Texts.Writer; Fi: Files.File; len: LONGINT; bin: BOOLEAN; BEGIN GetContext(F, D); IF F # NIL THEN ScanName(D.dsc, name, bin); IF name # "" THEN COPY(name, lname); IF F.S.system = VMS THEN TrimmVMS(lname) END; IF bin THEN Texts.WriteString(W, "FTPDocs.GetFile ") ELSE Texts.WriteString(W, "FTPDocs.GetText ") END; Texts.WriteString(W, name); Texts.WriteString(W, " => "); Texts.WriteString(W, lname); Texts.Write(W, " "); Texts.Append(Oberon.Log, W.buf); IF bin THEN GetFile(F.S, name, lname) ELSE NEW(T); Texts.Open(T, ""); Texts.OpenWriter(Wr); GetText(F.S, name, Wr); Texts.Append(T, Wr.buf); Fi := Files.New(lname); Texts.Store(T, Fi, 0, len); Files.Register(Fi) END; Texts.WriteString(W, F.S.reply); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) END END END GetDocFile; PROCEDURE SkipPath(VAR pname, name: ARRAY OF CHAR); VAR i, j: LONGINT; BEGIN i := 0; j := 0; WHILE (pname[i] # 0X) & (j = 0) DO 			IF (pname[i] = "=") & (pname[i+1] = ">") THEN j := i 			ELSE INC(i) END END; IF j # 0 THEN pname[j] := 0X; INC(j, 2); i := 0; WHILE pname[j] # 0X DO 				name[i] := pname[j]; INC(i); INC(j) END; name[i] := 0X ELSE i := 0; j := 0; WHILE pname[i] # 0X DO 				IF (pname[i] = "/") OR (pname[i] = "\") OR (pname[i] = ":") THEN j := 0 ELSE name[j] := pname[i]; INC(j) END; INC(i) END; name[j] := 0X END END SkipPath; (** Used by the interactive interface to send the selected file and store it under the same name. *) PROCEDURE PutDocFile*; VAR D: Documents.Document; F: Frame; name, rname: ARRAY 128 OF CHAR; T: Texts.Text; bin: BOOLEAN; BEGIN GetContext(F, D); IF F # NIL THEN ScanName(D.dsc, name, bin); IF name # "" THEN IF bin THEN Texts.WriteString(W, "FTPDocs.PutFile ") ELSE Texts.WriteString(W, "FTPDocs.PutText ") END; Texts.WriteString(W, name); Texts.Write(W, " "); Texts.Append(Oberon.Log, W.buf); SkipPath(name, rname); IF bin THEN PutFile(F.S, rname, name) ELSE NEW(T); Texts.Open(T, name); PutText(F.S, rname, T) 				END; Texts.WriteString(W, F.S.reply); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); DoDir(D, F) 			END END END PutDocFile; (** Used by the interactive interface to delete the selected file. *) PROCEDURE DeleteDocFile*; VAR D: Documents.Document; F: Frame; name: ARRAY NetTools.MaxLine OF CHAR; bin: BOOLEAN; BEGIN GetContext(F, D); IF F # NIL THEN ScanName(D.dsc, name, bin); IF name # "" THEN DeleteFile(F.S, name); Texts.WriteString(W, F.S.reply); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); DoDir(D, F) 			END END END DeleteDocFile; PROCEDURE TrimmCurDirVMS(VAR curDir: ARRAY OF CHAR); VAR i: LONGINT; BEGIN curDir[0] := "/"; i := 0; WHILE curDir[i] # 0X DO 			INC(i) END; IF i > 0 THEN curDir[i-1] := 0X END END TrimmCurDirVMS; (** Used by the interactive interface to change to directory pointed at *) PROCEDURE ChangeDocDir*; VAR F: Frame; D: Documents.Document; S: Attributes.Scanner; old, new: HyperDocs.Node; key: LONGINT; BEGIN GetContext(F, D); IF F # NIL THEN Attributes.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Attributes.Scan(S); IF S.class IN {Attributes.Name, Attributes.String} THEN ChangeDir(F.S, S.s); IF F.S.res # Done THEN Texts.WriteString(W, F.S.reply); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) ELSE old := HyperDocs.NodeByDoc(D); DoDir(D, F); IF F.S.system = VMS THEN TrimmCurDirVMS(F.S.curDir) ELSIF F.S.curDir # "/" THEN Strings.AppendCh(F.S.curDir, "/") END; key := RegisterFTPAdr(F.S.host, F.S.curDir, "", "", 0X, F.S.port); IF (old = NIL) OR (old.key # key) THEN HyperDocs.Remember(key, old, new) ELSE new := old END; HyperDocs.LinkNodeToDoc(D, new) END END END END ChangeDocDir; (** Extension of TextGadgets used by the interactive FTPDocs. *) PROCEDURE CopyFrame(VAR C: Objects.CopyMsg; from, to: Frame); BEGIN TextGadgets.CopyFrame(C, from, to); to.S := from.S 	END CopyFrame; PROCEDURE *FrameHandler(F: Objects.Object; VAR M: Objects.ObjMsg); VAR F1: Frame; BEGIN WITH F: Frame DO 			IF M IS Objects.CopyMsg THEN WITH M: Objects.CopyMsg DO 					IF M.stamp = F.stamp THEN M.obj := F.dlink ELSE NEW(F1); F.stamp := M.stamp; F.dlink := F1; CopyFrame(M, F, F1); M.obj := F1 					END END ELSE TextGadgets.FrameHandler(F, M) 			END END END FrameHandler; PROCEDURE CurrentS(VAR S: Session); BEGIN S := NIL; IF (HyperDocs.context # NIL) & (HyperDocs.context.curDoc # NIL) & (HyperDocs.context.curDoc.dsc IS Frame) THEN S := HyperDocs.context.curDoc.dsc(Frame).S 		END END CurrentS; PROCEDURE *LoadDoc(D: Documents.Document); VAR F: Frame; usr, pass, host: ARRAY NetTools.ServerStrLen OF CHAR; path, name: ARRAY NetTools.PathStrLen OF CHAR; i, j, k, key: LONGINT; D2: Documents.Document; T: Texts.Text; new: HyperDocs.Node; port: INTEGER; P: NetTools.ProxyMsg; S: HyperDocs.LinkScheme; type: CHAR; newC: BOOLEAN; BEGIN key := SplitFTPAdr(D.name, host, path, usr, pass, type, port); IF key = HyperDocs.UndefKey THEN D.dsc := NIL; RETURN END; IF proxy & NetTools.UseProxy(host) THEN GetLogin(host, usr, pass); IF (usr = "ftp") OR (usr = "anonymous") THEN usr := ""; pass := "" END; P.key := RegisterFTPAdr(host, path, usr, pass, type, port); P.res := -1; COPY(proxyHost, P.host); P.port := proxyPort; P.D := D; 			S := HyperDocs.LinkSchemeByPrefix("http"); S.handle(S, P); RETURN END; NEW(F); CurrentS(F.S); IF F.S = NIL THEN newC := TRUE; Texts.WriteString(W, host); Texts.Append(Oberon.Log, W.buf); Open(host, usr, pass, port, NIL, F.S); IF F.S.res = Done THEN Texts.WriteString(W, " connected"); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf) END ELSE newC := FALSE; F.S.res := Done END; IF F.S.res = Done THEN IF F.S.system # VMS THEN j := -1; i := 0; WHILE path[i] # 0X DO 					IF path[i] = "/" THEN j := i 					END; INC(i) END; IF j > 0 THEN k := j; path[j] := 0X; INC(j) ELSE k := -1 END; IF (j > 0) & (path # "") THEN ChangeDir(F.S, path) ELSIF j = 0 THEN ChangeDir(F.S, "/"); j := 1; k := 0 END; IF (j > 0) & (i > j) THEN IF HyperDocs.context # NIL THEN HyperDocs.context.replace := FALSE; HyperDocs.context.history := FALSE END; i := 0; WHILE path[j] # 0X DO 						name[i] := path[j]; INC(i); INC(j) END; name[i] := 0X; D2 := GetDoc(F, name, type); IF D2 # NIL THEN IF newC THEN Close(F.S) 						END; D^ := D2^ ELSE name := ""; path[k] := "/"; ChangeDir(F.S, path) END ELSE name := "" END ELSE i := 0; WHILE (path[i] # 0X) & (path[i] # "]") DO 					INC(i) END; IF path[i] = "]" THEN k := i+1; j := 0; WHILE path[k] # 0X DO 						name[j] := path[k]; INC(j); INC(k) END; name[j] := 0X; path[i+1] := 0X; i := 1; WHILE path[i] # 0X DO 						path[i-1] := path[i]; INC(i) END; path[i-1] := 0X; ChangeDir(F.S, path); IF name # "" THEN IF HyperDocs.context # NIL THEN HyperDocs.context.replace := FALSE; HyperDocs.context.history := FALSE END; D2 := GetDoc(F, name, type); IF D2 # NIL THEN IF newC THEN Close(F.S) 							END; D^ := D2^ ELSE name := "" END END ELSE name := "" END END; IF (F.S.res = Done) & (name = "") THEN TextDocs.InitDoc(D); NEW(T); Texts.Open(T, ""); TextGadgets.Init(F, T, FALSE); DoDir(D, F); IF HyperDocs.context = NIL THEN IF F.S.system = VMS THEN TrimmCurDirVMS(F.S.curDir) END; key := RegisterFTPAdr(host, F.S.curDir, "", "", 0X, port); HyperDocs.Remember(key, NIL, new); HyperDocs.LinkNodeToDoc(D, new) ELSE HyperDocs.context.replace := ~newC; HyperDocs.context.history := TRUE END; D.W := HyperDocs.docW; D.H := HyperDocs.docH; D.dsc := F; D.handle := DocHandler; F.handle := FrameHandler END; IF F.S.res = Done THEN RETURN ELSIF HyperDocs.context # NIL THEN HyperDocs.context.history := FALSE END END; Texts.WriteString(W, " - "); Texts.WriteString(W, F.S.reply); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf); F.S := NIL; D.dsc := NIL END LoadDoc; PROCEDURE NewDoc*; VAR D: Documents.Document; BEGIN NEW(D); D.Load := LoadDoc; D.Store := NIL; D.handle := DocHandler; Objects.NewObj := D 	END NewDoc; PROCEDURE Init; BEGIN dataPort := MinDataPort; NetTools.GetHostPort("FTPProxy", proxyHost, proxyPort, 80); proxy := proxyHost # ""; cacheS := NIL; curS := NIL END Init; BEGIN Texts.OpenWriter(W); Texts.OpenWriter(dirW); Texts.SetFont(dirW, Fonts.This(FixedFont)); Init END FTPDocs.