Host/Mod/PackedFiles.odc

MODULE HostPackedFiles; (* SP410 *)
(**
	project	= "BlackBox"
	organization	= "www.oberon.ch"
	contributors	= "Oberon microsystems"
	version	= "System/Rsrc/About"
	copyright	= "System/Rsrc/About"
	license	= "Docu/BB-License"
	changes	= "
	- 20111211, Fyodor Tkachov, switched from National to i21sysCharacters
	- 20080215, Fyodor Tkachov, reviewed
	- 20050626, Fyodor Tkachov, russification edited
	- 20050430, Ivan Goryachev, russification
	- YYYYMMDD, nn, ...
	"
	issues	= "
	- ...
	"

**)

	(* This module depends on the implementation of DevPacker. *)

	IMPORT SYSTEM, Files, HostFiles (*, Dialog*), i21sysCharacters;

	CONST
		packTag* = 12681268H;
		version = 1; (* same as in DevPacker *)

	TYPE
		Directory = POINTER TO RECORD (Files.Directory) END;
		PackedDirectory = POINTER TO RECORD (Files.Directory) END;
		FileList = POINTER TO RECORD
			path, name: Files.Name;
			adr, len: INTEGER;
			year, month, day, hour, minute, second: INTEGER;
			next: FileList
		END;
		Locator = POINTER TO RECORD
			name: Files.Name;
			files: FileList;
			sublocs: Locator;
			next: Locator
		END;
		File = POINTER TO RECORD (Files.File)
			l: FileList;
			f: Files.File
		END;
		Reader = POINTER TO RECORD (Files.Reader)
			r: Files.Reader;
			base: File
		END;

	VAR
		orgdir: Files.Directory;
		stdDir-, packedDir-: Files.Directory;
		roots: Locator;
		exefile: Files.File;
		curloc: HostFiles.Locator;

	(* Auxiliary procedures *)

	PROCEDURE DebugPrint(IN str: ARRAY OF CHAR);
	BEGIN
		(*
		Dialog.ShowMsg(str)
		*)
	END DebugPrint;

	PROCEDURE ReadInt (r: Files.Reader; OUT x: INTEGER);
		VAR b: ARRAY 4 OF BYTE;
	BEGIN
		r.ReadBytes(b, 0, 4);
		x := b[0] MOD 256 + 256 * (b[1] MOD 256 + 256 * (b[2] MOD 256 + 256 * (b[3] MOD 256)))
	END ReadInt;

	PROCEDURE ReadChar (r: Files.Reader; OUT x: CHAR);
		VAR b: ARRAY 2 OF BYTE;
	BEGIN
		r.ReadBytes(b, 0, 2);
		x := SYSTEM.VAL(CHAR, b)
	END ReadChar;

	PROCEDURE ReadString (r: Files.Reader; OUT x: ARRAY OF CHAR);
		VAR i: INTEGER; ch: CHAR;
	BEGIN
		i := 0; REPEAT ReadChar(r, ch); x[i] := ch; INC(i) UNTIL ch = 0X
	END ReadString;

	PROCEDURE Diff (VAR a, b: ARRAY OF CHAR; caseSens: BOOLEAN): INTEGER;
		VAR i: INTEGER; cha, chb: CHAR;
	BEGIN
		i := 0;
		REPEAT
			cha := a[i]; chb := b[i]; INC(i);
			IF cha # chb THEN
				IF ~caseSens THEN
					cha := i21sysCharacters.Cap(cha);
					chb := i21sysCharacters.Cap(chb);
				END;
				IF cha = "\" THEN cha := "/" END;
				IF chb = "\" THEN chb := "/" END;
				IF cha # chb THEN RETURN ORD(cha) - ORD(chb) END
			END
		UNTIL cha = 0X;
		RETURN 0
	END Diff;

	PROCEDURE GetType(name: Files.Name; OUT type: Files.Type);
		VAR l, i: INTEGER;
	BEGIN
		l := LEN(name$); type := "";
		WHILE (l > 0) & (name[l - 1] # '.') DO DEC(l) END;
		FOR i := 0 TO LEN(name$) - l DO type[i] := name[l + i] END
	END GetType;

	PROCEDURE GetNextSubLoc (path: Files.Name; beg: INTEGER; OUT res: Files.Name; OUT end: INTEGER);
		VAR i: INTEGER;
	BEGIN
		i := 0; res := "";
		WHILE (beg < LEN(path$)) & (path[beg] # '/') & (path[beg] # '\') & (path[beg] # ':') DO
			res[i] := path[beg];
			INC(beg); INC(i)
		END;
		res[i] := 0X; end := beg
	END GetNextSubLoc;

	PROCEDURE GetLoc(path: Files.Name; create: BOOLEAN): Locator;
		VAR end, diff: INTEGER;sp: Files.Name; loc, tl, last: Locator;
	BEGIN
		sp := "";
		IF path = '' THEN
			DebugPrint("Cannot use an empty path.");
			RETURN NIL
		ELSIF (path[0] = '/') OR (path[0] = '\') THEN (* network path *)
			IF (path[1] = '/') OR (path[1] = '\') THEN
				GetNextSubLoc(path, 2, sp, end)
			ELSE
				DebugPrint("Invalid network path.");
				RETURN NIL
			END
		ELSIF path[1] = ':' THEN (* absolute path *)
			GetNextSubLoc(path, 0, sp, end)
		ELSE
			DebugPrint("No absolute path.");
			RETURN NIL
		END;
		IF sp # "" THEN
			loc := roots; last := loc;
			IF loc # NIL THEN diff := Diff(sp, loc.name, FALSE) END;
			WHILE (loc # NIL) & (diff > 0) DO
				last := loc; loc := loc.next;
				IF loc # NIL THEN diff := Diff(sp, loc.name, FALSE) END
			END;
			IF ((loc = NIL) OR (diff # 0)) & ~create THEN RETURN NIL END;
			IF (loc = NIL) OR (diff < 0) THEN
				NEW(loc); loc.name := sp;
				IF roots = NIL THEN
					roots := loc
				ELSE
					loc.next := last.next; last.next := loc
				END
			END;
			GetNextSubLoc(path, 3, sp, end);
			WHILE sp # "" DO
				tl := loc.sublocs; last := NIL;
				IF tl # NIL THEN diff := Diff(sp, tl.name, FALSE) END;
				WHILE (tl # NIL) & (diff > 0) DO
					last := tl; tl := tl.next;
					IF tl # NIL THEN diff := Diff(sp, tl.name, FALSE) END
				END;
				IF (tl = NIL) OR (diff < 0) THEN
					IF create THEN
						NEW(tl); tl.name := sp;
						IF last = NIL THEN
							tl.next := loc.sublocs; loc.sublocs := tl
						ELSE
							tl.next := last.next; last.next := tl
						END
					ELSE
						RETURN NIL
					END
				END;
				loc := tl;
				GetNextSubLoc(path, end + 1, sp, end)
			END;
			RETURN loc
		END;
		RETURN NIL
	END GetLoc;

	PROCEDURE ReadResourceTable;
		VAR r: Files.Reader; tableadr, int, noff, i: INTEGER; str: Files.Name; l: FileList; loc: Locator;
	BEGIN
		roots := NIL; r := exefile.NewReader(NIL);
		r.SetPos(exefile.Length() - 12);
		ReadInt(r, int);
		IF int = packTag THEN
			ReadInt(r, int);
			IF int = version THEN
				ReadInt(r, tableadr);
				r.SetPos(tableadr); ReadInt(r, noff);
				NEW(roots);
				FOR i := 0 TO noff - 1 DO
					(* Files are packed in reversed alphabetical order,
						so adding files at the beginning of the list renders an alphabetically sorted list. *)
					NEW(l);
					ReadString(r, str); l.path := str; ReadString(r, str); l.name := str;
					ReadInt(r, int); l.adr := int; ReadInt(r, int); l.len := int;
					ReadInt(r, int); l.year := int; ReadInt(r, int); l.month := int; ReadInt(r, int); l.day := int;
					ReadInt(r, int); l.hour := int; ReadInt(r, int); l.minute := int; ReadInt(r, int); l.second := int;
					loc := GetLoc(curloc.path + '/' + l.path, TRUE);
					l.next := loc.files; loc.files := l
				END
			END
		END
	END ReadResourceTable;

	PROCEDURE Get (path: HostFiles.FullName; name: Files.Name): Files.File;
		VAR
			l: FileList; f: File; loc: Locator;
			type: Files.Type;
			diff: INTEGER;
	BEGIN
		loc := GetLoc(path$, FALSE);
		IF loc # NIL THEN l := loc.files ELSE RETURN NIL END;
		IF l # NIL THEN diff := Diff(l.name, name, FALSE) END;
		WHILE (l # NIL) & (diff < 0) DO
			l := l.next;
			IF l # NIL THEN diff := Diff(l.name, name, FALSE) END
		END;
		IF (l # NIL) & (diff = 0) THEN
			NEW(f); f.l := l; f.f := exefile;
			GetType(name, type); f.InitType(type);
			RETURN f
		END;
		RETURN NIL
	END Get;

	(* Files.Directory *)

	PROCEDURE (d: Directory) Delete (loc: Files.Locator; name: Files.Name);
	BEGIN
		orgdir.Delete(loc, name)
	END Delete;

	PROCEDURE (d: Directory) FileList (floc: Files.Locator): Files.FileInfo;
		VAR pi, fi, tfi, nfi, last: Files.FileInfo; diff: INTEGER; caseSens: BOOLEAN;
	BEGIN
		ASSERT(floc IS HostFiles.Locator, 20);
		fi := orgdir.FileList(floc); (* Gives an alphabetically sorted list of files. *)
		pi := packedDir.FileList(floc); (* Gives an alphabetically sorted list of files. *)
		nfi := NIL; last := NIL; tfi := NIL;
		(* Both fi and l are alphabetically sorted. And the returned list also has to be alphabetically sorted. *)
		caseSens := floc(HostFiles.Locator).caseSens;
		WHILE (pi # NIL) & (fi # NIL) DO
			diff := Diff(pi.name, fi.name, caseSens);
			IF diff >= 0 THEN
				tfi := fi;
				fi := fi.next;
				IF diff = 0 THEN pi := pi.next END
			ELSE
				tfi := pi;
				pi := pi.next
			END;
			IF nfi = NIL THEN nfi := tfi ELSE last.next := tfi END;
			last := tfi
		END;
		IF pi # NIL THEN
			IF nfi = NIL THEN nfi := pi ELSE last.next := pi END
		ELSIF fi # NIL THEN
			IF nfi = NIL THEN nfi := fi ELSE last.next := fi END
		END;
		RETURN nfi
	END FileList;

	PROCEDURE (d: Directory) GetFileName (name: Files.Name; type: Files.Type; OUT filename: Files.Name);
	BEGIN
		orgdir.GetFileName(name, type, filename)
	END GetFileName;

	PROCEDURE (d: Directory) LocList (floc: Files.Locator): Files.LocInfo;
		VAR pi, li, nli, last: Files.LocInfo; diff: INTEGER; caseSens: BOOLEAN;
	BEGIN
		li := orgdir.LocList(floc);
		pi := packedDir.LocList(floc);
		caseSens := floc(HostFiles.Locator).caseSens;
		nli := NIL;
		(* Both pi and li are alphabetically ordered. *)
		WHILE (pi # NIL) & (li # NIL) DO
			diff := Diff(pi.name, li.name, caseSens);
			IF diff >= 0 THEN
				IF nli = NIL THEN nli := li ELSE last.next := li END; last := li;
				li := li.next;
				IF diff = 0 THEN pi := pi.next END
			ELSE
				IF nli = NIL THEN nli := pi ELSE last.next := pi END; last := pi;
				pi := pi.next
			END
		END;
		IF pi = NIL THEN
			IF nli = NIL THEN nli := li ELSE last.next := li END
		ELSE
			IF nli = NIL THEN nli := pi ELSE last.next := pi END
		END;
		RETURN nli
	END LocList;

	PROCEDURE (d: Directory) New (loc: Files.Locator; ask: BOOLEAN): Files.File;
	BEGIN
		RETURN orgdir.New(loc, ask)
	END New;

	PROCEDURE (d: Directory) Old (loc: Files.Locator; name: Files.Name; shared: BOOLEAN): Files.File;
		VAR f: Files.File;
	BEGIN
		f := orgdir.Old(loc, name, shared);
		IF f = NIL THEN f := packedDir.Old(loc, name, shared) END;
		RETURN f
	END Old;

	PROCEDURE (d: Directory) Rename (loc: Files.Locator; old, new: Files.Name; ask: BOOLEAN);
	BEGIN
		orgdir.Rename(loc, old, new, ask)
	END Rename;

	PROCEDURE (d: Directory) SameFile (
		loc0: Files.Locator; name0: Files.Name; loc1: Files.Locator; name1: Files.Name
	): BOOLEAN;
	BEGIN
		RETURN orgdir.SameFile(loc0, name0, loc1, name1)
	END SameFile;

	PROCEDURE (d: Directory) Temp (): Files.File;
	BEGIN
		RETURN orgdir.Temp()
	END Temp;

	PROCEDURE (d: Directory) This (IN path: ARRAY OF CHAR): Files.Locator;
	BEGIN
		RETURN orgdir.This(path)
	END This;

	(* PackedDirectory *)

	PROCEDURE (d: PackedDirectory) Delete (loc: Files.Locator; name: Files.Name);
	BEGIN
		loc.res := 4 (* write-protection *)
	END Delete;

	PROCEDURE (d: PackedDirectory) FileList (floc: Files.Locator): Files.FileInfo;
		VAR nfi, tfi, last: Files.FileInfo; loc: Locator; l: FileList; type: Files.Type; hloc: HostFiles.Locator;
	BEGIN
		ASSERT(floc IS HostFiles.Locator, 20);
		hloc := floc(HostFiles.Locator);
		loc := GetLoc(hloc.path$, FALSE);
		nfi := NIL;
		IF loc # NIL THEN
			l := loc.files; last := NIL; tfi := NIL;
			(* l is alphabetically sorted. And the returned list also has to be alphabetically sorted. *)
			WHILE l # NIL DO
				GetType(l.name, type);
				NEW(tfi); tfi.name := l.name; tfi.type := type; tfi.attr := {Files.readOnly};
				tfi.modified.year := l.year; tfi.modified.month := l.month; tfi.modified.day := l.day;
				tfi.modified.hour := l.hour; tfi.modified.minute := l.minute; tfi.modified.second := l.second;
				IF nfi = NIL THEN nfi := tfi ELSE last.next := tfi END;
				last := tfi;
				l := l.next
			END
		END;
		RETURN nfi
	END FileList;

	PROCEDURE (d: PackedDirectory) GetFileName (name: Files.Name; type: Files.Type; OUT filename: Files.Name);
	BEGIN
		orgdir.GetFileName(name, type, filename)
	END GetFileName;

	PROCEDURE (d: PackedDirectory) LocList (floc: Files.Locator): Files.LocInfo;
		VAR nli, tli, last: Files.LocInfo; loc: Locator; hloc: HostFiles.Locator;
	BEGIN
		hloc := floc(HostFiles.Locator); nli := NIL;
		loc := GetLoc(hloc.path$, FALSE);
		IF loc # NIL THEN loc := loc.sublocs END;
		(* loc is alphabetically ordered. *)
		WHILE loc # NIL DO
			NEW(tli); tli.name := loc.name; tli.attr := {Files.readOnly};
			IF nli = NIL THEN nli := tli ELSE last.next := tli END;
			last := tli;
			loc := loc.next
		END;
		RETURN nli
	END LocList;

	PROCEDURE (d: PackedDirectory) New (loc: Files.Locator; ask: BOOLEAN): Files.File;
	BEGIN
		loc.res := 4; (* write-protection *)
		RETURN NIL
	END New;

	PROCEDURE (d: PackedDirectory) Old (loc: Files.Locator; name: Files.Name; shared: BOOLEAN): Files.File;
		VAR f: Files.File;
	BEGIN
		f := NIL;
		IF shared THEN
			WITH loc: HostFiles.Locator DO
				f := Get(loc.path, name)
			ELSE
				DebugPrint("HostPackedFiles: Directory.Old - This operation requires HostFiles. ")
			END
		END;
		RETURN f
	END Old;

	PROCEDURE (d: PackedDirectory) Rename (loc: Files.Locator; old, new: Files.Name; ask: BOOLEAN);
	BEGIN
		loc.res := 4 (* write-protection *)
	END Rename;

	PROCEDURE (d: PackedDirectory) SameFile (loc0: Files.Locator; name0: Files.Name; loc1: Files.Locator; name1: Files.Name): BOOLEAN;
	BEGIN
		RETURN orgdir.SameFile(loc0, name0, loc1, name1)
	END SameFile;

	PROCEDURE (d: PackedDirectory) Temp (): Files.File;
	BEGIN
		RETURN orgdir.Temp()
	END Temp;

	PROCEDURE (d: PackedDirectory) This (IN path: ARRAY OF CHAR): Files.Locator;
	BEGIN
		RETURN orgdir.This(path)
	END This;

	(* Files.Reader *)

	PROCEDURE (r: Reader) Base (): File;
	BEGIN
		RETURN r.base
	END Base;

	PROCEDURE (r: Reader) Pos (): INTEGER;
	BEGIN
		RETURN r.r.Pos() - r.base.l.adr
	END Pos;

	PROCEDURE (r: Reader) SetPos (pos: INTEGER);
	BEGIN
		ASSERT(pos <= r.base.l.len, 20);
		r.r.SetPos(pos + r.base.l.adr);
		r.eof := FALSE
	END SetPos;

	PROCEDURE (r: Reader) ReadByte (OUT x: BYTE);
	BEGIN
		IF (r.r.Pos() - r.base.l.adr) >= r.base.l.len THEN
			r.eof := TRUE; x := 0
		ELSE
			r.r.ReadByte(x)
		END
	END ReadByte;

	PROCEDURE (r: Reader) ReadBytes (VAR x: ARRAY OF BYTE; beg, len: INTEGER);
	BEGIN
		ASSERT(beg >= 0, 20); ASSERT(len >= 0, 21);
		ASSERT(beg + len <= LEN(x), 22);
		len := MIN(r.base.l.len, len);
		r.r.ReadBytes(x, beg, len);
		IF (r.r.Pos() - r.base.l.adr) >= r.base.l.len THEN r.eof := TRUE END
	END ReadBytes;

	(* Files.File *)

	PROCEDURE (f: File) Close;
	BEGIN
		(* Do nothing since all packed files are opened on the exe file which should stay open. *)
	END Close;

	PROCEDURE (f: File) Flush;
	BEGIN
		(* Do nothing since all packed files are read only. *)
	END Flush;

	PROCEDURE (f: File) Length(): INTEGER;
	BEGIN
		RETURN f.l.len
	END Length;

	PROCEDURE (f: File) NewReader(old: Files.Reader): Files.Reader;
		VAR r: Reader; hr: Files.Reader;
	BEGIN
		ASSERT(f.f # NIL, 20); ASSERT(f.l # NIL, 21);
		hr := f.f.NewReader(old);
		IF hr = NIL THEN RETURN NIL END;
		hr.SetPos(f.l.adr);
		NEW(r); r.base := f; r.r := hr; r.eof := FALSE;
		RETURN r
	END NewReader;

	PROCEDURE (f: File) NewWriter(old: Files.Writer): Files.Writer;
	BEGIN
		(* Return NIL since all packed files are read only. *)
		RETURN NIL
	END NewWriter;

	PROCEDURE (f: File) Register (name: Files.Name; type: Files.Type; ask: BOOLEAN; OUT res: INTEGER);
	BEGIN
		HALT(20)
		(* Do nothing since all packed files are opened using Old and only files opened using New can be registered. *)
	END Register;

	(* Inititlization and uninitialization *)

	PROCEDURE SetFilesDir*;
	BEGIN
		orgdir := Files.dir;
		IF orgdir # NIL THEN
			IF roots # NIL THEN
				curloc := Files.dir.This("")(HostFiles.Locator);
				Files.SetDir(stdDir)
			END
		ELSE
		END
	END SetFilesDir;

	PROCEDURE RestoreFilesDir*;
	BEGIN
		IF orgdir # NIL THEN Files.SetDir(orgdir) END
	END RestoreFilesDir;

	PROCEDURE IsInstalled*;
	BEGIN
		IF Files.dir IS Directory THEN
			DebugPrint("HostPackedFiles is installed")
		ELSE
			DebugPrint("HostPackedFiles is NOT installed")
		END
	END IsInstalled;

	PROCEDURE GetModDate* (f: Files.File; VAR year, month, day, hour, minute, second: INTEGER);
	BEGIN
		ASSERT(f IS File);
		WITH f: File DO
			year := f.l.year; month := f.l.month; day := f.l.day;
			hour := f.l.hour; minute := f.l.minute; second := f.l.second
		END
	END GetModDate;

	PROCEDURE Init;
		VAR loc: Files.Locator; appName: Files.Name; pDir: PackedDirectory; sDir: Directory;
	BEGIN
		loc := Files.dir.This(""); Files.dir.GetFileName(HostFiles.appName$, "EXE", appName);
		exefile := Files.dir.Old(loc, appName, Files.shared);
		IF exefile # NIL THEN
			curloc := loc(HostFiles.Locator);
			ReadResourceTable;
			NEW(pDir); packedDir := pDir; NEW(sDir); stdDir := sDir;
			SetFilesDir
		ELSE
			DebugPrint("HostPackedFiles: Could not open " + appName)
		END
	END Init;

BEGIN
	Init
CLOSE
	RestoreFilesDir;
	IF exefile # NIL THEN exefile.Close END
END HostPackedFiles.

 HostPackedFiles.SetFilesDir
 HostPackedFiles.RestoreFilesDir
 HostPackedFiles.PackStat
 HostPackedFiles.IsInstalled