diff --git a/makefile b/makefile index 63065945..e13048a7 100644 --- a/makefile +++ b/makefile @@ -9,7 +9,7 @@ RELEASE = 1.0 INCLUDEPATH = -Isrc/lib/system/$(CCOMP)/$(TARCH) -SETPATH = CFLAGS=$(INCLUDEPATH) PATH=.:/bin:/usr/bin MODULES=.:src/lib:src/lib/v4:src/lib/system:src/lib/system/$(CCOMP):src/lib/system/$(CCOMP)/$(TARCH):src/lib/ulm:src/lib/ulm/$(CCOMP):src/lib/ulm/$(TARCH):src/lib/ooc2:src/lib/ooc2/$(CCOMP):src/lib/ooc:src/lib/ooc/$(CCOMP):src/lib/pow:src/lib/misc:src/voc:src/voc/$(CCOMP):src/voc/$(CCOMP)/$(TARCH):src/tools/ocat:src/tools/browser:src/tools/vocparam:src/tools/coco:src/test +SETPATH = CFLAGS=$(INCLUDEPATH) PATH=.:/bin:/usr/bin MODULES=.:src/lib:src/lib/v4:src/lib/system:src/lib/system/$(CCOMP):src/lib/system/$(CCOMP)/$(TARCH):src/lib/ulm:src/lib/ulm/$(CCOMP):src/lib/ulm/$(TARCH):src/lib/ooc2:src/lib/ooc2/$(CCOMP):src/lib/ooc:src/lib/ooc/$(CCOMP):src/lib/pow:src/lib/misc:src/lib/s3:src/voc:src/voc/$(CCOMP):src/voc/$(CCOMP)/$(TARCH):src/tools/ocat:src/tools/browser:src/tools/vocparam:src/tools/coco:src/test VOC = voc VOCSTATIC0 = $(SETPATH) ./vocstatic.$(TOS).$(CCOMP).$(TARCH) @@ -202,6 +202,17 @@ stage6: $(VOCSTATIC) -sP MultiArrayRiders.Mod $(VOCSTATIC) -sP MersenneTwister.Mod + #s3 libs + $(VOCSTATIC) -sP BTrees.Mod + $(VOCSTATIC) -sP MD5.Mod + $(VOCSTATIC) -sP Zlib.Mod + $(VOCSTATIC) -sP ZlibBuffers.Mod + $(VOCSTATIC) -sP ZlibInflate.Mod + $(VOCSTATIC) -sP ZlibDeflate.Mod + $(VOCSTATIC) -sP ZlibReaders.Mod + $(VOCSTATIC) -sP ZlibWriters.Mod + $(VOCSTATIC) -sP Zip.Mod + stage7: #objects := $(wildcard *.o) diff --git a/src/lib/s3/BTrees.Mod b/src/lib/s3/BTrees.Mod new file mode 100644 index 00000000..9e015f60 --- /dev/null +++ b/src/lib/s3/BTrees.Mod @@ -0,0 +1,1134 @@ +(* ETH Oberon, Copyright 2001 ETH Zuerich Institut fuer Computersysteme, ETH Zentrum, CH-8092 Zuerich. +Refer to the "General ETH Oberon System Source License" contract available at: http://www.oberon.ethz.ch/ *) + +MODULE BTrees; (** portable *) (* ejz, *) + IMPORT Files; + +(** BTrees is a utility module that manages b-trees with string (64 characters) or longint keys. Each key is linked to + a longint value (org) which normaly is an offset to where the data for that key is stored. *) + + CONST + Done* = 0; NotFound* = 1; EntryChanged* = 2; (** res codes *) + + Tag = 2425; + PageSize = 2*1024; + BoolSize = 1; + IntSize = 2; + LIntSize = 4; + + LInt = 0; + LIntKeySize = LIntSize; + LIntPageN = (PageSize-BoolSize-LIntSize-IntSize-LIntSize) DIV (2*(LIntKeySize+2*LIntSize)); + LIntPageSize = LIntSize+BoolSize+IntSize+LIntSize+2*LIntPageN*(LIntKeySize+2*LIntSize); + + Str = 1; + StrKeySize* = 64; (** The maximum length of a string key. *) + StrPageN = (PageSize-BoolSize-LIntSize-IntSize-LIntSize) DIV (2*(StrKeySize+2*LIntSize)); + StrPageSize = LIntSize+BoolSize+IntSize+LIntSize+2*StrPageN*(StrKeySize+2*LIntSize); + + TYPE + Page = POINTER TO PageDesc; + PageDesc = RECORD + org: LONGINT; (* pos of this page *) + p0: LONGINT; (* pos of left page *) + m: INTEGER; (* number of entries *) + dirty: BOOLEAN; (* page changed *) + discard: BOOLEAN; (* TRUE: page is deleted *) + next: Page (* next page in cache *) + END; + Tree* = POINTER TO TreeDesc; (** handle to a b-tree index *) + TreeDesc = RECORD + F: Files.File; (* index file *) + cache: Page; (* list of cached pages *) + org: LONGINT; (* pos of btree header *) + root: LONGINT; (* pos of root page *) + free: LONGINT; (* pos of first free page *) + class: INTEGER; (* 0: LInt, 1: Str *) + noCache: INTEGER; (* number of pages in cache *) + maxCache: INTEGER (* max. number of pages in cache *) + END; + + Entry = RECORD + org: LONGINT; (* pos of data for key *) + p: LONGINT (* pos of right page *) + END; + + LIntEntry = RECORD (Entry) + key: LONGINT + END; + LIntPage = POINTER TO LIntPageDesc; + LIntPageDesc = RECORD (PageDesc) + e: ARRAY 2*LIntPageN OF LIntEntry + END; + EnumLIntProc* = PROCEDURE (key, org: LONGINT; VAR cont: BOOLEAN); (** enumerator for longin keys *) + + StrEntry = RECORD (Entry) + key: ARRAY StrKeySize OF CHAR + END; + StrPage = POINTER TO StrPageDesc; + StrPageDesc = RECORD (PageDesc) + e: ARRAY 2*StrPageN OF StrEntry + END; + EnumStrProc* = PROCEDURE (key: ARRAY OF CHAR; org: LONGINT; VAR cont: BOOLEAN); (** enumerator for string keys *) + + VAR + MINStrKey*, MAXStrKey*: ARRAY StrKeySize OF CHAR; (** first and last string key *) + +(* Allocate space for a new page. *) + PROCEDURE AllocSpace(T: Tree; size: LONGINT): LONGINT; + VAR + R: Files.Rider; + pos: LONGINT; + BEGIN + IF T.free > T.org THEN + pos := T.free; Files.Set(R, T.F, pos); + Files.ReadLInt(R, T.free) (* next free *) + ELSE + pos := Files.Length(T.F); Files.Set(R, T.F, pos); + WHILE size > 0 DO + Files.Write(R, 0X); DEC(size) + END + END; + RETURN pos + END AllocSpace; + + PROCEDURE ToFree(T: Tree; P: Page); + VAR R: Files.Rider; + BEGIN + Files.Set(R, T.F, P.org); Files.WriteLInt(R, T.free); + Files.Set(R, T.F, T.org); + Files.WriteInt(R, Tag); Files.WriteInt(R, T.class); + Files.WriteInt(R, T.maxCache); + T.free := P.org; Files.WriteLInt(R, T.free) + END ToFree; + +(* Force write back of a page. *) + PROCEDURE WriteLIntPage(T: Tree; p: LIntPage); + VAR + R: Files.Rider; + i: LONGINT; + BEGIN + ASSERT(p.org <= Files.Length(T.F)); + Files.Set(R, T.F, p.org); + Files.WriteLInt(R, p.org); + Files.WriteInt(R, p.m); + Files.WriteBool(R, p.discard); + Files.WriteLInt(R, p.p0); + FOR i := 0 TO p.m-1 DO + Files.WriteLInt(R, p.e[i].key); + Files.WriteLInt(R, p.e[i].org); + Files.WriteLInt(R, p.e[i].p) + END; + p.dirty := FALSE + END WriteLIntPage; + +(* Allocate a new (memory) page. *) + PROCEDURE NewLIntPage(T: Tree): LIntPage; + VAR + p0, pm, pp: Page; + p: LIntPage; + BEGIN + NEW(p); INC(T.noCache); + IF T.noCache > T.maxCache THEN + pp := NIL; pm := NIL; p0 := T.cache; + WHILE p0 # NIL DO + pp := pm; pm := p0; p0 := p0.next + END; + IF pm.dirty THEN + WriteLIntPage(T, pm(LIntPage)) + END; + IF pp # NIL THEN + pp.next := pm.next + ELSE + T.cache := pm.next + END; + T.noCache := T.maxCache + END; + p.next := T.cache; T.cache := p; + p.m := 0; p.p0 := -1; p.org := -1; + p.dirty := TRUE; p.discard := FALSE; + RETURN p + END NewLIntPage; + +(* Read page at offset org. *) + PROCEDURE ReadLIntPage(T: Tree; org: LONGINT; VAR p: LIntPage); + VAR + R: Files.Rider; + p0: Page; + i: LONGINT; + BEGIN + IF org < 0 THEN + p := NIL; RETURN + END; + p0 := T.cache; + WHILE (p0 # NIL) & (p0.org # org) DO + p0 := p0.next + END; + IF p0 = NIL THEN + p := NewLIntPage(T); + Files.Set(R, T.F, org); + Files.ReadLInt(R, p.org); ASSERT(p.org = org); + Files.ReadInt(R, p.m); + Files.ReadBool(R, p.discard); ASSERT(~p.discard); + Files.ReadLInt(R, p.p0); + FOR i := 0 TO p.m-1 DO + Files.ReadLInt(R, p.e[i].key); + Files.ReadLInt(R, p.e[i].org); + Files.ReadLInt(R, p.e[i].p) + END; + p.dirty := FALSE + ELSE + p := p0(LIntPage); + IF (p.next = NIL) & (p # T.cache) THEN + p0 := T.cache; + WHILE p0.next # p DO + p0 := p0.next + END; + p0.next := NIL; + p.next := T.cache; T.cache := p + END + END + END ReadLIntPage; + +(** Search for key in T. If the key could be found res = Done else res = NotFound. *) + PROCEDURE SearchLInt*(T: Tree; key: LONGINT; VAR org: LONGINT; VAR res: INTEGER); + VAR + i, L, R: LONGINT; + a: LIntPage; + BEGIN + ASSERT(T.class = LInt); + ReadLIntPage(T, T.root, a); + LOOP + L := 0; R := a.m; + WHILE L < R DO + i := (L+R) DIV 2; + IF key <= a.e[i].key THEN + R := i + ELSE + L := i+1 + END + END; + IF (R < a.m) & (a.e[R].key = key) THEN + res := Done; org := a.e[R].org; + RETURN + END; + IF R = 0 THEN + ReadLIntPage(T, a.p0, a) + ELSE + ReadLIntPage(T, a.e[R-1].p, a) + END; + IF a = NIL THEN + res := NotFound; org := -1; + RETURN + END + END + END SearchLInt; + + PROCEDURE insertLInt(T: Tree; key, org: LONGINT; a: LIntPage; VAR h: BOOLEAN; VAR v: LIntEntry; VAR res: INTEGER); + VAR + i, L, R: LONGINT; + b: LIntPage; + u: LIntEntry; + BEGIN + L := 0; R := a.m; + WHILE L < R DO + i := (L+R) DIV 2; + IF key <= a.e[i].key THEN + R := i + ELSE + L := i+1 + END + END; + IF (R < a.m) & (a.e[R].key = key) THEN + res := EntryChanged; + a.dirty := TRUE; a.e[R].org := org + ELSE + IF R = 0 THEN + ReadLIntPage(T, a.p0, b) + ELSE + ReadLIntPage(T, a.e[R-1].p, b) + END; + IF b = NIL THEN + res := Done; + u.p := -1; h := TRUE; + u.key := key; u.org := org + ELSE + insertLInt(T, key, org, b, h, u, res) + END; + IF h THEN + ReadLIntPage(T, a.org, a); (* ensure a is still cached *) + a.dirty := TRUE; + IF a.m < 2*LIntPageN THEN + h := FALSE; i := a.m; + WHILE i > R DO + DEC(i); a.e[i+1] := a.e[i] + END; + a.e[R] := u; INC(a.m) + ELSE + b := NewLIntPage(T); + b.dirty := TRUE; b.org := AllocSpace(T, LIntPageSize); + IF R < LIntPageN THEN + i := LIntPageN-1; v := a.e[i]; + WHILE i > R DO + DEC(i); a.e[i+1] := a.e[i] + END; + a.e[R] := u; + i := 0; + WHILE i < LIntPageN DO + b.e[i] := a.e[i+LIntPageN]; INC(i) + END + ELSE + DEC(R, LIntPageN); + i := 0; + IF R = 0 THEN + v := u + ELSE + v := a.e[LIntPageN]; + WHILE i < R-1 DO + b.e[i] := a.e[i+LIntPageN+1]; INC(i) + END; + b.e[i] := u; INC(i) + END; + WHILE i < LIntPageN DO + b.e[i] := a.e[i+LIntPageN]; INC(i) + END + END; + a.m := LIntPageN; b.m := LIntPageN; + b.p0 := v.p; v.p := b.org + END + END + END + END insertLInt; + +(** Insert a new key into T. If a new key was inserted, res = Done else res = EntryChanged. *) + PROCEDURE InsertLInt*(T: Tree; key, org: LONGINT; VAR res: INTEGER); + VAR + u: LIntEntry; + r, q: LIntPage; + h: BOOLEAN; + BEGIN + ASSERT(T.class = LInt); + h := FALSE; u.p := -1; + ReadLIntPage(T, T.root, r); + insertLInt(T, key, org, r, h, u, res); + IF h THEN + ReadLIntPage(T, T.root, q); + q.dirty := TRUE; q.org := AllocSpace(T, LIntPageSize); + r := NewLIntPage(T); + r.m := 1; r.dirty := TRUE; + r.org := T.root; r.p0 := q.org; + r.e[0] := u + END + END InsertLInt; + + PROCEDURE underflowLInt(T: Tree; c, a: LIntPage; s: LONGINT; VAR h: BOOLEAN); + VAR + b: LIntPage; + i, k: LONGINT; + BEGIN + IF s < c.m THEN + ReadLIntPage(T, c.e[s].p, b); k := (b.m-LIntPageN+1) DIV 2; + ReadLIntPage(T, a.org, a); (* ensure a is still cached *) + ReadLIntPage(T, c.org, c); (* ensure c is still cached *) + a.dirty := TRUE; c.dirty := TRUE; + a.e[LIntPageN-1] := c.e[s]; a.e[LIntPageN-1].p := b.p0; + IF k > 0 THEN + i := 0; + WHILE i < k-1 DO + a.e[i+LIntPageN] := b.e[i]; INC(i) + END; + c.e[s] := b.e[k-1]; b.p0 := c.e[s].p; + c.e[s].p := b.org; b.m := b.m-SHORT(k); + b.dirty := TRUE; i := 0; + WHILE i < b.m DO + b.e[i] := b.e[i+k]; INC(i) + END; + a.m := LIntPageN-1+SHORT(k); h := FALSE + ELSE + i := 0; + WHILE i < LIntPageN DO + a.e[i+LIntPageN] := b.e[i]; INC(i) + END; + i := s; DEC(c.m); + WHILE i < c.m DO + c.e[i] := c.e[i+1]; INC(i) + END; + a.m := 2*LIntPageN; h := c.m < LIntPageN + END + ELSE + DEC(s); + IF s = 0 THEN + ReadLIntPage(T, c.p0, b) + ELSE + ReadLIntPage(T, c.e[s-1].p, b) + END; + ReadLIntPage(T, a.org, a); (* ensure a is still cached *) + ReadLIntPage(T, c.org, c); (* ensure c is still cached *) + k := (b.m-LIntPageN+1) DIV 2; b.dirty := TRUE; + IF k > 0 THEN + a.dirty := TRUE; c.dirty := TRUE; + i := LIntPageN-1; + WHILE i > 0 DO + DEC(i); a.e[i+k] := a.e[i] + END; + i := k-1; a.e[i] := c.e[s]; a.e[i].p := a.p0; + b.m := b.m-SHORT(k); + WHILE i > 0 DO + DEC(i); a.e[i] := b.e[i+b.m+1] + END; + c.e[s] := b.e[b.m]; a.p0 := c.e[s].p; + c.e[s].p := a.org; a.m := LIntPageN-1+SHORT(k); h := FALSE + ELSE + c.dirty := TRUE; + c.e[s].p := a.p0; b.e[LIntPageN] := c.e[s]; i := 0; + WHILE i < LIntPageN-1 DO + b.e[i+LIntPageN+1] := a.e[i]; INC(i) + END; + b.m := 2*LIntPageN; DEC(c.m); h := c.m < LIntPageN + END + END + END underflowLInt; + + PROCEDURE deleteLInt(T: Tree; key: LONGINT; a: LIntPage; VAR h: BOOLEAN; VAR res: INTEGER); + VAR + i, L, R: LONGINT; + q: LIntPage; + PROCEDURE del(p: LIntPage; VAR h: BOOLEAN); + VAR + k: LONGINT; + q: LIntPage; + BEGIN + k := p.m-1; ReadLIntPage(T, p.e[k].p, q); + IF q # NIL THEN + del(q, h); + IF h THEN underflowLInt(T, p, q, p.m, h) END + ELSE + p.dirty := TRUE; a.dirty := TRUE; + p.e[k].p := a.e[R].p; a.e[R] := p.e[k]; + DEC(p.m); h := p.m < LIntPageN + END + END del; + BEGIN + L := 0; R := a.m; + WHILE L < R DO + i := (L+R) DIV 2; + IF key <= a.e[i].key THEN + R := i + ELSE + L := i+1 + END + END ; + IF R = 0 THEN + ReadLIntPage(T, a.p0, q) + ELSE + ReadLIntPage(T, a.e[R-1].p, q) + END; + IF (R < a.m) & (a.e[R].key = key) THEN + res := Done; + IF q = NIL THEN + a.dirty := TRUE; + DEC(a.m); h := a.m < LIntPageN; i := R; + WHILE i < a.m DO + a.e[i] := a.e[i+1]; INC(i) + END + ELSE + del(q, h); + IF h THEN underflowLInt(T, a, q, R, h) END + END + ELSIF q # NIL THEN + deleteLInt(T, key, q, h, res); + IF h THEN underflowLInt(T, a, q, R, h) END + END + END deleteLInt; + +(** Delete key from T. If key was deleted res = Done else res = NotFound. *) + PROCEDURE DeleteLInt*(T: Tree; key: LONGINT; VAR res: INTEGER); + VAR + p: Page; + r, r0: LIntPage; + h: BOOLEAN; + BEGIN + ASSERT(T.class = LInt); res := NotFound; + ReadLIntPage(T, T.root, r); + deleteLInt(T, key, r, h, res); + IF (res = Done) & h THEN + ReadLIntPage(T, T.root, r); + IF r.m = 0 THEN + IF r.p0 >= 0 THEN + p := T.cache; + WHILE p # NIL DO + IF p.dirty THEN + WriteLIntPage(T, p(LIntPage)) + END; + p := p.next + END; + ReadLIntPage(T, r.p0, r0); + r.org := r0.org; r.dirty := TRUE; r.discard := TRUE; r.next := NIL; + WriteLIntPage(T, r); ToFree(T, r); + r0.org := T.root; r0.dirty := TRUE; r0.next := NIL; + T.cache := r0; T.noCache := 1 + END + END + END + END DeleteLInt; + + PROCEDURE enumerateLInt(T: Tree; p: LIntPage; min, max: LONGINT; enum: EnumLIntProc; VAR cont: BOOLEAN); + VAR + key, lkey, i: LONGINT; + q: LIntPage; + BEGIN + IF p # NIL THEN + lkey := MIN(LONGINT); i := 0; + WHILE (i < p.m) & (lkey < max) DO + key := p.e[i].key; + IF key >= min THEN + IF key > min THEN + IF i = 0 THEN + ReadLIntPage(T, p.p0, q) + ELSE + ReadLIntPage(T, p.e[i-1].p, q) + END; + enumerateLInt(T, q, min, max, enum, cont) + END; + IF cont & (key <= max) THEN + enum(key, p.e[i].org, cont) + END + END; + lkey := key; INC(i) + END; + IF cont & (lkey < max) THEN + ReadLIntPage(T, p.e[p.m-1].p, q); + enumerateLInt(T, q, min, max, enum, cont) + END + END + END enumerateLInt; + +(** Enumerate all keys in T witch range from min upto max (key >= min) & (key <= max). *) + PROCEDURE EnumLInt*(T: Tree; min, max: LONGINT; enum: EnumLIntProc); + VAR + r: LIntPage; + cont: BOOLEAN; + BEGIN + ASSERT(T.class = LInt); + ReadLIntPage(T, T.root, r); + IF r.m > 0 THEN + cont := TRUE; + enumerateLInt(T, r, min, max, enum, cont) + END + END EnumLInt; + + PROCEDURE minLIntKey(T: Tree; p: LIntPage; VAR key: LONGINT); + BEGIN + IF p # NIL THEN + key := p.e[0].key; + ReadLIntPage(T, p.p0, p); + minLIntKey(T, p, key) + END + END minLIntKey; + +(** Searches the smallest key used in T. *) + PROCEDURE MinLIntKey*(T: Tree; VAR key: LONGINT; VAR res: INTEGER); + VAR r: LIntPage; + BEGIN + ASSERT(T.class = LInt); + ReadLIntPage(T, T.root, r); + IF r.m > 0 THEN + minLIntKey(T, r, key); res := Done + ELSE + key := MAX(LONGINT); res := NotFound + END + END MinLIntKey; + + PROCEDURE maxLIntKey(T: Tree; p: LIntPage; VAR key: LONGINT); + BEGIN + IF (p # NIL) & (p.m > 0) THEN + key := p.e[p.m-1].key; + ReadLIntPage(T, p.e[p.m-1].p, p); + maxLIntKey(T, p, key) + END + END maxLIntKey; + +(** Searches the biggest key used in T. *) + PROCEDURE MaxLIntKey*(T: Tree; VAR key: LONGINT; VAR res: INTEGER); + VAR r: LIntPage; + BEGIN + ASSERT(T.class = LInt); + ReadLIntPage(T, T.root, r); + IF r.m > 0 THEN + maxLIntKey(T, r, key); res := Done + ELSE + key := MIN(LONGINT); res := NotFound + END + END MaxLIntKey; + +(** Create a new b-tree with longint keys. The tree is written to F starting at org. + cache gives the minumum number of keys which should fit into the page cache. *) + PROCEDURE NewLInt*(F: Files.File; org: LONGINT; cache: INTEGER): Tree; + VAR + T: Tree; + R: Files.Rider; + BEGIN + NEW(T); + T.maxCache := (cache+2*LIntPageN-1) DIV (2*LIntPageN); + IF T.maxCache < 4 THEN + T.maxCache := 4 + END; + T.F := F; T.org := org; + Files.Set(R, F, org); + Files.WriteInt(R, Tag); Files.WriteInt(R, LInt); + Files.WriteInt(R, T.maxCache); + T.free := -1; Files.WriteLInt(R, T.free); + T.root := AllocSpace(T, LIntPageSize); + T.class := LInt; T.noCache := 0; + T.cache := NewLIntPage(T); + T.cache.dirty := TRUE; + T.cache.org := T.root; + RETURN T + END NewLInt; + +(* Force write back of a page. *) + PROCEDURE WriteStrPage(T: Tree; p: StrPage); + VAR + R: Files.Rider; + i: LONGINT; + BEGIN + ASSERT(p.org <= Files.Length(T.F)); + Files.Set(R, T.F, p.org); + Files.WriteLInt(R, p.org); + Files.WriteInt(R, p.m); + Files.WriteBool(R, p.discard); + Files.WriteLInt(R, p.p0); + FOR i := 0 TO p.m-1 DO + Files.WriteBytes(R, p.e[i].key, StrKeySize); + Files.WriteLInt(R, p.e[i].org); + Files.WriteLInt(R, p.e[i].p) + END; + p.dirty := FALSE + END WriteStrPage; + +(* Allocate a new (memory) page. *) + PROCEDURE NewStrPage(T: Tree): StrPage; + VAR + p0, pm, pp: Page; + p: StrPage; + BEGIN + NEW(p); INC(T.noCache); + IF T.noCache > T.maxCache THEN + pp := NIL; pm := NIL; p0 := T.cache; + WHILE p0 # NIL DO + pp := pm; pm := p0; p0 := p0.next + END; + IF pm.dirty THEN + WriteStrPage(T, pm(StrPage)) + END; + IF pp # NIL THEN + pp.next := pm.next + ELSE + T.cache := pm.next + END; + T.noCache := T.maxCache + END; + p.next := T.cache; T.cache := p; + p.m := 0; p.p0 := -1; p.org := -1; + p.dirty := TRUE; p.discard := FALSE; + RETURN p + END NewStrPage; + +(* Read page at offset org. *) + PROCEDURE ReadStrPage(T: Tree; org: LONGINT; VAR p: StrPage); + VAR + R: Files.Rider; + p0: Page; + i: LONGINT; + BEGIN + IF org < 0 THEN + p := NIL; RETURN + END; + p0 := T.cache; + WHILE (p0 # NIL) & (p0.org # org) DO + p0 := p0.next + END; + IF p0 = NIL THEN + p := NewStrPage(T); + Files.Set(R, T.F, org); + Files.ReadLInt(R, p.org); ASSERT(p.org = org); + Files.ReadInt(R, p.m); + Files.ReadBool(R, p.discard); ASSERT(~p.discard); + Files.ReadLInt(R, p.p0); + FOR i := 0 TO p.m-1 DO + Files.ReadBytes(R, p.e[i].key, StrKeySize); + Files.ReadLInt(R, p.e[i].org); + Files.ReadLInt(R, p.e[i].p) + END; + p.dirty := FALSE + ELSE + p := p0(StrPage); + IF (p.next = NIL) & (p # T.cache) THEN + p0 := T.cache; + WHILE p0.next # p DO + p0 := p0.next + END; + p0.next := NIL; + p.next := T.cache; T.cache := p + END + END + END ReadStrPage; + +(** Search for key in T. If the key could be found res = Done else res = NotFound. *) + PROCEDURE SearchStr*(T: Tree; key: ARRAY OF CHAR; VAR org: LONGINT; VAR res: INTEGER); + VAR + i, L, R: LONGINT; + a: StrPage; + sKey: ARRAY StrKeySize OF CHAR; + BEGIN + ASSERT(T.class = Str); COPY(key, sKey); + ReadStrPage(T, T.root, a); + LOOP + L := 0; R := a.m; + WHILE L < R DO + i := (L+R) DIV 2; + IF sKey <= a.e[i].key THEN + R := i + ELSE + L := i+1 + END + END; + IF (R < a.m) & (a.e[R].key = sKey) THEN + res := Done; org := a.e[R].org; + RETURN + END; + IF R = 0 THEN + ReadStrPage(T, a.p0, a) + ELSE + ReadStrPage(T, a.e[R-1].p, a) + END; + IF a = NIL THEN + res := NotFound; org := -1; + RETURN + END + END + END SearchStr; + + PROCEDURE insertStr(T: Tree; VAR key: ARRAY OF CHAR; org: LONGINT; a: StrPage; VAR h: BOOLEAN; VAR v: StrEntry; VAR res: INTEGER); + VAR + i, L, R: LONGINT; + b: StrPage; + u: StrEntry; + BEGIN + L := 0; R := a.m; + WHILE L < R DO + i := (L+R) DIV 2; + IF key <= a.e[i].key THEN + R := i + ELSE + L := i+1 + END + END; + IF (R < a.m) & (a.e[R].key = key) THEN + res := EntryChanged; + a.dirty := TRUE; a.e[R].org := org + ELSE + IF R = 0 THEN + ReadStrPage(T, a.p0, b) + ELSE + ReadStrPage(T, a.e[R-1].p, b) + END; + IF b = NIL THEN + res := Done; + u.p := -1; h := TRUE; + COPY(key, u.key); u.org := org + ELSE + insertStr(T, key, org, b, h, u, res) + END; + IF h THEN + ReadStrPage(T, a.org, a); (* ensure a is still cached *) + a.dirty := TRUE; + IF a.m < 2*StrPageN THEN + h := FALSE; i := a.m; + WHILE i > R DO + DEC(i); a.e[i+1] := a.e[i] + END; + a.e[R] := u; INC(a.m) + ELSE + b := NewStrPage(T); + b.dirty := TRUE; b.org := AllocSpace(T, StrPageSize); + IF R < StrPageN THEN + i := StrPageN-1; v := a.e[i]; + WHILE i > R DO + DEC(i); a.e[i+1] := a.e[i] + END; + a.e[R] := u; + i := 0; + WHILE i < StrPageN DO + b.e[i] := a.e[i+StrPageN]; INC(i) + END + ELSE + DEC(R, StrPageN); + i := 0; + IF R = 0 THEN + v := u + ELSE + v := a.e[StrPageN]; + WHILE i < R-1 DO + b.e[i] := a.e[i+StrPageN+1]; INC(i) + END; + b.e[i] := u; INC(i) + END; + WHILE i < StrPageN DO + b.e[i] := a.e[i+StrPageN]; INC(i) + END + END; + a.m := StrPageN; b.m := StrPageN; + b.p0 := v.p; v.p := b.org + END + END + END + END insertStr; + +(** Insert a new key into T. If a new key was inserted, res = Done else res = EntryChanged. *) + PROCEDURE InsertStr*(T: Tree; key: ARRAY OF CHAR; org: LONGINT; VAR res: INTEGER); + VAR + u: StrEntry; + r, q: StrPage; + h: BOOLEAN; + sKey: ARRAY StrKeySize OF CHAR; + BEGIN + ASSERT(T.class = Str); COPY(key, sKey); + h := FALSE; u.p := -1; + ReadStrPage(T, T.root, r); + insertStr(T, sKey, org, r, h, u, res); + IF h THEN + ReadStrPage(T, T.root, q); + q.dirty := TRUE; q.org := AllocSpace(T, StrPageSize); + r := NewStrPage(T); + r.m := 1; r.dirty := TRUE; + r.org := T.root; r.p0 := q.org; + r.e[0] := u + END + END InsertStr; + + PROCEDURE underflowStr(T: Tree; c, a: StrPage; s: LONGINT; VAR h: BOOLEAN); + VAR + b: StrPage; + i, k: LONGINT; + BEGIN + IF s < c.m THEN + ReadStrPage(T, c.e[s].p, b); k := (b.m-StrPageN+1) DIV 2; + ReadStrPage(T, a.org, a); (* ensure a is still cached *) + ReadStrPage(T, c.org, c); (* ensure c is still cached *) + a.dirty := TRUE; c.dirty := TRUE; + a.e[StrPageN-1] := c.e[s]; a.e[StrPageN-1].p := b.p0; + IF k > 0 THEN + i := 0; + WHILE i < k-1 DO + a.e[i+StrPageN] := b.e[i]; INC(i) + END; + c.e[s] := b.e[k-1]; b.p0 := c.e[s].p; + c.e[s].p := b.org; b.m := b.m-SHORT(k); + b.dirty := TRUE; i := 0; + WHILE i < b.m DO + b.e[i] := b.e[i+k]; INC(i) + END; + a.m := StrPageN-1+SHORT(k); h := FALSE + ELSE + i := 0; + WHILE i < StrPageN DO + a.e[i+StrPageN] := b.e[i]; INC(i) + END; + i := s; DEC(c.m); + WHILE i < c.m DO + c.e[i] := c.e[i+1]; INC(i) + END; + a.m := 2*StrPageN; h := c.m < StrPageN + END + ELSE + DEC(s); + IF s = 0 THEN + ReadStrPage(T, c.p0, b) + ELSE + ReadStrPage(T, c.e[s-1].p, b) + END; + ReadStrPage(T, a.org, a); (* ensure a is still cached *) + ReadStrPage(T, c.org, c); (* ensure c is still cached *) + k := (b.m-StrPageN+1) DIV 2; b.dirty := TRUE; + IF k > 0 THEN + a.dirty := TRUE; c.dirty := TRUE; + i := StrPageN-1; + WHILE i > 0 DO + DEC(i); a.e[i+k] := a.e[i] + END; + i := k-1; a.e[i] := c.e[s]; a.e[i].p := a.p0; + b.m := b.m-SHORT(k); + WHILE i > 0 DO + DEC(i); a.e[i] := b.e[i+b.m+1] + END; + c.e[s] := b.e[b.m]; a.p0 := c.e[s].p; + c.e[s].p := a.org; a.m := StrPageN-1+SHORT(k); h := FALSE + ELSE + c.dirty := TRUE; + c.e[s].p := a.p0; b.e[StrPageN] := c.e[s]; i := 0; + WHILE i < StrPageN-1 DO + b.e[i+StrPageN+1] := a.e[i]; INC(i) + END; + b.m := 2*StrPageN; DEC(c.m); h := c.m < StrPageN + END + END + END underflowStr; + + PROCEDURE deleteStr(T: Tree; VAR key: ARRAY OF CHAR; a: StrPage; VAR h: BOOLEAN; VAR res: INTEGER); + VAR + i, L, R: LONGINT; + q: StrPage; + PROCEDURE del(p: StrPage; VAR h: BOOLEAN); + VAR + k: LONGINT; + q: StrPage; + BEGIN + k := p.m-1; ReadStrPage(T, p.e[k].p, q); + IF q # NIL THEN + del(q, h); + IF h THEN underflowStr(T, p, q, p.m, h) END + ELSE + p.dirty := TRUE; a.dirty := TRUE; + p.e[k].p := a.e[R].p; a.e[R] := p.e[k]; + DEC(p.m); h := p.m < StrPageN + END + END del; + BEGIN + L := 0; R := a.m; + WHILE L < R DO + i := (L+R) DIV 2; + IF key <= a.e[i].key THEN + R := i + ELSE + L := i+1 + END + END ; + IF R = 0 THEN + ReadStrPage(T, a.p0, q) + ELSE + ReadStrPage(T, a.e[R-1].p, q) + END; + IF (R < a.m) & (a.e[R].key = key) THEN + res := Done; + IF q = NIL THEN + a.dirty := TRUE; + DEC(a.m); h := a.m < StrPageN; i := R; + WHILE i < a.m DO + a.e[i] := a.e[i+1]; INC(i) + END + ELSE + del(q, h); + IF h THEN underflowStr(T, a, q, R, h) END + END + ELSIF q # NIL THEN + deleteStr(T, key, q, h, res); + IF h THEN underflowStr(T, a, q, R, h) END + END + END deleteStr; + +(** Delete key from T. If key was deleted res = Done else res = NotFound. *) + PROCEDURE DeleteStr*(T: Tree; key: ARRAY OF CHAR; VAR res: INTEGER); + VAR + p: Page; + r, r0: StrPage; + sKey: ARRAY StrKeySize OF CHAR; + h: BOOLEAN; + BEGIN + ASSERT(T.class = Str); COPY(key, sKey); res := NotFound; + ReadStrPage(T, T.root, r); + deleteStr(T, sKey, r, h, res); + IF (res = Done) & h THEN + ReadStrPage(T, T.root, r); + IF r.m = 0 THEN + IF r.p0 >= 0 THEN + p := T.cache; + WHILE p # NIL DO + IF p.dirty THEN + WriteStrPage(T, p(StrPage)) + END; + p := p.next + END; + ReadStrPage(T, r.p0, r0); + r.org := r0.org; r.dirty := TRUE; r.discard := TRUE; r.next := NIL; + WriteStrPage(T, r); ToFree(T, r); + r0.org := T.root; r0.dirty := TRUE; r0.next := NIL; + T.cache := r0; T.noCache := 1 + END + END + END + END DeleteStr; + + PROCEDURE enumerateStr(T: Tree; p: StrPage; VAR min, max: ARRAY OF CHAR; enum: EnumStrProc; VAR cont: BOOLEAN); + VAR + key, lkey: ARRAY StrKeySize OF CHAR; + q: StrPage; + i: LONGINT; + BEGIN + IF p # NIL THEN + COPY(MINStrKey, lkey); i := 0; + WHILE (i < p.m) & (lkey < max) DO + COPY(p.e[i].key, key); + IF key >= min THEN + IF key > min THEN + IF i = 0 THEN + ReadStrPage(T, p.p0, q) + ELSE + ReadStrPage(T, p.e[i-1].p, q) + END; + enumerateStr(T, q, min, max, enum, cont) + END; + IF cont & (key <= max) THEN + enum(key, p.e[i].org, cont) + END + END; + COPY(key, lkey); INC(i) + END; + IF cont & (lkey < max) THEN + ReadStrPage(T, p.e[p.m-1].p, q); + enumerateStr(T, q, min, max, enum, cont) + END + END + END enumerateStr; + +(** Enumerate all keys in T witch range from min upto max (key >= min) & (key <= max). *) + PROCEDURE EnumStr*(T: Tree; min, max: ARRAY OF CHAR; enum: EnumStrProc); + VAR + r: StrPage; + cont: BOOLEAN; + BEGIN + ASSERT(T.class = Str); + ReadStrPage(T, T.root, r); + IF r.m > 0 THEN + cont := TRUE; + enumerateStr(T, r, min, max, enum, cont) + END + END EnumStr; + + PROCEDURE minStrKey(T: Tree; p: StrPage; VAR key: ARRAY OF CHAR); + BEGIN + IF p # NIL THEN + COPY(p.e[0].key, key); + ReadStrPage(T, p.p0, p); + minStrKey(T, p, key) + END + END minStrKey; + +(** Searches the smallest key used in T. *) + PROCEDURE MinStrKey*(T: Tree; VAR key: ARRAY OF CHAR; VAR res: INTEGER); + VAR r: StrPage; + BEGIN + ASSERT(T.class = Str); + ReadStrPage(T, T.root, r); + IF r.m > 0 THEN + minStrKey(T, r, key); res := Done + ELSE + res := NotFound + END + END MinStrKey; + + PROCEDURE maxStrKey(T: Tree; p: StrPage; VAR key: ARRAY OF CHAR); + BEGIN + IF (p # NIL) & (p.m > 0) THEN + COPY(p.e[p.m-1].key, key); + ReadStrPage(T, p.e[p.m-1].p, p); + maxStrKey(T, p, key) + END + END maxStrKey; + +(** Searches the biggest key used in T. *) + PROCEDURE MaxStrKey*(T: Tree; VAR key: ARRAY OF CHAR; VAR res: INTEGER); + VAR r: StrPage; + BEGIN + ASSERT(T.class = Str); + ReadStrPage(T, T.root, r); + IF r.m > 0 THEN + maxStrKey(T, r, key); res := Done + ELSE + res := NotFound + END + END MaxStrKey; + +(** Create a new b-tree with string keys. The tree is written to F starting at org. + cache gives the minumum number of keys which should fit into the page cache. *) + PROCEDURE NewStr*(F: Files.File; org: LONGINT; cache: INTEGER): Tree; + VAR + T: Tree; + R: Files.Rider; + BEGIN + NEW(T); + T.maxCache := (cache+2*StrPageN-1) DIV (2*StrPageN); + IF T.maxCache < 4 THEN + T.maxCache := 4 + END; + T.F := F; T.org := org; + Files.Set(R, F, org); + Files.WriteInt(R, Tag); Files.WriteInt(R, Str); + Files.WriteInt(R, T.maxCache); + T.free := -1; Files.WriteLInt(R, T.free); + T.root := AllocSpace(T, StrPageSize); + T.class := Str; T.noCache := 0; + T.cache := NewStrPage(T); + T.cache.dirty := TRUE; + T.cache.org := T.root; + RETURN T + END NewStr; + +(** Reopen the b-tree written to F starting at org. *) + PROCEDURE Old*(F: Files.File; org: LONGINT): Tree; + VAR + T: Tree; + R: Files.Rider; + tag: INTEGER; + BEGIN + NEW(T); T.F := F; T.org := org; + Files.Set(R, F, org); + Files.ReadInt(R, tag); ASSERT(tag = Tag); Files.ReadInt(R, T.class); + Files.ReadInt(R, T.maxCache); Files.ReadLInt(R, T.free); + IF T.maxCache < 4 THEN T.maxCache := 4 END; + T.root := Files.Pos(R); T.noCache := 0; T.cache := NIL; + RETURN T + END Old; + +(** Flush the page-cache of T to disk. *) + PROCEDURE Flush*(T: Tree); + VAR + R: Files.Rider; + p: Page; + BEGIN + Files.Set(R, T.F, T.org); + Files.WriteInt(R, Tag); Files.WriteInt(R, T.class); + Files.WriteInt(R, T.maxCache); Files.WriteLInt(R, T.free); + p := T.cache; + WHILE p # NIL DO + IF p.dirty THEN + CASE T.class OF + LInt: WriteLIntPage(T, p(LIntPage)) + |Str: WriteStrPage(T, p(StrPage)) + END + END; + p := p.next + END; + Files.Close(T.F) + END Flush; + +(** Return the file used by T. *) + PROCEDURE Base*(T: Tree): Files.File; + BEGIN + RETURN T.F + END Base; + + PROCEDURE Init(); + VAR i: LONGINT; + BEGIN + FOR i := 0 TO StrKeySize-2 DO + MINStrKey[i] := 0X; + MAXStrKey[i] := 0FFX + END; + MINStrKey[StrKeySize-1] := 0X; + MAXStrKey[StrKeySize-1] := 0X + END Init; + +BEGIN + Init() +END BTrees. diff --git a/src/lib/s3/MD5.Mod b/src/lib/s3/MD5.Mod new file mode 100644 index 00000000..3e3290e4 --- /dev/null +++ b/src/lib/s3/MD5.Mod @@ -0,0 +1,295 @@ +(* ETH Oberon, Copyright 2001 ETH Zuerich Institut fuer Computersysteme, ETH Zentrum, CH-8092 Zuerich. +Refer to the "General ETH Oberon System Source License" contract available at: http://www.oberon.ethz.ch/ *) + +MODULE MD5; (** portable *) (* ejz *) + IMPORT SYSTEM; + +(** The MD5 Message-Digest Algorithm (RFC1321) + +The algorithm takes as input a message of arbitrary length and produces +as output a 128-bit "fingerprint" or "message digest" of the input. It is +conjectured that it is computationally infeasible to produce two messages +having the same message digest, or to produce any message having a +given prespecified target message digest. The MD5 algorithm is intended +for digital signature applications, where a large file must be "compressed" +in a secure manner before being encrypted with a private (secret) key +under a public-key cryptosystem such as RSA. *) + + TYPE + Context* = POINTER TO ContextDesc; + ContextDesc = RECORD + buf: ARRAY 4 OF LONGINT; + bits: LONGINT; + in: ARRAY 64 OF CHAR + END; + Digest* = ARRAY 16 OF CHAR; + +(** Begin an MD5 operation, with a new context. *) + PROCEDURE New*(): Context; + VAR cont: Context; + BEGIN + NEW(cont); + cont.buf[0] := 067452301H; + cont.buf[1] := 0EFCDAB89H; + cont.buf[2] := 098BADCFEH; + cont.buf[3] := 010325476H; + cont.bits := 0; + RETURN cont + END New; + + PROCEDURE ByteReverse(VAR in: ARRAY OF SYSTEM.BYTE; VAR out: ARRAY OF LONGINT; longs: LONGINT); + VAR + adr, t, i: LONGINT; + bytes: ARRAY 4 OF CHAR; + BEGIN + adr := SYSTEM.ADR(in[0]); i := 0; + WHILE i < longs DO + SYSTEM.MOVE(adr, SYSTEM.ADR(bytes[0]), 4); + t := ORD(bytes[3]); + t := 256*t + ORD(bytes[2]); + t := 256*t + ORD(bytes[1]); + t := 256*t + ORD(bytes[0]); + out[i] := t; + INC(adr, 4); INC(i) + END + END ByteReverse; + + PROCEDURE F1(x, y, z: LONGINT): LONGINT; + BEGIN + RETURN SYSTEM.VAL(LONGINT, (SYSTEM.VAL(SET, x)*SYSTEM.VAL(SET, y)) + ((-SYSTEM.VAL(SET, x))*SYSTEM.VAL(SET, z))) + END F1; + + PROCEDURE F2(x, y, z: LONGINT): LONGINT; + BEGIN + RETURN SYSTEM.VAL(LONGINT, (SYSTEM.VAL(SET, x)*SYSTEM.VAL(SET, z)) + (SYSTEM.VAL(SET, y)*(-SYSTEM.VAL(SET, z)))) + END F2; + + PROCEDURE F3(x, y, z: LONGINT): LONGINT; + BEGIN + RETURN SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET, x) / SYSTEM.VAL(SET, y) / SYSTEM.VAL(SET, z)) + END F3; + + PROCEDURE F4(x, y, z: LONGINT): LONGINT; + BEGIN + RETURN SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET, y) / (SYSTEM.VAL(SET, x)+(-SYSTEM.VAL(SET, z)))) + END F4; + + PROCEDURE STEP1(VAR w: LONGINT; x, y, z, data, s: LONGINT); + BEGIN + w := w+F1(x, y, z)+data; + w := SYSTEM.ROT(w, s); + INC(w, x) + END STEP1; + + PROCEDURE STEP2(VAR w: LONGINT; x, y, z, data, s: LONGINT); + BEGIN + w := w+F2(x, y, z)+data; + w := SYSTEM.ROT(w, s); + INC(w, x) + END STEP2; + + PROCEDURE STEP3(VAR w: LONGINT; x, y, z, data, s: LONGINT); + BEGIN + w := w+F3(x, y, z)+data; + w := SYSTEM.ROT(w, s); + INC(w, x) + END STEP3; + + PROCEDURE STEP4(VAR w: LONGINT; x, y, z, data, s: LONGINT); + BEGIN + w := w+F4(x, y, z)+data; + w := SYSTEM.ROT(w, s); + INC(w, x) + END STEP4; + + PROCEDURE Transform(VAR buf, in: ARRAY OF LONGINT); + VAR a, b, c, d: LONGINT; + BEGIN + a := buf[0]; b := buf[1]; c := buf[2]; d := buf[3]; + + STEP1(a, b, c, d, in[0]+0D76AA478H, 7); + STEP1(d, a, b, c, in[1]+0E8C7B756H, 12); + STEP1(c, d, a, b, in[2]+0242070DBH, 17); + STEP1(b, c, d, a, in[3]+0C1BDCEEEH, 22); + STEP1(a, b, c, d, in[4]+0F57C0FAFH, 7); + STEP1(d, a, b, c, in[5]+04787C62AH, 12); + STEP1(c, d, a, b, in[6]+0A8304613H, 17); + STEP1(b, c, d, a, in[7]+0FD469501H, 22); + STEP1(a, b, c, d, in[8]+0698098D8H, 7); + STEP1(d, a, b, c, in[9]+08B44F7AFH, 12); + STEP1(c, d, a, b, in[10]+0FFFF5BB1H, 17); + STEP1(b, c, d, a, in[11]+0895CD7BEH, 22); + STEP1(a, b, c, d, in[12]+06B901122H, 7); + STEP1(d, a, b, c, in[13]+0FD987193H, 12); + STEP1(c, d, a, b, in[14]+0A679438EH, 17); + STEP1(b, c, d, a, in[15]+049B40821H, 22); + + STEP2(a, b, c, d, in[1]+0F61E2562H, 5); + STEP2(d, a, b, c, in[6]+0C040B340H, 9); + STEP2(c, d, a, b, in[11]+0265E5A51H, 14); + STEP2(b, c, d, a, in[0]+0E9B6C7AAH, 20); + STEP2(a, b, c, d, in[5]+0D62F105DH, 5); + STEP2(d, a, b, c, in[10]+02441453H, 9); + STEP2(c, d, a, b, in[15]+0D8A1E681H, 14); + STEP2(b, c, d, a, in[4]+0E7D3FBC8H, 20); + STEP2(a, b, c, d, in[9]+021E1CDE6H, 5); + STEP2(d, a, b, c, in[14]+0C33707D6H, 9); + STEP2(c, d, a, b, in[3]+0F4D50D87H, 14); + STEP2(b, c, d, a, in[8]+0455A14EDH, 20); + STEP2(a, b, c, d, in[13]+0A9E3E905H, 5); + STEP2(d, a, b, c, in[2]+0FCEFA3F8H, 9); + STEP2(c, d, a, b, in[7]+0676F02D9H, 14); + STEP2(b, c, d, a, in[12]+08D2A4C8AH, 20); + + STEP3(a, b, c, d, in[5]+0FFFA3942H, 4); + STEP3(d, a, b, c, in[8]+08771F681H, 11); + STEP3(c, d, a, b, in[11]+06D9D6122H, 16); + STEP3(b, c, d, a, in[14]+0FDE5380CH, 23); + STEP3(a, b, c, d, in[1]+0A4BEEA44H, 4); + STEP3(d, a, b, c, in[4]+04BDECFA9H, 11); + STEP3(c, d, a, b, in[7]+0F6BB4B60H, 16); + STEP3(b, c, d, a, in[10]+0BEBFBC70H, 23); + STEP3(a, b, c, d, in[13]+0289B7EC6H, 4); + STEP3(d, a, b, c, in[0]+0EAA127FAH, 11); + STEP3(c, d, a, b, in[3]+0D4EF3085H, 16); + STEP3(b, c, d, a, in[6]+04881D05H, 23); + STEP3(a, b, c, d, in[9]+0D9D4D039H, 4); + STEP3(d, a, b, c, in[12]+0E6DB99E5H, 11); + STEP3(c, d, a, b, in[15]+01FA27CF8H, 16); + STEP3(b, c, d, a, in[2]+0C4AC5665H, 23); + + STEP4(a, b, c, d, in[0]+0F4292244H, 6); + STEP4(d, a, b, c, in[7]+0432AFF97H, 10); + STEP4(c, d, a, b, in[14]+0AB9423A7H, 15); + STEP4(b, c, d, a, in[5]+0FC93A039H, 21); + STEP4(a, b, c, d, in[12]+0655B59C3H, 6); + STEP4(d, a, b, c, in[3]+08F0CCC92H, 10); + STEP4(c, d, a, b, in[10]+0FFEFF47DH, 15); + STEP4(b, c, d, a, in[1]+085845DD1H, 21); + STEP4(a, b, c, d, in[8]+06FA87E4FH, 6); + STEP4(d, a, b, c, in[15]+0FE2CE6E0H, 10); + STEP4(c, d, a, b, in[6]+0A3014314H, 15); + STEP4(b, c, d, a, in[13]+04E0811A1H, 21); + STEP4(a, b, c, d, in[4]+0F7537E82H, 6); + STEP4(d, a, b, c, in[11]+ 0BD3AF235H, 10); + STEP4(c, d, a, b, in[2]+02AD7D2BBH, 15); + STEP4(b, c, d, a, in[9]+0EB86D391H, 21); + + INC(buf[0], a); INC(buf[1], b); + INC(buf[2], c); INC(buf[3], d) + END Transform; + +(** Continues an MD5 message-digest operation, processing another + message block, and updating the context. *) + PROCEDURE Write*(context: Context; ch: CHAR); + VAR + in: ARRAY 16 OF LONGINT; + t, len: LONGINT; + BEGIN + t := context.bits; len := 1; + context.bits := t + 8; + t := (t DIV 8) MOD 64; + IF t > 0 THEN + t := 64-t; + IF 1 < t THEN + context.in[64-t] := ch; + RETURN + END; + ASSERT(len = 1); + context.in[64-t] := ch; + ByteReverse(context.in, in, 16); + Transform(context.buf, in); + DEC(len, t) + END; + IF len > 0 THEN + context.in[0] := ch + END + END Write; + +(** Continues an MD5 message-digest operation, processing another + message block, and updating the context. *) + PROCEDURE WriteBytes*(context: Context; VAR buf: ARRAY OF CHAR; len: LONGINT); + VAR + in: ARRAY 16 OF LONGINT; + beg, t: LONGINT; + BEGIN + beg := 0; t := context.bits; + context.bits := t + len*8; + t := (t DIV 8) MOD 64; + IF t > 0 THEN + t := 64-t; + IF len < t THEN + SYSTEM.MOVE(SYSTEM.ADR(buf[beg]), SYSTEM.ADR(context.in[64-t]), len); + RETURN + END; + SYSTEM.MOVE(SYSTEM.ADR(buf[beg]), SYSTEM.ADR(context.in[64-t]), t); + ByteReverse(context.in, in, 16); + Transform(context.buf, in); + INC(beg, t); DEC(len, t) + END; + WHILE len >= 64 DO + SYSTEM.MOVE(SYSTEM.ADR(buf[beg]), SYSTEM.ADR(context.in[0]), 64); + ByteReverse(context.in, in, 16); + Transform(context.buf, in); + INC(beg, 64); DEC(len, 64) + END; + IF len > 0 THEN + SYSTEM.MOVE(SYSTEM.ADR(buf[beg]), SYSTEM.ADR(context.in[0]), len) + END + END WriteBytes; + +(** Ends an MD5 message-digest operation, writing the message digest. *) + PROCEDURE Close*(context: Context; VAR digest: Digest); + VAR + in: ARRAY 16 OF LONGINT; + beg, i, count: LONGINT; + BEGIN + count := (context.bits DIV 8) MOD 64; + beg := count; + context.in[beg] := CHR(128); INC(beg); + count := 64-1-count; + IF count < 8 THEN + i := 0; + WHILE i < count DO + context.in[beg+i] := 0X; INC(i) + END; + ByteReverse(context.in, in, 16); + Transform(context.buf, in); + i := 0; + WHILE i < 56 DO + context.in[i] := 0X; INC(i) + END + ELSE + i := 0; + WHILE i < (count-8) DO + context.in[beg+i] := 0X; INC(i) + END + END; + ByteReverse(context.in, in, 14); + in[14] := context.bits; in[15] := 0; + Transform(context.buf, in); + ByteReverse(context.buf, in, 4); + SYSTEM.MOVE(SYSTEM.ADR(in[0]), SYSTEM.ADR(digest[0]), 16) + END Close; + + PROCEDURE HexDigit(i: LONGINT): CHAR; + BEGIN + IF i < 10 THEN + RETURN CHR(ORD("0")+i) + ELSE + RETURN CHR(ORD("a")+i-10) + END + END HexDigit; + +(** Convert the digest into an hexadecimal string. *) + PROCEDURE ToString*(digest: Digest; VAR str: ARRAY OF CHAR); + VAR i: LONGINT; + BEGIN + FOR i := 0 TO 15 DO + str[2*i] := HexDigit(ORD(digest[i]) DIV 16); + str[2*i+1] := HexDigit(ORD(digest[i]) MOD 16) + END; + str[32] := 0X + END ToString; + +END MD5. diff --git a/src/lib/s3/Zip.Mod b/src/lib/s3/Zip.Mod new file mode 100644 index 00000000..97172a35 --- /dev/null +++ b/src/lib/s3/Zip.Mod @@ -0,0 +1,745 @@ +(* ETH Oberon, Copyright 2001 ETH Zuerich Institut fuer Computersysteme, ETH Zentrum, CH-8092 Zuerich. +Refer to the "General ETH Oberon System Source License" contract available at: http://www.oberon.ethz.ch/ *) + +MODULE Zip; (** Stefan Walthert **) + +IMPORT + Files := OakFiles, Zlib, ZlibReaders, ZlibWriters; + +CONST + + (** result codes **) + Ok* = 0; (** operation on zip-file was successful **) + FileError* = -1; (** file not found **) + NotZipArchiveError* = -2; (** file is not in zip format **) + EntryNotFound* = -3; (** specified file was not found in zip-file **) + EntryAlreadyExists* = -4; (** file is already stored in zip-file -> can not add specified file to zip-file **) + NotSupportedError* = -5; (** can not extract specified file (compression method not supported/file is encrypted) **) + DataError* = -6; (** file is corrupted **) + BadName* = -7; (** bad file name *) + ReaderError* = -8; (** e.g. Reader not opened before Read **) + + (** compression levels **) + DefaultCompression* = ZlibWriters.DefaultCompression; + NoCompression* = ZlibWriters.NoCompression; + BestSpeed* = ZlibWriters.BestSpeed; + BestCompression* = ZlibWriters.BestCompression; + + (** compression strategies **) + DefaultStrategy* = ZlibWriters.DefaultStrategy; + Filtered* = ZlibWriters.Filtered; + HuffmanOnly* = ZlibWriters.HuffmanOnly; + + (* support *) + Supported = 0; (* can extract file *) + IncompatibleVersion = 1; (* version needed to extract < PKZIP 1.00 *) + Encrypted = 2; (* file is encrypted *) + UnsupCompMethod = 3; (* file not stored or deflated *) + + Stored = 0; (* file is stored (no compression) *) + Deflated = 8; (* file is deflated *) + + SupportedCompMethods = {Stored, Deflated}; + CompatibleVersions = 1; (* versions >= CompatibleVersions are supported *) + + (* headers *) + LocalFileHeaderSignature = 04034B50H; + CentralFileHeaderSignature = 02014B50H; + EndOfCentralDirSignature = 06054B50H; + +TYPE + Entry* = POINTER TO EntryDesc; (** description of a file stored in the zip-archive **) + EntryDesc* = RECORD + name-: ARRAY 256 OF CHAR; (** name of file stored in the zip-archive **) + method: INTEGER; (* compression method *) + time-, date-: LONGINT; (** (Oberon) time and date when file was last modified **) + crc32: LONGINT; (* checksum of uncompressed file data *) + compSize-, uncompSize-: LONGINT; (** size of compressed / uncompressed file **) + intFileAttr: INTEGER; (* internal file attributes, not used in this implementation *) + extFileAttr: LONGINT; (* external file attributes, not used in this implementation *) + extraField (* for future expansions *), comment-: POINTER TO ARRAY OF CHAR; (** comment for this file **) + genPurpBitFlag: INTEGER; + support: SHORTINT; + dataDescriptor: BOOLEAN; (* if set, data descriptor after (compressed) file data *) + offsetLocal: LONGINT; (* offset of file header in central directory *) + offsetFileData: LONGINT; (* offset of (compressed) file data *) + offsetCentralDir: LONGINT; (* offset of local file header *) + next: Entry + END; + + Archive* = POINTER TO ArchiveDesc; (** description of a zipfile **) + ArchiveDesc* = RECORD + nofEntries-: INTEGER; (** total number of files stored in the zipfile **) + comment-: POINTER TO ARRAY OF CHAR; (** comment for zipfile **) + file: Files.File; (* pointer to the according zip-file *) + offset: LONGINT; (* offset of end of central dir record *) + firstEntry, lastEntry: Entry (* first and last Entry of Archive *) + END; + + Reader* = POINTER TO ReaderDesc; + ReaderDesc* = RECORD (** structure for reading from a zip-file into a buffer **) + res-: LONGINT; (** result of last operation **) + open: BOOLEAN; + ent: Entry + END; + + UncompReader = POINTER TO UncompReaderDesc; + UncompReaderDesc = RECORD (ReaderDesc) (* structur for reading from a uncompressed entry *) + fr: Files.Rider; + crc32: LONGINT; (* crc32 of uncomressed data *) + END; + + DefReader = POINTER TO DefReaderDesc; + DefReaderDesc = RECORD (ReaderDesc) (* structure for reading from a deflated entry *) + zr: ZlibReaders.Reader + END; + +(* length of str *) +PROCEDURE StringLength(VAR str(* in *): ARRAY OF CHAR): LONGINT; + VAR i, l: LONGINT; +BEGIN + l := LEN(str); i := 0; + WHILE (i < l) & (str[i] # 0X) DO + INC(i) + END; + RETURN i +END StringLength; + +(* Converts Oberon time into MS-DOS time *) +PROCEDURE OberonToDosTime(t: LONGINT): INTEGER; +BEGIN + RETURN SHORT(t DIV 1000H MOD 20H * 800H + t DIV 40H MOD 40H * 20H + t MOD 40H DIV 2) +END OberonToDosTime; + +(* Converts Oberon date into MS-DOS time *) +PROCEDURE OberonToDosDate(d: LONGINT): INTEGER; +BEGIN + RETURN SHORT((d DIV 200H + 1900 - 1980) * 200H + d MOD 200H) +END OberonToDosDate; + +(* Converts MS-DOS time into Oberon time *) +PROCEDURE DosToOberonTime(t: INTEGER): LONGINT; +BEGIN + RETURN LONG(t) DIV 800H MOD 20H * 1000H + t DIV 20H MOD 40H * 40H + t MOD 20H * 2 +END DosToOberonTime; + +(* Converts MS-DOS date into Oberon date *) +PROCEDURE DosToOberonDate(d: INTEGER): LONGINT; +BEGIN + RETURN (LONG(d) DIV 200H MOD 80H + 1980 - 1900) * 200H + d MOD 200H +END DosToOberonDate; + +(* Copy len bytes from src to dst; if compCRC32 is set, then the crc 32-checksum is computed *) +PROCEDURE Copy(VAR src, dst: Files.Rider; len: LONGINT; compCRC32: BOOLEAN; VAR crc32: LONGINT); +CONST + BufSize = 4000H; +VAR + n: LONGINT; + buf: ARRAY BufSize OF CHAR; +BEGIN + IF compCRC32 THEN crc32 := Zlib.CRC32(0, buf, -1, -1) END; + REPEAT + IF len < BufSize THEN n := len + ELSE n := BufSize + END; + Files.ReadBytes(src, buf, n); + IF compCRC32 THEN crc32 := Zlib.CRC32(crc32, buf, 0, n - src.res) END; + Files.WriteBytes(dst, buf, n - src.res); + DEC(len, n) + UNTIL len = 0 +END Copy; + +(* Reads an Entry, r must be at the start of a file header; returns NIL if read was not successful *) +PROCEDURE ReadEntry(VAR r: Files.Rider): Entry; +VAR + ent: Entry; + intDummy, nameLen, extraLen, commentLen: INTEGER; + longDummy: LONGINT; + bufDummy: ARRAY 256 OF CHAR; +BEGIN + Files.ReadLInt(r, longDummy); + IF longDummy = CentralFileHeaderSignature THEN + NEW(ent); + ent.offsetCentralDir := Files.Pos(r) - 4; + ent.support := 0; + Files.ReadInt(r, intDummy); (* version made by *) + Files.ReadInt(r, intDummy); (* version needed to extract *) + IF (intDummy MOD 100H) / 10 < CompatibleVersions THEN + ent.support := IncompatibleVersion + END; + Files.ReadInt(r, ent.genPurpBitFlag); (* general purpose bit flag *) + IF ODD(intDummy) THEN + ent.support := Encrypted (* bit 0: if set, file encrypted *) + END; + ent.dataDescriptor := ODD(intDummy DIV 8); (* bit 3: data descriptor after (compressed) file data *) + Files.ReadInt(r, ent.method); (* compression method *) + IF (ent.support = Supported) & ~(ent.method IN SupportedCompMethods) THEN + ent.support := UnsupCompMethod + END; + Files.ReadInt(r, intDummy); ent.time := DosToOberonTime(intDummy); (* last mod file time *) + Files.ReadInt(r, intDummy); ent.date := DosToOberonDate(intDummy); (* last mod file date *) + Files.ReadLInt(r, ent.crc32); (* crc-32 *) + Files.ReadLInt(r, ent.compSize); (* compressed size *) + Files.ReadLInt(r, ent.uncompSize); (* uncompressed size *) + Files.ReadInt(r, nameLen); (* filename length *) + Files.ReadInt(r, extraLen); (* extra field length *) + Files.ReadInt(r, commentLen); (* file comment length *) + Files.ReadInt(r, intDummy); (* disk number start *) + Files.ReadInt(r, ent.intFileAttr); (* internal file attributes *) + Files.ReadLInt(r, ent.extFileAttr); (* external file attributes *) + Files.ReadLInt(r, ent.offsetLocal); (* relative offset of local header *) + Files.ReadBytes(r, ent.name, nameLen); (* filename *) + IF extraLen # 0 THEN + NEW(ent.extraField, extraLen); + Files.ReadBytes(r, ent.extraField^, extraLen) (* extra field *) + END; + IF commentLen > 0 THEN + NEW(ent.comment, commentLen); + Files.ReadBytes(r, ent.comment^, commentLen) (* file comment *) + END; + (* read extra field length in the local file header (can be different from extra field length stored in the file header...) *) + longDummy := Files.Pos(r); (* store actual position of file reader *) + Files.Set(r, Files.Base(r), ent.offsetLocal + 28); (* set r to position of extra field length in local file header *) + Files.ReadInt(r, extraLen); (* extra field length *) + ent.offsetFileData := ent.offsetLocal + 30 + nameLen + extraLen; (* compute offset of file data *) + Files.Set(r, Files.Base(r), longDummy); (* set position of file reader to previous position *) + IF r.eof THEN (* if file is a zip-archive, r is not at end of file *) + ent := NIL + END + END; + RETURN ent; +END ReadEntry; + +(* Writes a local file header *) +PROCEDURE WriteLocalFileHeader(ent: Entry; VAR r: Files.Rider); +BEGIN + Files.WriteLInt(r, LocalFileHeaderSignature); (* local file header signature *) + Files.WriteInt(r, CompatibleVersions * 10); (* version needed to extract *) + Files.WriteInt(r, ent.genPurpBitFlag); (* general purpose bit flag *) + Files.WriteInt(r, ent.method); (* compression method *) + Files.WriteInt(r, OberonToDosTime(ent.time)); (* last mod file time *) + Files.WriteInt(r, OberonToDosDate(ent.date)); (* last mod file date *) + Files.WriteLInt(r, ent.crc32); (* crc-32 *) + Files.WriteLInt(r, ent.compSize); (* compressed size *) + Files.WriteLInt(r, ent.uncompSize); (* uncompressed size *) + Files.WriteInt(r, SHORT(StringLength(ent.name))); (* filename length *) + IF ent.extraField # NIL THEN + Files.WriteInt(r, SHORT(LEN(ent.extraField^))) (* extra field length *) + ELSE + Files.WriteInt(r, 0) + END; + Files.WriteBytes(r, ent.name, StringLength(ent.name)); (* filename *) + IF ent.extraField # NIL THEN + Files.WriteBytes(r, ent.extraField^, LEN(ent.extraField^)) (* extra field *) + END +END WriteLocalFileHeader; + +(* Writes file header in central directory, updates ent.offsetCentralDir *) +PROCEDURE WriteFileHeader(ent: Entry; VAR r: Files.Rider); +BEGIN + ent.offsetCentralDir := Files.Pos(r); + Files.WriteLInt(r, CentralFileHeaderSignature); (* central file header signature *) + Files.WriteInt(r, CompatibleVersions * 10); (* version made by *) + Files.WriteInt(r, CompatibleVersions * 10); (* version needed to extract *) + Files.WriteInt(r, ent.genPurpBitFlag); (* general purpose bit flag *) + Files.WriteInt(r, ent.method); (* compression method *) + Files.WriteInt(r, OberonToDosTime(ent.time)); (* last mod file time *) + Files.WriteInt(r, OberonToDosDate(ent.date)); (* last mod file date *) + Files.WriteLInt(r, ent.crc32); (* crc-32 *) + Files.WriteLInt(r, ent.compSize); (* compressed size *) + Files.WriteLInt(r, ent.uncompSize); (* uncompressed size *) + Files.WriteInt(r, SHORT(StringLength(ent.name))); (* filename length *) + IF ent.extraField = NIL THEN + Files.WriteInt(r, 0) + ELSE + Files.WriteInt(r, SHORT(LEN(ent.extraField^))); (* extra field length *) + END; + IF ent.comment = NIL THEN + Files.WriteInt(r, 0) + ELSE + Files.WriteInt(r, SHORT(LEN(ent.comment^))); (* file comment length *) + END; + Files.WriteInt(r, 0); (* disk number start *) + Files.WriteInt(r, ent.intFileAttr); (* internal file attributes *) + Files.WriteLInt(r, ent.extFileAttr); (* external file attributes *) + Files.WriteLInt(r, ent.offsetLocal); (* relative offset of local header *) + Files.WriteBytes(r, ent.name, StringLength(ent.name)); (* filename *) + IF ent.extraField # NIL THEN + Files.WriteBytes(r, ent.extraField^, LEN(ent.extraField^)) (* extra field *) + END; + IF ent.comment # NIL THEN + Files.WriteBytes(r, ent.comment^, LEN(ent.comment^)) (* file comment *) + END +END WriteFileHeader; + +(* Writes end of central directory record *) +PROCEDURE WriteEndOfCentDir(arc: Archive; VAR r: Files.Rider); +VAR + size: LONGINT; +BEGIN + Files.WriteLInt(r, EndOfCentralDirSignature); (* end of central dir signature *) + Files.WriteInt(r, 0); (* number of this disk *) + Files.WriteInt(r, 0); (* number of the disk with the start of the central directory *) + Files.WriteInt(r, arc.nofEntries); (* total number of entries in the central dir on this disk *) + Files.WriteInt(r, arc.nofEntries); (* total number of entries in the central dir *) + IF arc.firstEntry # NIL THEN + Files.WriteLInt(r, arc.offset - arc.firstEntry.offsetCentralDir) (* size of the central directory (without end of central dir record) *) + ELSE + Files.WriteLInt(r, 0) + END; + IF arc.firstEntry = NIL THEN + Files.WriteLInt(r, arc.offset) (* offset of start of central directory with respect to the starting disk number *) + ELSE + Files.WriteLInt(r, arc.firstEntry.offsetCentralDir) (* offset of start of central directory with respect to the starting disk number *) + END; + IF arc.comment = NIL THEN + Files.WriteInt(r, 0) (* zipfile comment length *) + ELSE + Files.WriteInt(r, SHORT(LEN(arc.comment^))); (* zipfile comment length *) + Files.WriteBytes(r, arc.comment^, LEN(arc.comment^)) (* zipfile comment *) + END +END WriteEndOfCentDir; + +(* Writes central directory + end of central directory record, updates arc.offset and offsetCentralDir of entries *) +PROCEDURE WriteCentralDirectory(arc: Archive; VAR r: Files.Rider); +VAR + ent: Entry; +BEGIN + ent := arc.firstEntry; + WHILE ent # NIL DO + WriteFileHeader(ent, r); + ent := ent.next + END; + arc.offset := Files.Pos(r); + WriteEndOfCentDir(arc, r) +END WriteCentralDirectory; + +(** Returns an Archive data structure corresponding to the specified zipfile; + possible results: + - Ok: operation was successful + - FileError: file with specified name does not exist + - NotZipArchiveError: file is not a correct zipfile **) +PROCEDURE OpenArchive*(name: ARRAY OF CHAR; VAR res: LONGINT): Archive; +VAR + arc: Archive; + ent: Entry; + f: Files.File; + r: Files.Rider; + longDummy: LONGINT; + intDummy: INTEGER; +BEGIN + res := Ok; + f := Files.Old(name); + IF f = NIL THEN + res := FileError + ELSIF Files.Length(f) < 22 THEN + res := NotZipArchiveError + ELSE + longDummy := 0; + Files.Set(r, f, Files.Length(f) - 17); + WHILE (longDummy # EndOfCentralDirSignature) & (Files.Pos(r) > 4) DO + Files.Set(r, f, Files.Pos(r) - 5); + Files.ReadLInt(r, longDummy) + END; + IF longDummy # EndOfCentralDirSignature THEN + res := NotZipArchiveError + ELSE + NEW(arc); + arc.file := f; + arc.offset := Files.Pos(r) - 4; + Files.ReadInt(r, intDummy); (* number of this disk *) + Files.ReadInt(r, intDummy); (* number of the disk with the start of the central directory *) + Files.ReadInt(r, intDummy); (* total number of entries in the central dir on this disk *) + Files.ReadInt(r, arc.nofEntries); (* total number of entries in the central dir *) + Files.ReadLInt(r, longDummy); (* size of the central directory *) + Files.ReadLInt(r, longDummy); (* offset of start of central directory with respect to the starting disk number *) + Files.ReadInt(r, intDummy); (* zipfile comment length *) + IF intDummy # 0 THEN + NEW(arc.comment, intDummy); + Files.ReadBytes(r, arc.comment^, intDummy) (* zipfile comment *) + END; + IF Files.Pos(r) # Files.Length(f) THEN + res := NotZipArchiveError; + arc := NIL + ELSE + Files.Set(r, f, longDummy); (* set r on position of first file header in central dir *) + arc.firstEntry := ReadEntry(r); arc.lastEntry := arc.firstEntry; + ent := arc.firstEntry; intDummy := 0; + WHILE ent # NIL DO + arc.lastEntry := ent; INC(intDummy); (* count number of entries *) + ent.next := ReadEntry(r); + ent := ent.next + END; + IF intDummy # arc.nofEntries THEN + res := NotZipArchiveError; + arc := NIL + END + END; + Files.Close(f) + END + END; + RETURN arc +END OpenArchive; + +(** Returns an Archive that corresponds to a file with specified name; + if there is already a zip-file with the same name, this already existing archive is returned; + possible results: cf. OpenArchive **) +PROCEDURE CreateArchive*(VAR name: ARRAY OF CHAR; VAR res: LONGINT): Archive; +VAR + f: Files.File; + r: Files.Rider; + arc: Archive; +BEGIN + f := Files.Old(name); + IF f # NIL THEN + RETURN OpenArchive(name, res) + ELSE + f := Files.New(name); + NEW(arc); + arc.file := f; + arc.nofEntries := 0; + arc.offset := 0; + Files.Set(r, f, 0); + WriteEndOfCentDir(arc, r); + Files.Register(f); + res := Ok; + RETURN arc + END +END CreateArchive; + +(** Returns the first entry of the Archive arc (NIL if there is no Entry) **) +PROCEDURE FirstEntry*(arc: Archive): Entry; +BEGIN + IF arc = NIL THEN + RETURN NIL + ELSE + RETURN arc.firstEntry + END +END FirstEntry; + +(** Returns the next Entry after ent **) +PROCEDURE NextEntry*(ent: Entry): Entry; +BEGIN + RETURN ent.next +END NextEntry; + +(** Returns the Entry that corresponds to the file with the specified name and that is stored in the Archive arc; + possible results: + - Ok: Operation was successful + - NotZipArchiveError: arc is not a valid Archive + - EntryNotFound: no Entry corresponding to name was found **) +PROCEDURE GetEntry*(arc: Archive; VAR name: ARRAY OF CHAR; VAR res: LONGINT): Entry; +VAR + ent: Entry; +BEGIN + IF arc = NIL THEN + res := NotZipArchiveError + ELSE + ent := arc.firstEntry; + WHILE (ent # NIL) & (ent.name # name) DO + ent := ent.next + END; + IF ent = NIL THEN + res := EntryNotFound + ELSE + res := Ok + END + END; + RETURN ent +END GetEntry; + +(** Uncompresses and writes the data of Entry ent to Files.Rider dst; + possible results: + - Ok: Data extracted + - NotZipArchiveError: arc is not a valid zip-archive + - EntryNotFound: ent is not an Entry of arc + - NotSupportedError: data of ent are encrypted or compression method is not supported + - DataError: zipfile is corrupted + - BadName: entry has a bad file name **) +PROCEDURE ExtractEntry*(arc: Archive; ent: Entry; VAR dst: Files.Rider; VAR res: LONGINT); +VAR + src: Files.Rider; crc32: LONGINT; +BEGIN + IF arc = NIL THEN + res := NotZipArchiveError + ELSIF Files.Base(dst) = NIL THEN + res := BadName + ELSIF (ent = NIL) OR (ent # GetEntry(arc, ent.name, res)) THEN + res := EntryNotFound + ELSIF ~(ent.method IN SupportedCompMethods) OR (ent.support > Supported) THEN + res := NotSupportedError + ELSE + CASE ent.method OF + | Stored: + Files.Set(src, arc.file, ent.offsetFileData); + Copy(src, dst, ent.uncompSize, TRUE, crc32); + IF crc32 = ent.crc32 THEN + res := Ok + ELSE + res := DataError + END + | Deflated: + Files.Set(src, arc.file, ent.offsetFileData); + ZlibReaders.Uncompress(src, dst, crc32, res); + IF (res = ZlibReaders.Ok) & (crc32 = ent.crc32) THEN + res := Ok + ELSE + res := DataError + END + END; + IF res = Ok THEN + Files.Close(Files.Base(dst)); + END + END +END ExtractEntry; + +(** Reads and compresses len bytes from Files.Rider src with specified level and strategy + and writes them to a new Entry in the Archive arc; + possible results: + - Ok: file was added to arc + - NotZipArchiveError: arc is not a valid zip-archive + - EntryAlreadyExists: there is already an Entry in arc with the same name + - DataError: error during compression + - BadName: src is not based on a valid file **) +PROCEDURE AddEntry*(arc: Archive; VAR name: ARRAY OF CHAR; VAR src: Files.Rider; len: LONGINT; level, strategy: SHORTINT; VAR res: LONGINT); +VAR + dst: Files.Rider; ent: Entry; start: LONGINT; +BEGIN + IF arc = NIL THEN + res := NotZipArchiveError + ELSIF Files.Base(src) = NIL THEN + res := BadName + ELSIF (GetEntry(arc, name, res) # NIL) & (res = Ok) THEN + res := EntryAlreadyExists + ELSE + NEW(ent); + COPY(name, ent.name); + ent.genPurpBitFlag := 0; + IF level = NoCompression THEN + ent.method := Stored + ELSE + ent.method := Deflated + END; + Files.GetDate(Files.Base(src), ent.time, ent.date); + ent.uncompSize := len; + ent.intFileAttr := 0; + ent.extFileAttr := 0; + ent.comment := NIL; + ent.support := Supported; + ent.dataDescriptor := FALSE; + IF arc.firstEntry # NIL THEN + ent.offsetLocal := arc.firstEntry.offsetCentralDir + ELSE + ent.offsetLocal := 0 + END; + Files.Set(dst, arc.file, ent.offsetLocal); + WriteLocalFileHeader(ent, dst); + ent.offsetFileData := Files.Pos(dst); + Files.Close(arc.file); + start := Files.Pos(src); + IF level = 0 THEN + Copy(src, dst, len, TRUE, ent.crc32); + ent.compSize := len; + res := Ok + ELSE + ZlibWriters.Compress(src, dst, len, ent.compSize, level, strategy, ent.crc32, res); + IF res # ZlibWriters.Ok THEN + res := DataError + ELSE + res := Ok + END + END; + IF res = Ok THEN + ent.uncompSize := Files.Pos(src) - start; + Files.Close(arc.file); + Files.Set(dst, arc.file, ent.offsetLocal + 14); + Files.WriteLInt(dst, ent.crc32); + Files.WriteLInt(dst, ent.compSize); + Files.Close(arc.file); + IF arc.lastEntry # NIL THEN + arc.lastEntry.next := ent + ELSE (* archive has no entries *) + arc.firstEntry := ent + END; + arc.lastEntry := ent; + INC(arc.nofEntries); + Files.Set(dst, arc.file, ent.offsetFileData + ent.compSize); + WriteCentralDirectory(arc, dst); + Files.Close(arc.file); + res := Ok + END; + END +END AddEntry; + +(** Deletes Entry ent from Archive arc; + Possible results: + - Ok: ent was deleted, ent is set to NIL + - NotZipArchiveError: arc is not a valid zip-archive + - EntryNotFound: ent is not an Entry of Archive arc **) +PROCEDURE DeleteEntry*(arc: Archive; VAR ent: Entry; VAR res: LONGINT); +CONST + BufSize = 4000H; +VAR + f: Files.File; r1, r2: Files.Rider; + ent2: Entry; + arcname: ARRAY 256 OF CHAR; + buf: ARRAY BufSize OF CHAR; + offset, diff: LONGINT; +BEGIN + IF arc = NIL THEN + res := NotZipArchiveError + ELSIF arc.firstEntry = NIL THEN + res := EntryNotFound + ELSIF arc.firstEntry = ent THEN + offset := arc.firstEntry.offsetLocal; (* arc.firstEntry.offsetLocal = 0 *) + IF arc.lastEntry = arc.firstEntry THEN + arc.lastEntry := arc.firstEntry.next (* = NIL *) + END; + arc.firstEntry := arc.firstEntry.next; + ent2 := arc.firstEntry; + res := Ok + ELSE + ent2 := arc.firstEntry; + WHILE (ent2.next # NIL) & (ent2.next # ent) DO + ent2 := ent2.next + END; + IF ent2.next = NIL THEN + res := EntryNotFound + ELSE + IF arc.lastEntry = ent2.next THEN + arc.lastEntry := ent2 + END; + offset := ent2.next.offsetLocal; + ent2.next := ent2.next.next; + ent2 := ent2.next; + res := Ok + END + END; + IF res = Ok THEN + Files.GetName(arc.file, arcname); + f := Files.New(arcname); + Files.Set(r2, f, 0); + Files.Set(r1, arc.file, 0); + Copy(r1, r2, offset, FALSE, diff); (* no crc 32-checksum is computed -> diff used as dummy *) + Files.Close(f); + ASSERT(ent2 = ent.next); + IF ent2 # NIL THEN + Files.Set(r1, arc.file, ent2.offsetLocal); + Copy(r1, r2, arc.firstEntry.offsetCentralDir - ent2.offsetLocal, FALSE, diff); (* arc.firstEntry can not be NIL because ent # NIL *) + Files.Close(f); + diff := ent2.offsetLocal - offset + ELSE + diff := arc.offset - offset + END; + WHILE (ent2 # NIL) DO (* update offsets of entries *) + DEC(ent2.offsetLocal, diff); DEC(ent2.offsetFileData, diff); DEC(ent2.offsetCentralDir, diff); + ent2 := ent2.next + END; + DEC(arc.offset, diff); + DEC(arc.nofEntries); + WriteCentralDirectory(arc, r2); + Files.Register(f); arc.file := f; ent := NIL + END +END DeleteEntry; + +(** open a Reader to read uncompressed data from a zip entry directly to memory **) +PROCEDURE OpenReader*(arc: Archive; ent: Entry): Reader; +VAR + dummyBuf: ARRAY 1 OF CHAR; + fr: Files.Rider; + r: Reader; + ur: UncompReader; + dr: DefReader; +BEGIN + IF ent.support = Supported THEN + IF ent.method = Stored THEN + NEW(ur); + ur.crc32 := Zlib.CRC32(0, dummyBuf, -1, -1); + Files.Set(ur.fr, arc.file, ent.offsetFileData); + r := ur; + r.open := TRUE; + r.res := Ok + ELSIF ent.method = Deflated THEN + Files.Set(fr, arc.file, ent.offsetFileData); + NEW(dr); + ZlibReaders.Open(dr.zr, FALSE, fr); + dr.res := dr.zr.res; + r := dr; + r.open := TRUE + ELSE + NEW(r); + r.open := FALSE; + r.res := NotSupportedError + END; + ELSE + NEW(r); + r.open := FALSE; + r.res := NotSupportedError + END; + r.ent := ent; + RETURN r; +END OpenReader; + +(** read len bytes of uncompressed data into buf[offset] and return number of bytes actually read; Reader must be opened **) +PROCEDURE ReadBytes*(r: Reader; VAR buf: ARRAY OF CHAR; offset, len: LONGINT; VAR read: LONGINT); +VAR + bufp: POINTER TO ARRAY OF CHAR; i: LONGINT; +BEGIN + IF r.open THEN + IF r IS UncompReader THEN + IF offset = 0 THEN + Files.ReadBytes(r(UncompReader).fr, buf, len); + ELSE + NEW(bufp, len); + Files.ReadBytes(r(UncompReader).fr, bufp^, len); + FOR i := 0 TO len - 1 DO + buf[offset + i] := bufp[i] + END + END; + read := len - r(UncompReader).fr.res; + r(UncompReader).crc32 := Zlib.CRC32(r(UncompReader).crc32, buf, offset, read) + ELSIF r IS DefReader THEN + ZlibReaders.ReadBytes(r(DefReader).zr, buf, offset, len, read); + r.res := r(DefReader).zr.res + END + ELSE + r.res := ReaderError + END +END ReadBytes; + +(** read decompressed byte **) +PROCEDURE Read*(r: Reader; VAR ch: CHAR); +VAR + buf: ARRAY 1 OF CHAR; read: LONGINT; +BEGIN + ReadBytes(r, buf, 0, 1, read); + ch := buf[0]; +END Read; + +(** close Reader **) +PROCEDURE Close*(r: Reader); +BEGIN + IF r.open THEN + IF r IS UncompReader THEN + IF r(UncompReader).crc32 # r.ent.crc32 THEN + r.res := DataError + ELSE + r.res := Ok + END + ELSIF r IS DefReader THEN + ZlibReaders.Close(r(DefReader).zr); + IF r(DefReader).zr.crc32 # r.ent.crc32 THEN + r.res := DataError + ELSE + r.res := r(DefReader).zr.res + END + ELSE + r.res := ReaderError + END; + r.open := FALSE + ELSE + r.res := ReaderError + END +END Close; + +END Zip. diff --git a/src/lib/s3/Zlib.Mod b/src/lib/s3/Zlib.Mod new file mode 100644 index 00000000..aa033f3f --- /dev/null +++ b/src/lib/s3/Zlib.Mod @@ -0,0 +1,160 @@ +(* ETH Oberon, Copyright 2001 ETH Zuerich Institut fuer Computersysteme, ETH Zentrum, CH-8092 Zuerich. +Refer to the "General ETH Oberon System Source License" contract available at: http://www.oberon.ethz.ch/ *) + +MODULE Zlib; (** Stefan Walthert **) + +IMPORT + SYSTEM; + +CONST + (** Result codes for compression/decompression functions **) + + (** regular termination **) + Ok* = 0; (** some progress has been made (more input processed or more output produced **) + StreamEnd* = 1; (** all input has been consumed and all output has been produced (only when flush is set to Finish) **) + NeedDict* = 2; + + (** errors **) + StreamError* = -2; (** stream state was inconsistent (for example stream.in.next or stream.out.next was 0) **) + DataError* = -3; + MemError* = -4; + BufError* = -5; (** no progress is possible (for example stream.in.avail or stream.out.avail was zero) **) + + + (** Flush values (Flushing may degrade compression for some compression algorithms and so it should be used only + when necessary) **) + NoFlush* = 0; + PartialFlush* = 1; (** will be removed, use SyncFlush instead **) + SyncFlush* = 2; (** pending output is flushed to the output buffer and the output is aligned on a byte boundary, + so that the compressor/decompressor can get all input data available so far. (In particular stream.in.avail + is zero after the call if enough output space has been provided before the call.) **) + FullFlush* = 3; (** all output is flushed as with SyncFlush, and the compression state is reset so that + decompression can restart from this point if previous compressed data has been damaged of if random access + is desired. Using FullFlush too often can seriously degrade the compression. **) + Finish* = 4; (** pending input is processed, pending output is flushed. + If Deflate/Inflate returns with StreamEnd, there was enough space. + If Deflate/Inflate returns with Ok, this function must be called again with Finish and more output space + (updated stream.out.avail) but no more input data, until it returns with StreamEnd or an error. + After Deflate has returned StreamEnd, the only possible operations on the stream are Reset or Close + Finish can be used immediately after Open if all the compression/decompression is to be done in a single step. + In case of compression, the out-Buffer (respectively stream.out.avail) must be at least 0.1% larger than the + in-Buffer (respectively stream.in.avail) plus 12 bytes. **) + + (** compression levels **) + DefaultCompression* = -1; + NoCompression* = 0; + BestSpeed* = 1; + BestCompression* = 9; + + (** compression strategies; the strategy only affects the compression ratio but not the correctness of the + compressed output even if it is not set appropriately **) + DefaultStrategy* = 0; (** for normal data **) + Filtered* = 1; (** for data produced by a filter (or predictor); filtered data consists mostly of small values with a + somewhat random distribution. In this case, the compression algorithm is tuned to compress them better. + The effect of Filtered is to force more Huffman coding and less string matching; it is somewhat intermediate + between DefaultStrategy and HuffmanOnly. **) + HuffmanOnly* = 2; (** to force Huffman encoding only (no string match) **) + + (** data type **) + Binary* = 0; + Ascii* = 1; + Unknown* = 2; + + DeflateMethod* = 8; + +VAR + CRCTable: ARRAY 256 OF LONGINT; + + +PROCEDURE Adler32*(adler: LONGINT; VAR buf: ARRAY OF CHAR; offset, len: LONGINT): LONGINT; +CONST + base = 65521; (* largest prim smaller than 65536 *) + nmax = 5552; (* largest n such that 255n(n + 1) / 2 + (n + 1)(base - 1) <= 2^32 - 1 *) +VAR + s1, s2, k, offset0, len0: LONGINT; +BEGIN + offset0 := offset; len0 := len; + IF len < 0 THEN + RETURN 1 + ELSE + s1 := adler MOD 10000H; + s2 := SYSTEM.LSH(adler, -16) MOD 10000H; + WHILE len > 0 DO + IF len < nmax THEN k := len ELSE k := nmax END; + DEC(len, k); + REPEAT + INC(s1, LONG(ORD(buf[offset]))); + INC(s2, s1); + INC(offset); + DEC(k) + UNTIL k = 0; + s1 := s1 MOD base; + s2 := s2 MOD base + END; + RETURN SYSTEM.LSH(s2, 16) + s1 + END +END Adler32; + + +(** Generate a table for a byte-wise 32-bit CRC calculation on the polynomial: + x^32+x^26+x^23+x^22+x^16+x^12+x^11+x^10+x^8+x^7+x^5+x^4+x^2+x+1. + + Polynomials over GF(2) are represented in binary, one bit per coefficient, + with the lowest powers in the most significant bit. Then adding polynomials + is just exclusive-or, and multiplying a polynomial by x is a right shift by + one. If we call the above polynomial p, and represent a byte as the + polynomial q, also with the lowest power in the most significant bit (so the + byte 0xb1 is the polynomial x^7+x^3+x+1), then the CRC is (q*x^32) mod p, + where a mod b means the remainder after dividing a by b. + + This calculation is done using the shift-register method of multiplying and + taking the remainder. The register is initialized to zero, and for each + incoming bit, x^32 is added mod p to the register if the bit is a one (where + x^32 mod p is p+x^32 = x^26+...+1), and the register is multiplied mod p by + x (which is shifting right by one and adding x^32 mod p if the bit shifted + out is a one). We start with the highest power (least significant bit) of + q and repeat for all eight bits of q. + + The table is simply the CRC of all possible eight bit values. This is all + the information needed to generate CRC's on data a byte at a time for all + combinations of CRC register values and incoming bytes. **) + +PROCEDURE InitCRCTable*(); +CONST + poly = 0EDB88320H; +VAR + n, c, k: LONGINT; +BEGIN + FOR n := 0 TO 255 DO + c := n; + FOR k := 0 TO 7 DO + IF ODD(c) THEN c := SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET, poly)/SYSTEM.VAL(SET, SYSTEM.LSH(c, -1))) + ELSE c := SYSTEM.LSH(c, -1) + END + END; + CRCTable[n] := c + END +END InitCRCTable; + + +PROCEDURE CRC32*(crc: LONGINT; VAR buf: ARRAY OF CHAR; offset, len: LONGINT): LONGINT; +VAR idx: LONGINT; +BEGIN + IF offset < 0 THEN + crc := 0 + ELSE + crc := SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET, crc)/{0..31}); + WHILE len > 0 DO + idx := SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET, crc)/SYSTEM.VAL(SET, LONG(ORD(buf[offset])))) MOD 100H; + crc := SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET, CRCTable[idx])/SYSTEM.VAL(SET, SYSTEM.LSH(crc, -8))); + DEC(len); INC(offset) + END; + crc := SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET, crc)/{0..31}) + END; + RETURN crc +END CRC32; + + +BEGIN + InitCRCTable(); +END Zlib. diff --git a/src/lib/s3/ZlibBuffers.Mod b/src/lib/s3/ZlibBuffers.Mod new file mode 100644 index 00000000..68e0f1fb --- /dev/null +++ b/src/lib/s3/ZlibBuffers.Mod @@ -0,0 +1,116 @@ +(* ETH Oberon, Copyright 2001 ETH Zuerich Institut fuer Computersysteme, ETH Zentrum, CH-8092 Zuerich. +Refer to the "General ETH Oberon System Source License" contract available at: http://www.oberon.ethz.ch/ *) + +MODULE ZlibBuffers; (** Stefan Walthert **) + +IMPORT + SYSTEM; + (* + should be portable even if SYSTEM is imported: + - PUT and GET only with byte sized operands + - no overlapping MOVEs (unless malignant client passes buffer memory to buffer operations) + *) + +TYPE + (** input/output buffer **) + Address = LONGINT; + Buffer* = RECORD + avail-: LONGINT; (** number of bytes that can be produced/consumed **) + size-: LONGINT; (** total number of bytes in buffer memory **) + totalOut-, totalIn-: LONGINT; (** total number of bytes produced/consumed **) + next: Address; (* address of next byte to produce/consume **) + adr: Address; (* buffer memory *) + END; + + +(** set buf.totalIn and buf.totalOut to zero **) +PROCEDURE Reset*(VAR buf: Buffer); +BEGIN + buf.totalIn := 0; buf.totalOut := 0 +END Reset; + +(** initialize buffer on memory in client space **) +PROCEDURE Init* (VAR buf: Buffer; VAR mem: ARRAY OF CHAR; offset, size, avail: LONGINT); +BEGIN + ASSERT((0 <= offset) & (0 < size) & (offset + size <= LEN(mem)), 100); + ASSERT((0 <= avail) & (avail <= size),101); + buf.avail := avail; buf.size := size; buf.adr := SYSTEM.ADR(mem[offset]); buf.next := buf.adr; +END Init; + +(** read byte from (input) buffer **) +PROCEDURE Read* (VAR buf: Buffer; VAR ch: CHAR); +BEGIN + ASSERT(buf.avail > 0, 100); + SYSTEM.GET(buf.next, ch); + INC(buf.next); DEC(buf.avail); INC(buf.totalIn) +END Read; + +(** read len bytes from (input) buffer **) +PROCEDURE ReadBytes* (VAR buf: Buffer; VAR dst: ARRAY OF CHAR; offset, len: LONGINT); +BEGIN + ASSERT((0 <= offset) & (0 < len) & (offset + len <= LEN(dst)) & (len <= buf.avail), 100); + SYSTEM.MOVE(buf.next, SYSTEM.ADR(dst[offset]), len); + INC(buf.next, len); DEC(buf.avail, len); INC(buf.totalIn, len) +END ReadBytes; + +(** write byte into (output) buffer **) +PROCEDURE Write* (VAR buf: Buffer; ch: CHAR); +BEGIN + ASSERT(buf.avail > 0, 100); + SYSTEM.PUT(buf.next, ch); + INC(buf.next); DEC(buf.avail); INC(buf.totalOut) +END Write; + +(** write len bytes into (output) buffer **) +PROCEDURE WriteBytes* (VAR buf: Buffer; VAR src: ARRAY OF CHAR; offset, len: LONGINT); +BEGIN + ASSERT((0 <= offset) & (0 < len) & (offset + len <= LEN(src)) & (len <= buf.avail), 100); + SYSTEM.MOVE(SYSTEM.ADR(src[offset]), buf.next, len); + INC(buf.next, len); DEC(buf.avail, len); INC(buf.totalOut, len) +END WriteBytes; + +(** rewind previously empty input buffer to first position after it has been filled with new input **) +PROCEDURE Rewind* (VAR buf: Buffer; avail: LONGINT); +BEGIN + ASSERT(buf.avail = 0, 100); + ASSERT((0 <= avail) & (avail <= buf.size), 101); + buf.next := buf.adr; buf.avail := avail +END Rewind; + +(** move position of next read for -offset bytes **) +PROCEDURE Reread* (VAR buf: Buffer; offset: LONGINT); +BEGIN + ASSERT((0 <= offset) & (buf.avail + offset <= buf.size), 101); + DEC(buf.next, offset); INC(buf.avail, offset) +END Reread; + +(** restart writing at starting position of output buffer after it has been emptied **) +PROCEDURE Rewrite* (VAR buf: Buffer); +BEGIN + buf.next := buf.adr; buf.avail := buf.size +END Rewrite; + +(** fill input buffer with new bytes to consume **) +PROCEDURE Fill* (VAR buf: Buffer; VAR src: ARRAY OF CHAR; offset, size: LONGINT); +BEGIN + ASSERT((0 <= offset) & (0 < size) & (offset + size <= LEN(src)), 100); + ASSERT(buf.avail + size <= buf.size, 101); + IF buf.avail # 0 THEN + SYSTEM.MOVE(buf.next, buf.adr, buf.avail) + END; + buf.next := buf.adr + buf.avail; + SYSTEM.MOVE(SYSTEM.ADR(src[offset]), buf.next, size); + INC(buf.avail, size) +END Fill; + +(** extract bytes from output buffer to make room for new bytes **) +PROCEDURE Drain* (VAR buf: Buffer; VAR dst: ARRAY OF CHAR; offset, size: LONGINT); +BEGIN + ASSERT((0 <= offset) & (0 < size) & (offset + size <= LEN(dst)), 100); + ASSERT(buf.avail + size <= buf.size, 101); (* can't consume more than is in buffer *) + SYSTEM.MOVE(buf.adr, SYSTEM.ADR(dst[offset]), size); + SYSTEM.MOVE(buf.adr + size, buf.adr, buf.size - buf.avail - size); + INC(buf.avail, size); DEC(buf.next, size); +END Drain; + +END ZlibBuffers. diff --git a/src/lib/s3/ZlibDeflate.Mod b/src/lib/s3/ZlibDeflate.Mod new file mode 100644 index 00000000..5d5368d7 --- /dev/null +++ b/src/lib/s3/ZlibDeflate.Mod @@ -0,0 +1,1492 @@ +(* ETH Oberon, Copyright 2001 ETH Zuerich Institut fuer Computersysteme, ETH Zentrum, CH-8092 Zuerich. +Refer to the "General ETH Oberon System Source License" contract available at: http://www.oberon.ethz.ch/ *) + +MODULE ZlibDeflate; (** Stefan Walthert **) + + (** + Compression of byte streams with deflate algorithm + **) + + (* + 01.04.2001 - fixed bug in Deflate (condition before 4th RETURN statement: + .. & (flush # BufError) THEN .. instead of .. & (flush # Finish) THEN .. + *) + +IMPORT + SYSTEM, Zlib, ZlibBuffers; + +CONST + (** Result codes for compression/decompression functions **) + Ok* = Zlib.Ok; StreamEnd* = Zlib.StreamEnd; (** regular termination **) + StreamError* = Zlib.StreamError;DataError* = Zlib.DataError; MemError* = Zlib.MemError; BufError* = Zlib.BufError; (** errors **) + + (** Flush values **) + NoFlush* = Zlib.NoFlush; PartialFlush = Zlib.PartialFlush; SyncFlush* = Zlib.SyncFlush; FullFlush* = Zlib.FullFlush; Finish* = Zlib.Finish; + + (** compression levels **) + DefaultCompression* = Zlib.DefaultCompression; NoCompression* = Zlib.NoCompression; + BestSpeed* = Zlib.BestSpeed; BestCompression* = Zlib.BestCompression; + + (** compression strategies **) + DefaultStrategy* = Zlib.DefaultStrategy; Filtered* = Zlib.Filtered; HuffmanOnly* = Zlib.HuffmanOnly; + + (** data type **) + Binary* = Zlib.Binary; Ascii* = Zlib.Ascii; Unknown* = Zlib.Unknown; + + (* stream states *) + InitState = 1; BusyState = 2; FinishState = 3; + + (* block state *) + NeedMore = 1; BlockDone = 2; FinishStarted = 3; FinishDone = 4; + + StoredBlock = 0; StaticTrees = 1; DynamicTrees = 2; (* block types *) + Deflated = 8; (* compression method (by coincidence the only one supported..) *) + PresetDict = 20H; (* flag indicating use of a preset dictionary *) + + (* Huffman trees *) + LengthCodes = 29; Literals = 256; LitLenCodes = Literals + 1 + LengthCodes; DistCodes = 30; BitCodes = 19; + HeapSize = 2 * LitLenCodes + 1; MaxBits = 15; MaxBitLenBits = 7; DistCodeLen = 512; EndBlock = 256; BitBufSize = 16; + Rep3To6 = 16; RepZero3To10 = 17; RepZero11To138 = 18; + + (* window and matches *) + WindowBits = 15; WindowSize = ASH(1, WindowBits); (* always use 32k buffer *) + MinMatch = 3; MaxMatch = 258; + MinLookAhead = MinMatch + MaxMatch + 1; MaxDist = WindowSize - MinLookAhead; + TooFar = 4096; (* matches of length MinMatch are discarded if their distance exceeds this *) + MemLevel = 8; (* constant memory level *) + HashBits = MemLevel + 7; HashSize = ASH(1, HashBits); (* implies constant number of hash bits *) + HashShift = (HashBits + (MinMatch - 1)) DIV MinMatch; (* MinMatch bytes should have effect on hash code *) + LitBufSize = ASH(1, MemLevel + 6); (* number of elements in literal/distance buffers *) + PendingBufSize = ASH(LitBufSize, 2); (* use 64k pending buffer *) + +TYPE + (* Huffman trees *) + Node = RECORD + freqOrCode: INTEGER; (* frequency count / bit string *) + dadOrLen: INTEGER (* father node on Huffman tree / length of bit string *) + END; + Nodes = POINTER TO ARRAY OF Node; + + Bits = POINTER TO ARRAY OF INTEGER; + + StaticTree = RECORD + node: Nodes; + bits: Bits; (* extra bits for each code *) + base: INTEGER; (* base index for Bits *) + elems: INTEGER; (* max number of elements in the tree *) + maxLength: INTEGER (* max bit length for the codes *) + END; + + Tree = RECORD + node: Nodes; (* dynamic tree *) + maxCode: INTEGER; (* largest code with non-zero frequency *) + static: StaticTree (* corresponding static tree *) + END; + + Window = ARRAY 2 * WindowSize OF CHAR; (* double size to keep full dictionary at all times; input is read into upper half *) + + PendingBuffer = RECORD + buf: POINTER TO ARRAY PendingBufSize OF CHAR; (* memory for pending buffer *) + beg: LONGINT; (* next pending byte to write to output buffer *) + end: LONGINT (* next pending byte in pending buffer *) + END; + + (** deflate stream **) + Stream* = RECORD + in*, out*: ZlibBuffers.Buffer; + res-: LONGINT; (** result of last operation **) + level-: SHORTINT; (** compression level **) + strategy-: SHORTINT; (**compression strategy **) + dataType-: SHORTINT; (** Unknown, Binary or Ascii **) + wrapper-: BOOLEAN; (** if set, zlib header and checksum are generated **) + open-: BOOLEAN; (** if set, stream is initialized **) + trailerDone: BOOLEAN; (* if set, the zlib trailer has already been generated *) + lastFlush: SHORTINT; (* flush operation of the previous deflate call *) + status: SHORTINT; (* current stream state *) + adler: LONGINT; (* Adler32 checksum *) + + window: POINTER TO Window; (* memory for sliding window *) + block: LONGINT; (* position in window where current block starts (negative if window moved) *) + hash: LONGINT; (* hash index of string to insert *) + prev: POINTER TO ARRAY WindowSize OF LONGINT; (* link to older string with same hash code (for last 32k strings) *) + head: POINTER TO ARRAY HashSize OF LONGINT; (* heads of hash chains for every window position *) + string: LONGINT; (* start of string to insert *) + lookAhead: LONGINT; (* number of valid bytes ahead in window *) + match: LONGINT; (* start of match string *) + matchLen: LONGINT; (* length of best match *) + prevMatch: LONGINT; (* start of previous match *) + prevLen: LONGINT; (* length of best match at previous step *) + prevAvail: BOOLEAN; (* set if previous match exists *) + pend: PendingBuffer; + + (* trees *) + ltree, dtree, btree: Tree; (* trees for literals/lengths, distances and bit lengths *) + lnode, dnode, bnode: Nodes; (* corresponding nodes *) + bitLenCount: ARRAY MaxBits + 1 OF INTEGER; (* number of codes at each bit length for optimal tree *) + heap: ARRAY HeapSize OF INTEGER; (* heap used to build Huffman tree *) + heapLen: INTEGER; (* number of elements in the heap *) + heapMax: INTEGER; (* heap element of largest frequency *) + depth: ARRAY HeapSize OF INTEGER; (* depth of each subtree for deciding between trees of equal frequency *) + lbuf: POINTER TO ARRAY LitBufSize OF CHAR; (* buffer for literals/lengths *) + dbuf: POINTER TO ARRAY LitBufSize OF INTEGER; (* buffer for distances *) + lastLit: LONGINT; (* running index in lbuf *) + buf: LONGINT; (* bit buffer *) + bits: INTEGER; (* number of valid bits in bit buffer *) + lastEobLen: INTEGER; (* bit length of End Of Block code for last block *) + optLen: LONGINT; (* bit length of current block with optimal trees *) + staticLen: LONGINT; (* bit length of current block with static trees *) + END; + + Compressor = PROCEDURE (VAR s: Stream; flush: SHORTINT): SHORTINT; + +VAR + ExtraLenBits, ExtraDistBits, ExtraBitBits: Bits; + LTree, DTree, BTree: StaticTree; + BaseLength: ARRAY LengthCodes OF INTEGER; + BaseDist: ARRAY DistCodes OF INTEGER; + LengthCode: ARRAY MaxMatch - MinMatch + 1 OF CHAR; + DistCode: ARRAY DistCodeLen OF CHAR; + BitOrder: ARRAY BitCodes OF SHORTINT; + ConfigTable: ARRAY 10 OF RECORD + GoodLen: INTEGER; (* reduce lazy search above this match length *) + MaxLazy: INTEGER; (* do not perform lazy search above this match length *) + NiceLen: INTEGER; (* quit search above this match length *) + MaxChain: INTEGER; (* maximal number of hash entries considered *) + Compress: Compressor; (* block compress procedure *) + END; + + +(* Put a byte c in the pending buffer *) +PROCEDURE PutChar(VAR pend: PendingBuffer; c: CHAR); +BEGIN + pend.buf[pend.end] := c; + INC(pend.end) +END PutChar; + +(* Put the 16 LSB of b in LSB order in the pending buffer *) +PROCEDURE Put16BitsLSB(VAR pend: PendingBuffer; b: LONGINT); +BEGIN + PutChar(pend, CHR(b MOD 100H)); + PutChar(pend, CHR((b DIV 100H) MOD 100H)) +END Put16BitsLSB; + +(* Put the 16 LSB of b in MSB order in the pending buffer *) +PROCEDURE Put16BitsMSB(VAR pend: PendingBuffer; b: LONGINT); +BEGIN + PutChar(pend, CHR((b DIV 100H) MOD 100H)); + PutChar(pend, CHR(b MOD 100H)) +END Put16BitsMSB; + +(* Put the 32 LSB of b in MSB order in the pending buffer *) +PROCEDURE Put32BitsMSB(VAR pend: PendingBuffer; b: LONGINT); +BEGIN + Put16BitsMSB(pend, (b DIV 10000H) MOD 10000H); + Put16BitsMSB(pend, b MOD 10000H) +END Put32BitsMSB; + +(* Reverse the first len bits of a code, using straightforward code *) +PROCEDURE ReverseBits(code, len: INTEGER): INTEGER; +VAR + res: INTEGER; +BEGIN + res := 0; + REPEAT + res := res * 2; INC(res, code MOD 2); + code := code DIV 2; DEC(len) + UNTIL len = 0; + RETURN res +END ReverseBits; + +(* Send a value on a given number of bits *) +PROCEDURE SendBits(VAR stream: Stream; val: LONGINT; len: INTEGER); +BEGIN + INC(stream.buf, ASH(val, stream.bits)); INC(stream.bits, len); + IF stream.bits > BitBufSize THEN + Put16BitsLSB(stream.pend, stream.buf); + stream.buf := SYSTEM.LSH(stream.buf, -BitBufSize); DEC(stream.bits, BitBufSize) + END +END SendBits; + +(* Send a code of the given node. c and node must not have side effects *) +PROCEDURE SendCode(VAR stream: Stream; VAR node: Node); +BEGIN + SendBits(stream, node.freqOrCode, node.dadOrLen) +END SendCode; + +(* Flush the bit buffer, keeping at most 7 bits in it *) +PROCEDURE FlushBits(VAR stream: Stream); +BEGIN + IF stream.bits = BitBufSize THEN + Put16BitsLSB(stream.pend, stream.buf); + stream.buf := 0; stream.bits := 0 + ELSIF stream.bits >= 8 THEN + PutChar(stream.pend, CHR(stream.buf)); + stream.buf := SYSTEM.LSH(stream.buf, -8); DEC(stream.bits, 8) + END +END FlushBits; + +(* Flush as much pending output as possible. *) +PROCEDURE FlushPending(VAR pend: PendingBuffer; VAR out: ZlibBuffers.Buffer); +VAR + len: LONGINT; +BEGIN + len := pend.end - pend.beg; + IF len > out.avail THEN len := out.avail END; + IF len > 0 THEN + ZlibBuffers.WriteBytes(out, pend.buf^, pend.beg, len); + INC(pend.beg, len); + IF pend.beg = pend.end THEN + pend.beg := 0; pend.end := 0 + END + END +END FlushPending; + +(* Flush the bit buffer and align the output on a byte boundary *) +PROCEDURE WindupBits(VAR stream: Stream); +BEGIN + IF stream.bits > 8 THEN + Put16BitsLSB(stream.pend, stream.buf) + ELSIF stream.bits > 0 THEN + PutChar(stream.pend, CHR(stream.buf)) + END; + stream.buf := 0; stream.bits := 0 +END WindupBits; + +(* Set data type to ASCII or Binary, using a crude heuristic: Binary if more than 20% of the bytes are <= 6 or >= 128, ASCII otherwise *) +PROCEDURE SetDataType(VAR stream: Stream); +VAR + n, ascii, bin: LONGINT; +BEGIN + WHILE n < 7 DO INC(bin, LONG(stream.lnode[n].freqOrCode)); INC(n) END; + WHILE n < 128 DO INC(ascii, LONG(stream.lnode[n].freqOrCode)); INC(n) END; + WHILE n < Literals DO INC(bin, LONG(stream.lnode[n].freqOrCode)); INC(n) END; + IF (4 * bin) > ascii THEN stream.dataType := Binary ELSE stream.dataType := Ascii END +END SetDataType; + +(* Generate the codes for a given tree and bit counts (which need not to be optimal) *) +PROCEDURE GenCodes(VAR node: Nodes; maxCode: INTEGER; VAR count: ARRAY OF INTEGER); +VAR + nextCode: ARRAY MaxBits + 1 OF INTEGER; (* next code value for each bit length *) + code, bits, n, len : INTEGER; +BEGIN + code := 0; + FOR bits := 1 TO MaxBits DO + code := SHORT(ASH(code + count[bits - 1], 1)); + nextCode[bits] := code + END; + ASSERT(code + count[MaxBits] - 1 = ASH(1, MaxBits) - 1, 110); (* inconsistent bit counts *) + FOR n := 0 TO maxCode DO + len := node[n].dadOrLen; + IF len # 0 THEN + node[n].freqOrCode := ReverseBits(nextCode[len], len); INC(nextCode[len]) + END + END +END GenCodes; + +(* Compute optimal bit lengths for a tree and update the total bit length for the current block *) +PROCEDURE GenBitLen(VAR stream: Stream; VAR tree: Tree); +VAR + node: Nodes; + stree: StaticTree; + bits, h, n, m, overflow, xbits : INTEGER; + freq: LONGINT; +BEGIN + node := tree.node; + stree := tree.static; + overflow := 0; + FOR bits := 0 TO MaxBits DO stream.bitLenCount[bits] := 0 END; + (* compute optimal bit lengths *) + node[stream.heap[stream.heapMax]].dadOrLen := 0; (* root of heap *) + FOR h := stream.heapMax + 1 TO HeapSize - 1 DO + n := stream.heap[h]; + bits := node[node[n].dadOrLen].dadOrLen + 1; + IF bits > stree.maxLength THEN + bits := stree.maxLength; INC(overflow) + END; + node[n].dadOrLen := bits; (* replace dad with len information *) + IF n <= tree.maxCode THEN (* leaf node *) + INC(stream.bitLenCount[bits]); + IF n >= stree.base THEN xbits := stree.bits[n - stree.base] ELSE xbits := 0 END; + freq := node[n].freqOrCode; + INC(stream.optLen, freq * (bits + xbits)); + IF stree.node # NIL THEN INC(stream.staticLen, freq * (stree.node[n].dadOrLen + xbits)) END + END + END; + + IF overflow # 0 THEN + (* find first bit length which could increase *) + REPEAT + bits := stree.maxLength - 1; + WHILE stream.bitLenCount[bits] = 0 DO DEC(bits) END; + DEC(stream.bitLenCount[bits]); (* move one leaf down the tree *) + INC(stream.bitLenCount[bits + 1], 2); (* move one overflow item as its brother *) + DEC(stream.bitLenCount[stree.maxLength]); DEC(overflow, 2) + UNTIL overflow <= 0; + + (* recompute all bit lengths, scanning in increasing frequency *) + bits := stree.maxLength; + WHILE bits > 0 DO + n := stream.bitLenCount[bits]; + WHILE n # 0 DO + DEC(h); m := stream.heap[h]; + IF m <= tree.maxCode THEN + IF node[m].dadOrLen # bits THEN + INC(stream.optLen, (bits - node[m].dadOrLen) * LONG(node[m].freqOrCode)); + node[m].dadOrLen := bits + END; + DEC(n) + END + END; + DEC(bits) + END + END +END GenBitLen; + +(* Restore heap property by moving down the tree starting at node k, exchanging a node with smallest child if necessary, + stopping when heap property is re-established (each father smaller than its two children *) +PROCEDURE Sift(VAR stream: Stream; VAR node: Nodes; k: INTEGER); +VAR + v, i: INTEGER; + + (* Compare subtrees, using tree depth as tie breaker when subtrees have equal frequency -> minimizes worst case length *) + PROCEDURE Smaller(n, m: INTEGER): BOOLEAN; + BEGIN + RETURN (node[n].freqOrCode < node[m].freqOrCode) OR + ((node[n].freqOrCode = node[m].freqOrCode) & (stream.depth[n] <= stream.depth[m])) + END Smaller; + +BEGIN + v := stream.heap[k]; + i := k * 2; (* left child of k *) + WHILE (i <= stream.heapLen) DO + IF (i < stream.heapLen) & Smaller(stream.heap[i + 1], stream.heap[i]) THEN INC(i) END; (* i: smallest child *) + IF Smaller(v, stream.heap[i]) THEN + stream.heap[k] := v; RETURN + ELSE + stream.heap[k] := stream.heap[i]; k := i; (* exchange v with smallest child *) + i := i * 2 (* set j to the left child of k *) + END + END; + stream.heap[k] := v +END Sift; + +(* Construct one Huffman tree and assign the code bit strings and lengths. Update the total bit length for the current block. + IN assertion: field freqOrCode is set for all tree elements + OUT assertions: the fields dadOrLen and freqOrCode are set to the optimal bit length and corresponding code. + The stream.optLen is updated; stream.staticLen is also updated if snode is not null. The field maxCode is set. *) +PROCEDURE BuildTree(VAR stream: Stream; VAR tree: Tree); +VAR + node: Nodes; + stree: StaticTree; + n, m, maxCode, next: INTEGER; +BEGIN + node := tree.node; stree := tree.static; maxCode := -1; + + (* construct initial heap *) + stream.heapLen := 0; stream.heapMax := HeapSize; + FOR n := 0 TO stree.elems - 1 DO + IF node[n].freqOrCode # 0 THEN + maxCode := n; + INC(stream.heapLen); stream.heap[stream.heapLen] := n; + stream.depth[n] := 0 + ELSE + node[n].dadOrLen := 0 + END + END; + + (* force at least two codes of non zero frequency in order to be compliant with pkzip format *) + WHILE stream.heapLen < 2 DO + INC(stream.heapLen); + IF maxCode < 2 THEN INC(maxCode); n := maxCode ELSE n := 0 END; + stream.heap[stream.heapLen] := n; + node[n].freqOrCode := 1; + stream.depth[n] := 0; + DEC(stream.optLen); + IF stree.node # NIL THEN DEC(stream.staticLen, LONG(stree.node[n].dadOrLen)) END; (* n IN {0, 1}, thus no extra bits *) + END; + tree.maxCode := maxCode; + + (* build heap *) + FOR n := stream.heapLen DIV 2 TO 1 BY -1 DO + Sift(stream, node, n) + END; + + (* construct Huffman tree by repeatedly combining the least two frequent nodes *) + next := stree.elems; + REPEAT + n := stream.heap[1]; + stream.heap[1] := stream.heap[stream.heapLen]; + DEC(stream.heapLen); + Sift(stream, node, 1); + m := stream.heap[1]; (* n: node of least frequency; m: node of next least frequency *) + DEC(stream.heapMax); stream.heap[stream.heapMax] := n; (* keep the nodes sorted by frequency *) + DEC(stream.heapMax); stream.heap[stream.heapMax] := m; + node[next].freqOrCode := node[n].freqOrCode + node[m].freqOrCode; (* create a new father of n and m *) + IF stream.depth[n] > stream.depth[m] THEN stream.depth[next] := stream.depth[n] + 1 + ELSE stream.depth[next] := stream.depth[m] + 1 + END; + node[n].dadOrLen := next; node[m].dadOrLen := next; + (* and insert the new node in the heap *) + stream.heap[1] := next; INC(next); + Sift(stream, node, 1); + UNTIL stream.heapLen < 2; + DEC(stream.heapMax); stream.heap[stream.heapMax] := stream.heap[1]; + (* field freqOrCode and dadOrLen are set -> generate bit lengths *) + GenBitLen(stream, tree); + (* field dadOrLen is set -> generate bit codes *) + GenCodes(node, maxCode, stream.bitLenCount) +END BuildTree; + +(* Scan a literal or distance tree to determine the frequencies of the codes in the bit length tree. *) +PROCEDURE ScanTree(VAR stream: Stream; node: Nodes; max: INTEGER); +VAR + n, prevLen, curLen, nextLen, count, maxCount, minCount: INTEGER; +BEGIN + prevLen := -1; nextLen := node[0].dadOrLen; count := 0; + IF nextLen = 0 THEN maxCount := 138; minCount := 3 + ELSE maxCount := 7; minCount := 4 + END; + node[max + 1].dadOrLen := MAX(INTEGER); (* sentinel *) + FOR n := 0 TO max DO + curLen := nextLen; nextLen := node[n + 1].dadOrLen; + INC(count); + IF (count >= maxCount) OR (curLen # nextLen) THEN + IF count < minCount THEN + INC(stream.bnode[curLen].freqOrCode, count); + ELSIF curLen # 0 THEN + IF curLen # prevLen THEN INC(stream.bnode[curLen].freqOrCode) END; + INC(stream.bnode[Rep3To6].freqOrCode) + ELSIF count <= 10 THEN + INC(stream.bnode[RepZero3To10].freqOrCode) + ELSE + INC(stream.bnode[RepZero11To138].freqOrCode) + END; + count := 0; prevLen := curLen; + IF nextLen = 0 THEN maxCount := 138; minCount := 3 + ELSIF curLen = nextLen THEN maxCount := 6; minCount := 3 + ELSE maxCount := 7; minCount := 4 + END + END + END +END ScanTree; + +(* Construct the Huffman tree for the bit lengths and return the index in BitOrder of the last bit length code to send. *) +PROCEDURE BuildBitLenTree(VAR stream: Stream): INTEGER; +VAR + max: INTEGER; (* index of last bit length code of non zero frequency *) +BEGIN + (* determine the bit length frequencies for literal and distance trees *) + ScanTree(stream, stream.ltree.node, stream.ltree.maxCode); + ScanTree(stream, stream.dtree.node, stream.dtree.maxCode); + BuildTree(stream, stream.btree); (* build bit length tree *) + (* stream.optLen now includes the length of the tree representations, except the lengths of the bit lengths codes + and the 5 + 5 + 4 bits for the count *) + (* determine the number of bit length codes to send; the pkzip format requires that at least 4 bit length codes to be sent *) + max := BitCodes - 1; + WHILE (max >= 3) & (stream.bnode[BitOrder[max]].dadOrLen = 0) DO DEC(max) END; + (* update stream.optLen to include the bit length tree and counts *) + INC(stream.optLen, LONG(3 * (max + 1) + 5 + 5 + 4)); + RETURN max +END BuildBitLenTree; + +(* Send a literal or distance tree in compressed form, using the codes in stream.bnode. + tree: the tree to be scanned; max: its largest code of non zero frequency *) +PROCEDURE SendTree(VAR stream: Stream; node: Nodes; max: INTEGER); +VAR + n, prevLen, curLen, nextLen, count, maxCount, minCount: INTEGER; +BEGIN + prevLen := -1; nextLen := node[0].dadOrLen; count := 0; + IF nextLen = 0 THEN maxCount := 138; minCount := 3 + ELSE maxCount := 7; minCount := 4 END; + node[max + 1].dadOrLen := MAX(INTEGER); (* sentinel *) + FOR n := 0 TO max DO + curLen := nextLen; nextLen := node[n + 1].dadOrLen; + INC(count); + IF (count >= maxCount) OR (curLen # nextLen) THEN + IF count < minCount THEN + REPEAT + SendCode(stream, stream.bnode[curLen]); + DEC(count) + UNTIL count = 0 + ELSIF curLen # 0 THEN + IF curLen # prevLen THEN + SendCode(stream, stream.bnode[curLen]); DEC(count) + END; + ASSERT((3 <= count) & (count <= 6), 110); + SendCode(stream, stream.bnode[Rep3To6]); SendBits(stream, count - 3, 2) + ELSIF count <= 10 THEN + SendCode(stream, stream.bnode[RepZero3To10]); SendBits(stream, count - 3, 3) + ELSE + SendCode(stream, stream.bnode[RepZero11To138]); SendBits(stream, count - 11, 7) + END; + count := 0; prevLen := curLen; + IF nextLen = 0 THEN maxCount := 138; minCount := 3 + ELSIF curLen = nextLen THEN maxCount := 6; minCount := 3 + ELSE maxCount := 7; minCount := 4 + END + END + END +END SendTree; + +(* Send the header for a block using dynamic Huffman trees: the counts, the lengths of the bit length codes, the literal tree + and the distance tree. + lcodes, dcodes, blcodes: number of codes for each tree *) +PROCEDURE SendAllTrees(VAR stream: Stream; lcodes, dcodes, blcodes: INTEGER); +VAR + rank: INTEGER; (* index in BitOrder *) +BEGIN + ASSERT((lcodes >= 257) & (dcodes >= 1) & (blcodes >= 4), 100); (* not enough codes *) + ASSERT((lcodes <= LitLenCodes) & (dcodes <= DistCodes) & (blcodes <= BitCodes), 101); (* too many codes *) + SendBits(stream, lcodes - 257, 5); SendBits(stream, dcodes - 1, 5); SendBits(stream, blcodes - 4, 4); + FOR rank := 0 TO blcodes - 1 DO + SendBits(stream, stream.bnode[BitOrder[rank]].dadOrLen, 3) + END; + SendTree(stream, stream.lnode, lcodes - 1); (* literal tree *) + SendTree(stream, stream.dnode, dcodes - 1) (* distance tree *) +END SendAllTrees; + +(* Initialize the various constant tables *) +PROCEDURE InitStaticTrees(); +VAR + n, code: LONGINT; + length, dist: INTEGER; + count: ARRAY MaxBits + 1 OF INTEGER; (* number of codes at each bit length for an optimal tree *) +BEGIN + NEW(ExtraLenBits, LengthCodes); + FOR n := 0 TO 3 DO ExtraLenBits[n] := 0 END; + FOR n := 4 TO LengthCodes - 2 DO ExtraLenBits[n] := SHORT((n - 4) DIV 4) END; + ExtraLenBits[LengthCodes - 1] := 0; + + NEW(ExtraDistBits, DistCodes); + FOR n := 0 TO 1 DO ExtraDistBits[n] := 0 END; + FOR n := 2 TO DistCodes - 1 DO ExtraDistBits[n] := SHORT((n - 2) DIV 2) END; + + NEW(ExtraBitBits, BitCodes); + FOR n := 0 TO BitCodes - 4 DO ExtraBitBits[n] := 0 END; + ExtraBitBits[BitCodes - 3] := 2; ExtraBitBits[BitCodes - 2] := 3; ExtraBitBits[BitCodes - 1] := 7; + + BitOrder[0] := 16; BitOrder[1] := 17; BitOrder[2] := 18; BitOrder[3] := 0; BitOrder[4] := 8; BitOrder[5] := 7; BitOrder[6] := 9; + BitOrder[7] := 6; BitOrder[8] := 10; BitOrder[9] := 5; BitOrder[10] := 11; BitOrder[11] := 4; BitOrder[12] := 12; BitOrder[13] := 3; + BitOrder[14] := 13; BitOrder[15] := 2; BitOrder[16] := 14; BitOrder[17] := 1; BitOrder[18] := 15; + + (* initialize the mapping length (0..255) -> length code (0..28) *) + length := 0; + FOR code := 0 TO LengthCodes - 2 DO + BaseLength[code] := length; + FOR n := 0 TO ASH(1, ExtraLenBits[code]) - 1 DO + LengthCode[length] := CHR(code); INC(length) + END + END; + ASSERT(length = 256, 110); + (* Note that length code 255 (match length 258) can be represented in two different ways: code 284 + 5 bits or code 285, + so we overwrite LengthCode[255] to use the best encoding: *) + LengthCode[length - 1] := CHR(code); + + (* initialize the mapping dist (0..32K) -> dist code (0..29) *) + dist := 0; + FOR code := 0 TO 15 DO + BaseDist[code] := dist; + FOR n := 0 TO ASH(1, ExtraDistBits[code]) - 1 DO + DistCode[dist] := CHR(code); INC(dist) + END + END; + ASSERT(dist = 256, 111); + + dist := SHORT(ASH(dist, -7)); (* from now on, all distances are divided by 128 *) + FOR code := 16 TO DistCodes - 1 DO + BaseDist[code] := SHORT(ASH(dist, 7)); + FOR n := 0 TO ASH(1, ExtraDistBits[code] - 7) - 1 DO + DistCode[256 + dist] := CHR(code); INC(dist) + END + END; + ASSERT(dist = 256, 112); + + (* construct the codes of the static literal tree *) + NEW(LTree.node, LitLenCodes + 2); + LTree.bits := ExtraLenBits; LTree.base := Literals + 1; LTree.elems := LitLenCodes; LTree.maxLength := MaxBits; + FOR n := 0 TO MaxBits DO count[n] := 0 END; + FOR n := 0 TO 143 DO LTree.node[n].dadOrLen := 8 END; INC(count[8], 143 - (-1)); + FOR n := 144 TO 255 DO LTree.node[n].dadOrLen := 9 END; INC(count[9], 255 - 143); + FOR n := 256 TO 279 DO LTree.node[n].dadOrLen := 7 END; INC(count[7], 279 - 255); + FOR n := 280 TO 287 DO LTree.node[n].dadOrLen := 8 END; INC(count[8], 287 - 279); + (* codes 286 and 287 do not exist, but we must include them in the tree construction to get a canonical Huffman tree + (longest code all ones) *) + GenCodes(LTree.node, LitLenCodes + 1, count); + + (* construct the codes of the static distance tree (trivial) *) + NEW(DTree.node, DistCodes); + DTree.bits := ExtraDistBits; DTree.base := 0; DTree.elems := DistCodes; DTree.maxLength := MaxBits; + FOR n := 0 TO DistCodes - 1 DO + DTree.node[n].dadOrLen := 5; + DTree.node[n].freqOrCode := ReverseBits(SHORT(n), 5) + END; + + BTree.node := NIL; + BTree.bits := ExtraBitBits; BTree.base := 0; BTree.elems := BitCodes; BTree.maxLength := MaxBitLenBits; +END InitStaticTrees; + +(* Initialize a new block *) +PROCEDURE InitBlock(VAR stream: Stream); +VAR + n: LONGINT; (* iterates over tree elements *) +BEGIN + FOR n := 0 TO LitLenCodes - 1 DO stream.lnode[n].freqOrCode := 0 END; + FOR n := 0 TO DistCodes - 1 DO stream.dnode[n].freqOrCode := 0 END; + FOR n := 0 TO BitCodes - 1 DO stream.bnode[n].freqOrCode := 0 END; + stream.lnode[EndBlock].freqOrCode := 1; + stream.optLen := 0; stream.staticLen := 0; + stream.lastLit := 0 +END InitBlock; + +(* Initialize the tree data structures for a new zlib stream *) +PROCEDURE InitTrees(VAR stream: Stream); +BEGIN + NEW(stream.lnode, HeapSize); NEW(stream.dnode, 2 * DistCodes + 1); NEW(stream.bnode, 2 * BitCodes + 1); + stream.ltree.node := stream.lnode; stream.dtree.node := stream.dnode; stream.btree.node := stream.bnode; + stream.ltree.static := LTree; stream.dtree.static := DTree; stream.btree.static := BTree; + stream.buf := 0; stream.bits := 0; stream.lastEobLen := 8; (* enough lookahead for inflate *) + InitBlock(stream) +END InitTrees; + +PROCEDURE FreeTrees(VAR stream: Stream); +BEGIN + stream.lnode := NIL; stream.dnode := NIL; stream.bnode := NIL +END FreeTrees; + +(* Send one empty static block to give enough lookahead for inflate. This takes 10 bits, of which 7 may remain in the bit buffer. + The current inflate code requires 9 bits of lookahead. If the last two codes for the previous block (real code plus end of block) + were coded on 5 bits or less, inflate may have only 5 + 3 bits of lookahead to decode the las real code. + In this case we send two empty static blocks instead of one. (There are no problems if the previous block is stored or fixed.) + To simplify the code, we assume the worst case of last real code encoded on one bit only *) +PROCEDURE AlignTrees(VAR stream: Stream); +BEGIN + SendBits(stream, SHORT(ASH(StaticTrees, 1)), 3); + SendCode(stream, LTree.node[EndBlock]); + FlushBits(stream); + (* Of the 10 bits for the empty block, we have already sent (10 - stream.bits) bits. The lookahead for the last real code + (before end of block of the previous block) was thus at least one plus the length of the end of block what we have + just sent of the empty static block. *) + IF (1 + stream.lastEobLen + 10 - stream.bits) < 9 THEN + SendBits(stream, SHORT(ASH(StaticTrees, 1)), 3); + SendCode(stream, LTree.node[EndBlock]); + FlushBits(stream) + END; + stream.lastEobLen := 7 +END AlignTrees; + +(* Copy a stored block, storing first the length and its one's complement if requested *) +PROCEDURE CopyBlock(VAR stream: Stream; VAR buf: ARRAY OF CHAR; offset, len: LONGINT; header: BOOLEAN); +VAR +BEGIN + WindupBits(stream); (* align on byte boundary *) + stream.lastEobLen := 8; (* enough lookahead for inflate *) + IF header THEN + Put16BitsLSB(stream.pend, len); (* LEN *) + Put16BitsLSB(stream.pend, -(len + 1)); (* NLEN (1's complement of LEN) *) + END; + WHILE len > 0 DO + PutChar(stream.pend, buf[offset]); + INC(offset); DEC(len) + END +END CopyBlock; + +(* Send a stored block *) +PROCEDURE StoreBlock(VAR stream: Stream; VAR buf: ARRAY OF CHAR; offset, len: LONGINT; eof: BOOLEAN); +VAR + value: LONGINT; +BEGIN + value := ASH(StoredBlock, 1); + IF eof THEN INC(value) END; + SendBits(stream, value, 3); (* send block type *) + CopyBlock(stream, buf, offset, len, TRUE); (* with header *) +END StoreBlock; + +(* Send the block data compressed using the given Huffman trees *) +PROCEDURE CompressBlock(VAR stream: Stream; lnode, dnode: Nodes); +VAR + dist: INTEGER; (* distance of matched string *) + lc: INTEGER; (* match length or unmatched char (if dist = 0) *) + code: INTEGER; (* the code to send *) + extra: INTEGER; (* number of extra bits to send *) + lx: LONGINT; (* running index in lbuf and dbuf *) +BEGIN + IF stream.lastLit # 0 THEN + lx := 0; + REPEAT + dist := stream.dbuf[lx]; + lc := ORD(stream.lbuf[lx]); + INC(lx); + IF dist = 0 THEN + SendCode(stream, lnode[lc]); (* send a literal byte *) + ELSE (* lc is (match length - MinMatch) *) + code := ORD(LengthCode[lc]); + SendCode(stream, lnode[code + Literals + 1]); (* send length code *) + extra := ExtraLenBits[code]; + IF extra # 0 THEN + DEC(lc, BaseLength[code]); + SendBits(stream, lc, extra) + END; + DEC(dist); (* dist is now (match distance - 1) *) + IF dist < 256 THEN code := ORD(DistCode[dist]); + ELSE code := ORD(DistCode[256 + ASH(dist, -7)]) + END; + ASSERT(code < DistCodes, 110); (* bad DistCode *) + SendCode(stream, dnode[code]); + extra := ExtraDistBits[code]; + IF extra # 0 THEN + DEC(dist, BaseDist[code]); + SendBits(stream, dist, extra) (* send extra distance bits *) + END + END (* literal or match pair? *) + (* no need to check for overlay consistency since we don't overlay *) + UNTIL lx = stream.lastLit + END; + SendCode(stream, lnode[EndBlock]); + stream.lastEobLen := lnode[EndBlock].dadOrLen +END CompressBlock; + +(* Flush the current block, with given end-of-file flag, determine the best encoding for the current block: + dynamic trees, static trees or store, and output the encoded block to the zip file. + buf: input block, or NULL if too old; + pos, len: position in and length of input block; + eof: true if this is the last block for a file; + IN assertion: stream.string is set to the end of the current match *) +PROCEDURE FlushBlock(VAR stream: Stream; VAR buf: ARRAY OF CHAR; pos, len: LONGINT; eof: BOOLEAN); +VAR + max: INTEGER; (* index of last bit length code of non zero freqency *) + optLen, staticLen: LONGINT; (* optLen and staticLen in bytes *) + value: LONGINT; +BEGIN + IF stream.level > 0 THEN (* build a Huffman tree unless a stored block is forced *) + IF stream.dataType = Unknown THEN SetDataType(stream) END; (* check if the file is ascii or binary *) + BuildTree(stream, stream.ltree); (* construct the literal .. *) + BuildTree(stream, stream.dtree); (* .. and the distance tree *) + (* at this point, stream.optLen and stream.staticLen are the total bit lengths of the compressed block data, + excluding tree representations *) + max := BuildBitLenTree(stream); (* build bit length tree for the above tow trees, get the index of the last bit length code *) + optLen := (stream.optLen + 3 + 7) DIV 8; + staticLen := (stream.staticLen + 3 + 7) DIV 8; + IF staticLen < optLen THEN optLen := staticLen END; + ELSE + ASSERT(pos >= 0, 110); (* lost buf *) + optLen := len + 5; + staticLen := optLen + END; + IF len + 4 <= optLen THEN (* 4: two words for the lengths *) + ASSERT(pos >= 0, 111); (* see explanation in trees.c, LitBufSize <= WindowSize avoids lost block *) + StoreBlock(stream, buf, pos, len, eof); + ELSIF staticLen = optLen THEN + value := ASH(StaticTrees, 1); + IF eof THEN INC(value) END; + SendBits(stream, value, 3); + CompressBlock(stream, LTree.node, DTree.node) + ELSE + value := ASH(DynamicTrees, 1); + IF eof THEN INC(value) END; + SendBits(stream, value, 3); + SendAllTrees(stream, stream.ltree.maxCode + 1, stream.dtree.maxCode + 1, max + 1); + CompressBlock(stream, stream.lnode, stream.dnode); + END; + InitBlock(stream); + IF eof THEN + WindupBits(stream) + END +END FlushBlock; + +(* Put a literal in the literal buffer (stream.lbuf) *) +PROCEDURE TallyLit(VAR stream: Stream; ch: CHAR): BOOLEAN; +BEGIN + stream.lbuf[stream.lastLit] := ch; + stream.dbuf[stream.lastLit] := 0; + INC(stream.lastLit); + INC(stream.lnode[ORD(ch)].freqOrCode); + RETURN (stream.lastLit = LitBufSize - 1) +END TallyLit; + +(* Put a distance/length pair in the distance and the length buffer (stream.dbuf, stream.lbuf) *) +PROCEDURE TallyDistLen(VAR stream: Stream; dist, len: INTEGER): BOOLEAN; +BEGIN + ASSERT(len < 256, 99); + stream.lbuf[stream.lastLit] := CHR(len); + stream.dbuf[stream.lastLit] := dist; + INC(stream.lastLit); + DEC(dist); + INC(stream.lnode[ORD(LengthCode[len]) + Literals + 1].freqOrCode); + IF dist < 256 THEN dist := ORD(DistCode[dist]) + ELSE dist := ORD(DistCode[256 + ASH(dist, -7)]) + END; + INC(stream.dnode[dist].freqOrCode); + RETURN (stream.lastLit = LitBufSize - 1) +END TallyDistLen; + +(*---Matches---*) + +PROCEDURE ClearHash(VAR stream: Stream); +VAR + i: LONGINT; +BEGIN + FOR i := 0 TO HashSize - 1 DO + stream.head[i] := 0 + END +END ClearHash; + +(* Update a hash value with the given input byte + IN assertion: all calls are made with consecutive input characters, so that a running hash key can be computed + from the previous key instead of complete recalculation each time *) +PROCEDURE UpdateHash(VAR h: LONGINT; ch: CHAR); +BEGIN + h := SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET, ASH(h, HashShift)) / SYSTEM.VAL(SET, LONG(ORD(ch)))) MOD HashSize +END UpdateHash; + +(* Insert string starting at position pos in the dictionary and set head to the previous head of the hash chain + (the most recent string with the same hash key). Return the previous length of the hash chain. + IN assertion: all calls are made with consecutive input characters and the first MinMatch bytes at pos are valid + (except for the last MinMatch - 1 bytes of the input file *) +PROCEDURE InsertString(VAR stream: Stream; pos: LONGINT; VAR head: LONGINT); +BEGIN + UpdateHash(stream.hash, stream.window[pos + MinMatch - 1]); + head := stream.head[stream.hash]; + stream.prev[pos MOD WindowSize] := head; + stream.head[stream.hash] := pos +END InsertString; + +(* initialize the "longes match" routines for a new zlib stream *) +PROCEDURE InitMatches(VAR stream: Stream); +BEGIN + ClearHash(stream); + stream.string := 0; stream.block := 0; stream.lookAhead := 0; + stream.matchLen := MinMatch - 1; stream.prevLen := MinMatch - 1; + stream.prevAvail := FALSE; stream.hash := 0; +END InitMatches; + +(* Set stream.match to the longest match starting at the given string and return its length. + Matches shorter or equal to stream.prevLen are discarded, in which case the result is equal to stream.prevLen + and stream.match is garbage. + IN assertion: cur is the head of the hash chain for the current string (stream.string) and its distance is <= MaxDist, + and stream.prevLen >= 1. + OUT assertion: the match length is not greater than stream.lookAhead. *) +PROCEDURE LongestMatch(VAR stream: Stream; cur: LONGINT): LONGINT; +VAR + chainLen: LONGINT; (* max hash chain length *) + scan: LONGINT; (* current string *) + match: LONGINT; (* matched string *) + len: LONGINT; (* length of current match *) + bestLen: LONGINT; (* best match so far *) + niceLen: LONGINT; (* stop if match long enough *) + limit: LONGINT; (* stop when cur becomes <= limit *) + strend: LONGINT; + scanEnd1, scanEnd: CHAR; +BEGIN + bestLen := stream.prevLen; + IF bestLen >= ConfigTable[stream.level].GoodLen THEN + chainLen := ConfigTable[stream.level].MaxChain DIV 4 (* do not waste too much time if match is already good enough *) + ELSE + chainLen := ConfigTable[stream.level].MaxChain; + END; + IF ConfigTable[stream.level].NiceLen > stream.lookAhead THEN (* do not look for matches beyond the end of the input *) + niceLen := stream.lookAhead + ELSE + niceLen := ConfigTable[stream.level].NiceLen + END; + scan := stream.string; + IF scan > MaxDist THEN limit := scan - MaxDist ELSE limit := 0 END; + strend := scan + MaxMatch; + scanEnd1 := stream.window[scan + bestLen - 1]; + scanEnd := stream.window[scan + bestLen]; + ASSERT(scan <= 2 * WindowSize - MinLookAhead, 110); (* need lookahead *) + len := -1; + REPEAT + ASSERT(cur < stream.string, 111); (* no future *) + match := cur; + + (* skip to next match if match length cannot increase or match lengtch < 2 *) + IF (stream.window[match + bestLen] = scanEnd) & (stream.window[match + bestLen - 1] = scanEnd1) & + (stream.window[match] = stream.window[scan]) & (stream.window[match + 1] = stream.window[scan + 1]) THEN + (* The check at match + bestLen - 1 can be removed because it will be made again later (this heuristic is not always a win). + It is not necessary to compare match + 2 and scan + 2 since they are always equal when the other bytes match, + given that the hash keys are equal and that HashBits >= 8 *) + INC(scan, 2); INC(match, 2); + ASSERT(stream.window[match] = stream.window[scan], 112); (* must be equal as well because hash values coincide *) + REPEAT + INC(match); INC(scan) + UNTIL (stream.window[match] # stream.window[scan]) OR (scan >= strend); + ASSERT(scan <= 2 * WindowSize - 1, 113); (* wild scan *) + len := MaxMatch - (strend - scan); + scan := strend - MaxMatch; + IF len > bestLen THEN + stream.match := cur; + bestLen := len; + scanEnd1 := stream.window[scan + bestLen - 1]; + scanEnd := stream.window[scan + bestLen] + END + END; + cur := stream.prev[cur MOD WindowSize]; + DEC(chainLen) + UNTIL (len >= niceLen) OR (cur <= limit) OR (chainLen = 0); + IF bestLen > MaxMatch THEN bestLen := MaxMatch END; (* neu *) + IF bestLen <= stream.lookAhead THEN + RETURN bestLen + ELSE + RETURN stream.lookAhead + END +END LongestMatch; + +(* Check that the match at stream.match is indeed a match *) +PROCEDURE CheckMatch(VAR stream: Stream; start, match, len: LONGINT); +BEGIN + WHILE len # 0 DO + ASSERT(stream.window[match] = stream.window[start]); + INC(match); INC(start); DEC(len) + END +END CheckMatch; + +(* Fill window when lookahead becomes insufficient. + Updates stream.string and stream.lookAhead *) +PROCEDURE FillWindow(VAR stream: Stream); +VAR + n, len: LONGINT; + more: LONGINT; (* amount of free space at the end of the window *) +BEGIN + more := 2 * WindowSize - (stream.lookAhead + stream.string); + REPEAT + IF stream.string >= WindowSize + MaxDist THEN + (* lower half is no longer available for matches -> slide window *) + SYSTEM.MOVE(SYSTEM.ADR(stream.window[WindowSize]), SYSTEM.ADR(stream.window[0]), WindowSize); + DEC(stream.match, WindowSize); DEC(stream.string, WindowSize); DEC(stream.block, WindowSize); + (* slide hash table *) + n := HashSize; + REPEAT + DEC(n); + IF stream.head[n] >= WindowSize THEN + DEC(stream.head[n], WindowSize) + ELSE + stream.head[n] := 0 + END + UNTIL n = 0; + n := WindowSize; + REPEAT + DEC(n); + IF stream.prev[n] >= WindowSize THEN + DEC(stream.prev[n], WindowSize) + ELSE + stream.prev[n] := 0 + END + UNTIL n = 0; + INC(more, WindowSize) + END; + len := stream.in.avail; + IF len = 0 THEN RETURN END; + ASSERT(more >= 2, 110); + IF len > more THEN len := more END; + ZlibBuffers.ReadBytes(stream.in, stream.window^, stream.string + stream.lookAhead, len); + IF stream.wrapper THEN + stream.adler := Zlib.Adler32(stream.adler, stream.window^, stream.string + stream.lookAhead, len); + END; + INC(stream.lookAhead, len); DEC(more, len); + (* initialize hash value now there is some input *) + IF stream.lookAhead >= MinMatch THEN + stream.hash := LONG(stream.window[stream.string]); + UpdateHash(stream.hash, stream.window[stream.string + 1]); + END + (* if the whole input has less than MinMatch bytes, stream.hash is garbage, + but this is not important since only literal bytes will be emitted *) + UNTIL (stream.lookAhead >= MinLookAhead) OR (stream.in.avail = 0) +END FillWindow; + +(*---Compressor Methods---*) + +(* store without compression as much as possible from the input stream, return the current block state. + This function does not insert new strings in the dictionary since uncompressible data is probably not useful. *) +PROCEDURE CompressStored(VAR stream: Stream; flush: SHORTINT): SHORTINT; +CONST + MaxBlockSize = PendingBufSize - 5; (* header for stored block takes 5 bytes *) +BEGIN + (* MaxBlockSize is the minimum of the maximal block size of 0FFFFH and the size of the pending buffer minus 5 bytes for + the block header. For MemLevel <= 8, PendingBufSize - 5 < 0FFFFH! *) + ASSERT(PendingBufSize - 5 < 0FFFFH, 110); + LOOP + (* fill the window as much as possible *) + IF stream.lookAhead <= 1 THEN + ASSERT((stream.string < (WindowSize + MaxDist)) OR (stream.block >= WindowSize), 111); (* slide too late *) + FillWindow(stream); + IF stream.lookAhead = 0 THEN + IF flush = NoFlush THEN RETURN NeedMore + ELSE EXIT (* flush the current block *) + END + END + END; + ASSERT(stream.block >= 0, 112); (* block gone *) + INC(stream.string, stream.lookAhead); + stream.lookAhead := 0; + + (* zlib flushes the block if the pending buffer will be full. With MemLevel = 8 and WindowBits = 15 this is impossible + since MaxBlockSize is almost twice the window size *) + ASSERT(stream.string < stream.block + MaxBlockSize, 113); + + (* flush if we may have to slide, otherwise stream.block may become negative and the data will be lost *) + IF (stream.string - stream.block) >= MaxDist THEN + FlushBlock(stream, stream.window^, stream.block, stream.string - stream.block, FALSE); + stream.block := stream.string; + FlushPending(stream.pend, stream.out); + IF stream.out.avail = 0 THEN RETURN NeedMore + END + END + END; + FlushBlock(stream, stream.window^, stream.block, stream.string - stream.block, flush = Finish); + stream.block := stream.string; + FlushPending(stream.pend, stream.out); + IF (stream.out.avail = 0) & (flush = Finish) THEN RETURN FinishStarted + ELSIF stream.out.avail = 0 THEN RETURN NeedMore + ELSIF flush = Finish THEN RETURN FinishDone + ELSE RETURN BlockDone + END +END CompressStored; + +(* Compress without lazy matches. + This function inserts new strings in the dictionary only for unmatched strings or for short matches. *) +PROCEDURE CompressFast(VAR stream: Stream; flush: SHORTINT): SHORTINT; +VAR + head: LONGINT; (* head of the hash chain *) + mustFlush: BOOLEAN; (* set if current block must be flushed *) +BEGIN + head := 0; + LOOP + (* make sure that we always have enough lookahead, except at the end of the input file. + We need MaxMatch bytes for the next match, plus MinMatch bytes to insert the string following the next match *) + IF stream.lookAhead < MinLookAhead THEN + FillWindow(stream); + IF (stream.lookAhead < MinLookAhead) & (flush = NoFlush) THEN RETURN NeedMore + ELSIF stream.lookAhead = 0 THEN EXIT (* flush the current block *) + END + END; + (* Insert the string window[stream.string .. stream.string + 2] in the dictionary, + and set stream.hash to the head of the hash chain *) + IF stream.lookAhead >= MinMatch THEN + InsertString(stream, stream.string, head) + END; + (* Find the longest match, discarding those <= prevLen. At this point we have always matchLen < MinMatch *) + IF (head # 0) & ((stream.string - head) <= MaxDist) THEN + IF stream.strategy # HuffmanOnly THEN (* avoid matches with string at index 0, in particular with itself *) + stream.matchLen := LongestMatch(stream, head) (* LongestMatch sets match *) + END + END; + IF stream.matchLen >= MinMatch THEN + CheckMatch(stream, stream.string, stream.match, stream.matchLen); + mustFlush := TallyDistLen(stream, SHORT(stream.string - stream.match), SHORT(stream.matchLen - MinMatch)); + DEC(stream.lookAhead, stream.matchLen); + (* Insert new strings in the hash table only if the match length is not too large. + This saves time but degrades compression *) + IF (stream.matchLen <= ConfigTable[stream.level].MaxLazy) & (stream.lookAhead >= MinMatch) THEN + DEC(stream.matchLen); (* string at stream.string is already in hash table *) + REPEAT + INC(stream.string); + InsertString(stream, stream.string, head); + (* stream.string never exceeds WindowSize - MaxMatch, so there are always MinMatch bytes ahead *) + DEC(stream.matchLen) + UNTIL stream.matchLen = 0; + INC(stream.string); + ELSE + INC(stream.string, stream.matchLen); + stream.matchLen := 0; + stream.hash := ORD(stream.window[stream.string]); + UpdateHash(stream.hash, stream.window[stream.string + 1]) + (* If stream.lookAhead < MinMatch, stream.hash is garbage, + but it does not matter since it will recomputed at next Deflate call *) + END + ELSE (* no match, output a literal byte *) + mustFlush := TallyLit(stream, stream.window[stream.string]); + DEC(stream.lookAhead); + INC(stream.string) + END; + IF mustFlush THEN + FlushBlock(stream, stream.window^, stream.block, stream.string - stream.block, FALSE); + stream.block := stream.string; + FlushPending(stream.pend, stream.out); + IF stream.out.avail = 0 THEN RETURN NeedMore + END + END + END; + FlushBlock(stream, stream.window^, stream.block, stream.string - stream.block, flush = Finish); + stream.block := stream.string; + FlushPending(stream.pend, stream.out); + IF (stream.out.avail = 0) & (flush = Finish) THEN RETURN FinishStarted + ELSIF stream.out.avail = 0 THEN RETURN NeedMore + ELSIF flush = Finish THEN RETURN FinishDone + ELSE RETURN BlockDone + END +END CompressFast; + +(* Same as above, but achieves a better compression. We use lazy evaluation for matches: + a match is finally adopted only if there is no better match at the next window position *) +PROCEDURE CompressSlow(VAR stream: Stream; flush: SHORTINT): SHORTINT; +VAR + head: LONGINT; (* head of the hash chain *) + maxIns: LONGINT; + mustFlush: BOOLEAN; (* set if current block must be flushed *) +BEGIN + head := 0; + LOOP + (* make sure that we always have enough lookahead, except at the end of the input file. + We need MaxMatch bytes for the next match, plus MinMatch bytes to insert the string following the next match *) + IF stream.lookAhead < MinLookAhead THEN + FillWindow(stream); + IF (stream.lookAhead < MinLookAhead) & (flush = NoFlush) THEN RETURN NeedMore + ELSIF stream.lookAhead = 0 THEN EXIT + END + END; + (* Insert the string window[stream.string .. stream.string + 2] in the dictionary, + and set stream.hash to the head of the hash chain *) + IF stream.lookAhead >= MinMatch THEN + InsertString(stream, stream.string, head); + END; + (* Find the longest match, discarding those <= stream.prevLen *) + stream.prevLen := stream.matchLen; + stream.prevMatch := stream.match; + stream.matchLen := MinMatch - 1; + IF (head # 0) & (stream.prevLen < ConfigTable[stream.level].MaxLazy) & (stream.string - head <= MaxDist) THEN + (* avoid matches with string at index 0, in particular with itself *) + IF stream.strategy # HuffmanOnly THEN + stream.matchLen := LongestMatch(stream, head); (* LongestMatch sets stream.match *) + END; + IF (stream.matchLen <= 5) & + ((stream.strategy = Filtered) OR ((stream.matchLen = MinMatch) & ((stream.string - stream.match) > TooFar))) THEN + (* If stream.prevMatch is also MinMatch, stream.match is garbage but we will ignore the current match anyway *) + stream.matchLen := MinMatch - 1 + END + END; + + (* If there was a match at the previous step and the current match is not better, output the previous match: *) + IF (stream.prevLen >= MinMatch) & (stream.matchLen <= stream.prevLen) THEN + maxIns := stream.string + stream.lookAhead - MinMatch; (* do not insert strings in hash table beyond this *) + CheckMatch(stream, stream.string - 1, stream.prevMatch, stream.prevLen); + mustFlush := TallyDistLen(stream, SHORT(stream.string - 1 - stream.prevMatch), SHORT(stream.prevLen - MinMatch)); + + (* Insert in hash table all strings up to the end of the match. stream.string - 1 and stream.string are already inserted. + If there is not enough stream.lookAhead, the last two strings are not inserted in the hash table. *) + DEC(stream.lookAhead, stream.prevLen - 1); + DEC(stream.prevLen, 2); + REPEAT + INC(stream.string); + IF stream.string <= maxIns THEN + InsertString(stream, stream.string, head) + END; + DEC(stream.prevLen); + UNTIL stream.prevLen = 0; + stream.prevAvail := FALSE; + stream.matchLen := MinMatch - 1; + INC(stream.string); + IF mustFlush THEN + FlushBlock(stream, stream.window^, stream.block, stream.string - stream.block, FALSE); + stream.block := stream.string; + FlushPending(stream.pend, stream.out); + IF stream.out.avail = 0 THEN RETURN NeedMore + END + END + ELSIF stream.prevAvail THEN + (* If there was no match at the previous position, output a single literal. If there was a match but the current + match is longer, truncate the previous match to a single literal. *) + mustFlush := TallyLit(stream, stream.window[stream.string - 1]); + IF mustFlush THEN + FlushBlock(stream, stream.window^, stream.block, stream.string - stream.block, FALSE); + stream.block := stream.string; + FlushPending(stream.pend, stream.out) + END; + INC(stream.string); + DEC(stream.lookAhead); + IF stream.out.avail = 0 THEN RETURN NeedMore + END + ELSE + (* There is no previous match to compare with, wait for the next step to decide *) + stream.prevAvail := TRUE; + INC(stream.string); + DEC(stream.lookAhead) + END + END; + ASSERT(flush # NoFlush, 110); + IF stream.prevAvail THEN + mustFlush := TallyLit(stream, stream.window[stream.string - 1]); + stream.prevAvail := FALSE + END; + FlushBlock(stream, stream.window^, stream.block, stream.string - stream.block, flush = Finish); + stream.block := stream.string; + FlushPending(stream.pend, stream.out); + IF (stream.out.avail = 0) & (flush = Finish) THEN RETURN FinishStarted + ELSIF stream.out.avail = 0 THEN RETURN NeedMore + ELSIF flush = Finish THEN RETURN FinishDone + ELSE RETURN BlockDone + END +END CompressSlow; + +(**---Streams---**) + +(** reset stream **) +PROCEDURE Reset*(VAR stream: Stream); +BEGIN + IF ~stream.open THEN + stream.res := StreamError; + ELSE + ZlibBuffers.Reset(stream.in); ZlibBuffers.Reset(stream.out); + stream.dataType := Unknown; + stream.pend.beg := 0; stream.pend.end := 0; + stream.trailerDone := FALSE; + IF stream.wrapper THEN + stream.status := InitState + ELSE + stream.status := BusyState + END; + stream.adler := 1; + stream.lastFlush := NoFlush; + InitTrees(stream); + InitMatches(stream); + stream.res := Ok; + END +END Reset; + +(** close deflate stream **) +PROCEDURE Close*(VAR stream: Stream); +BEGIN + IF stream.open THEN + stream.window := NIL; stream.prev := NIL; stream.head := NIL; + stream.pend.buf := NIL; stream.lbuf := NIL; stream.dbuf := NIL; + FreeTrees(stream); + stream.open := FALSE; stream.res := Ok + ELSE + stream.res := StreamError + END +END Close; + +(** initialize deflate stream with compression level and strategy; if wrapper is not set, no header and checksum are generated **) +PROCEDURE Open*(VAR stream: Stream; level, strategy: SHORTINT; wrapper: BOOLEAN); +BEGIN + IF level = DefaultCompression THEN level := 6 END; + IF (0 <= level) & (level <= 9) & (DefaultStrategy <= strategy) & (strategy <= HuffmanOnly) THEN + NEW(stream.window); NEW(stream.prev); NEW(stream.head); + (* zlib overlays pend.buf, lbuf and dbuf. Since memory usage should not be a very big problem and dbuf stores integers + instead of bytes they are allocated as seperate memory chunks here *) + NEW(stream.pend.buf); NEW(stream.lbuf); NEW(stream.dbuf); + IF (stream.window # NIL) & (stream.prev # NIL) & (stream.head # NIL) + & (stream.pend.buf # NIL) & (stream.lbuf # NIL) & (stream.dbuf # NIL) THEN + stream.level := level; stream.strategy := strategy; stream.wrapper := wrapper; stream.open := TRUE; + Reset(stream) + ELSE + stream.open := FALSE; + Close(stream); + stream.res := MemError + END + ELSE + stream.open := FALSE; + stream.res := StreamError + END +END Open; + +(** initializes the compression dictionary from the given byte sequence without producing any compressed output. + Must be called immediately after Open or Reset before any call of Deflate **) +PROCEDURE SetDictionary*(VAR stream: Stream; VAR dict: ARRAY OF CHAR; len: LONGINT); +VAR + offset, i, head: LONGINT; +BEGIN + IF ~stream.open OR (stream.status # InitState) THEN + stream.res := StreamError; + RETURN + END; + stream.adler := Zlib.Adler32(stream.adler, dict, 0, len); + IF len >= MinMatch THEN + IF len > MaxDist THEN + offset := len - MaxDist; (* use the tail of the dictionary *) + len := MaxDist + ELSE + offset := 0 + END; + SYSTEM.MOVE(SYSTEM.ADR(dict[offset]), SYSTEM.ADR(stream.window[0]), len); + stream.string := len; stream.block := len; + (* insert all strings in the hash table (except for the last two bytes). stream.lookAhead stays zero, + so stream.hash will be recomputed at the next call of FillWindow *) + stream.hash := ORD(stream.window[0]); + UpdateHash(stream.hash, stream.window[1]); + FOR i := 0 TO (len - MinMatch) DO + InsertString(stream, i, head) + END + END; + stream.res := Ok +END SetDictionary; + + +(** Deflate compresses as much data as possible, and stops when the input buffer becomes empty or the output buffer becomes full; + the flush parameter decides if and how blocks are terminated **) +PROCEDURE Deflate*(VAR stream: Stream; flush: SHORTINT); +VAR + lastFlush, bstate: SHORTINT; + header: LONGINT; + buf: ARRAY 1 OF CHAR; +BEGIN + IF ~stream.open OR (flush < NoFlush) OR (flush > Finish) OR ((stream.status = FinishState) & (flush # Finish)) THEN + stream.res := StreamError; + RETURN + END; + IF stream.out.avail = 0 THEN + stream.res := BufError; + RETURN + END; + lastFlush := stream.lastFlush; stream.lastFlush := flush; + + (* write zlib header *) + IF stream.status = InitState THEN + header := (((WindowBits - 8) * 10H) + Deflated) * 100H; (* CMF: 7 - 4: CINFO (compression info (=window size - 8)), 3 - 0: CM (compression method) *) + (* FLG: flags *) (* FLG.FLEVEL: compression level *) + IF stream.level >= 7 THEN INC(header, 0C0H) (* maximum compression, slowest algorithm *) + ELSIF stream.level >= 5 THEN INC(header, 80H) (* default algorithm *) + ELSIF stream.level >= 3 THEN INC(header, 40H) (* fast algorithm *) + END; (* ELSE fastest algorithm *) + IF stream.string # 0 THEN + INC(header, PresetDict) (* FLG.FDICT: preset dictionary *) + END; + INC(header, 31 - (header MOD 31)); (* FLG.FCHECK: check bits for CMF and FLG *) + stream.status := BusyState; + Put16BitsMSB(stream.pend, header); + IF stream.string # 0 THEN (* DICT: the adler32 checksum of the preset dictionary *) + Put32BitsMSB(stream.pend, stream.adler) + END; + stream.adler := 1; + END; + + (* flush as much pending output as possible *) + IF stream.pend.end # 0 THEN + FlushPending(stream.pend, stream.out); + IF stream.out.avail = 0 THEN + (* Since stream.out.avail is 0, Deflate will be called again with more output space, + but possibly with both stream.pend.end and stream.in.avail equal to zero. There won't be anything to do, + but this is not an error situation so make sure we return Ok instead of BufError at next call of Deflate *) + stream.lastFlush := -1; + stream.res := Ok; + RETURN + END + + (* make sure there is something to do and avoid duplicate consecutive flushes. For repeated and useless calls with Finish, + we keep returning StreamEnd instead of BufError *) + ELSIF (stream.in.avail = 0) & (flush <= lastFlush) & (flush # Finish) THEN + stream.res := BufError; + RETURN + END; + + (* user must not provide more input after the first Finish *) + IF (stream.status = Finish) & (stream.in.avail # 0) THEN + stream.res := BufError; + RETURN + END; + + (* start a new block or continue the current one *) + IF (stream.in.avail # 0) OR (stream.lookAhead # 0) OR ((flush # NoFlush) & (stream.status # FinishState)) THEN + bstate := ConfigTable[stream.level].Compress(stream, flush); + IF bstate IN {FinishStarted, FinishDone} THEN + stream.status := FinishState + END; + IF bstate IN {NeedMore, FinishStarted} THEN + IF stream.out.avail = 0 THEN + stream.lastFlush := -1 + END; + stream.res := Ok; (* avoid BufError in next call, see above *) + RETURN + (* if (flush # NoFlush) & (out.avail = 0), the next call of Deflate should use the same flush parameter + to make sure that the flush is complete. So we dont't have to output an empty block here, this will be done at next call. + This also ensures that for a very small output buffer, we emit at most one empty block. *) + ELSIF bstate = BlockDone THEN + IF flush = PartialFlush THEN + AlignTrees(stream) + ELSE (* FullFlush or SyncFlush *) + StoreBlock(stream, buf, 0, 0, FALSE); (* for a full flush, this empty block will be recognized as a special marker by Inflate.Sync *) + IF flush = FullFlush THEN + ClearHash(stream) (* forget about all hash chains *) + END + END; + FlushPending(stream.pend, stream.out); + IF stream.out.avail = 0 THEN + stream.lastFlush := -1; (* avoid BufError at next call, see above *) + stream.res := Ok; + RETURN + END + END + END; + ASSERT(stream.out.avail > 0, 111); + + IF flush # Finish THEN + stream.res := Ok + ELSIF ~stream.wrapper OR stream.trailerDone THEN + stream.res := StreamEnd + ELSE (* write the zlib trailer (adler32) *) + Put32BitsMSB(stream.pend, stream.adler); + FlushPending(stream.pend, stream.out); (* if stream.out.avail is zero, the application will call deflate again *) + stream.trailerDone := TRUE; (* write the trailer only once *) + IF stream.pend.end = 0 THEN (* flushed everything left *) + stream.res := StreamEnd + ELSE + stream.res := Ok + END + END +END Deflate; + + +(** change deflate parameters within the stream. If the compression level is changed, the input available so far + is compressed with the old level (and may be flushed); the new level will take effect only at the next call of Deflate **) +PROCEDURE SetParams*(VAR stream: Stream; level, strategy: SHORTINT); +BEGIN + IF level = DefaultCompression THEN + level := 6 + END; + IF ~stream.open OR (level < 0) OR (9 < level) OR (strategy < DefaultStrategy) OR (HuffmanOnly < strategy) THEN + stream.res := StreamError + ELSE + IF (ConfigTable[level].Compress # ConfigTable[stream.level].Compress) & (stream.in.totalIn # 0) THEN + Deflate(stream, PartialFlush) + END; + stream.level := level; + stream.strategy := strategy + END +END SetParams; + +(** compress complete stream and return output length in len **) +PROCEDURE Compress* (VAR src, dst: ARRAY OF CHAR; srcoffset, srclen, dstoffset, dstlen: LONGINT; level, strategy: SHORTINT; VAR len: LONGINT; VAR res: LONGINT); + VAR s: Stream; +BEGIN + ZlibBuffers.Init(s.in, src, srcoffset, srclen, srclen); + ZlibBuffers.Init(s.out, dst, dstoffset, dstlen, dstlen); + Open(s, level, strategy, TRUE); + IF s.res = Ok THEN + Deflate(s, Finish); + IF s.res = StreamEnd THEN + len := s.out.totalOut; + Close(s); + res := s.res + ELSE + res := s.res; + IF res = Ok THEN res := BufError END; + Close(s) + END + ELSE + res := s.res + END +END Compress; + + +BEGIN + InitStaticTrees(); + ConfigTable[0].GoodLen := 0; ConfigTable[0].MaxLazy := 0; ConfigTable[0].NiceLen := 0; + ConfigTable[0].MaxChain := 0; ConfigTable[0].Compress := CompressStored; (* store only *) + ConfigTable[1].GoodLen := 4; ConfigTable[1].MaxLazy := 4; ConfigTable[1].NiceLen := 8; + ConfigTable[1].MaxChain := 4; ConfigTable[1].Compress := CompressFast; (*maximum speed, no lazy matches *) + ConfigTable[2].GoodLen := 4; ConfigTable[2].MaxLazy := 5; ConfigTable[2].NiceLen := 16; + ConfigTable[2].MaxChain := 8; ConfigTable[2].Compress := CompressFast; + ConfigTable[3].GoodLen := 4; ConfigTable[3].MaxLazy := 6; ConfigTable[3].NiceLen := 32; + ConfigTable[3].MaxChain := 32; ConfigTable[3].Compress := CompressFast; + ConfigTable[4].GoodLen := 4; ConfigTable[4].MaxLazy := 4; ConfigTable[4].NiceLen := 16; + ConfigTable[4].MaxChain := 16; ConfigTable[4].Compress := CompressSlow; (* lazy matches *) + ConfigTable[5].GoodLen := 8; ConfigTable[5].MaxLazy := 16; ConfigTable[5].NiceLen := 32; + ConfigTable[5].MaxChain := 32; ConfigTable[5].Compress := CompressSlow; + ConfigTable[6].GoodLen := 8; ConfigTable[6].MaxLazy := 16; ConfigTable[6].NiceLen := 128; + ConfigTable[6].MaxChain := 128; ConfigTable[6].Compress := CompressSlow; + ConfigTable[7].GoodLen := 8; ConfigTable[7].MaxLazy := 32; ConfigTable[7].NiceLen := 128; + ConfigTable[7].MaxChain := 256; ConfigTable[7].Compress := CompressSlow; + ConfigTable[8].GoodLen := 32; ConfigTable[8].MaxLazy := 128; ConfigTable[8].NiceLen := 258; + ConfigTable[8].MaxChain := 1024; ConfigTable[8].Compress := CompressSlow; + ConfigTable[9].GoodLen := 32; ConfigTable[9].MaxLazy := 128; ConfigTable[9].NiceLen := 258; + ConfigTable[9].MaxChain := 4096; ConfigTable[9].Compress := CompressSlow; (* maximum compression *) +END ZlibDeflate. diff --git a/src/lib/s3/ZlibInflate.Mod b/src/lib/s3/ZlibInflate.Mod new file mode 100644 index 00000000..a1673d7a --- /dev/null +++ b/src/lib/s3/ZlibInflate.Mod @@ -0,0 +1,1230 @@ +(* ETH Oberon, Copyright 2001 ETH Zuerich Institut fuer Computersysteme, ETH Zentrum, CH-8092 Zuerich. +Refer to the "General ETH Oberon System Source License" contract available at: http://www.oberon.ethz.ch/ *) + +MODULE ZlibInflate; (** eos **) + + (** + Decompression of deflated byte streams + **) + + (* + 01.04.2001 - fixed bug in InflateBlock.Stored (didn't calculate t (or wavail?) correctly + -> Trap 100 in ZlibBuffers.ReadBytes (offset + len > LEN(buf))) + 11.12.2000 - Constants are imported from Zlib + 18.10.2000 - use Zlib.Adler32(..) instead of Adler32(..) -> import Zlib + 17.10.2000 - fixed bug in InflateBlocks.BlkLens (didn't calculate 1's complement of LEN correctly) + 04.01.2000 - fixed bug in InflateBlocks.BlkCodes (didn't reset s.res.code from StreamEnd to Ok) + 05.01.2000 - fixed bug in InflateCodes.CodeWash (didn't adjust s.buf when decreasing s.bits) + *) + + IMPORT + SYSTEM, Zlib, ZlibBuffers; + + CONST + (** result codes **) + Ok* = Zlib.Ok; StreamEnd* = Zlib.StreamEnd; NeedDict* = Zlib.NeedDict; + StreamError* = Zlib.StreamError; DataError* = Zlib.DataError; MemError* = Zlib.MemError; BufError* = Zlib.BufError; + + (** inflate operation codes **) + NoFlush* = Zlib.NoFlush; SyncFlush* = Zlib.SyncFlush; FullFlush* = Zlib.FullFlush; Finish* = Zlib.Finish; + + (* Huffman codes *) + MaxNodes = 1440; (* maximum number of nodes in dynamic literal/length and distance trees *) + MaxFixedNodes = 544; (* number of nodes in fixed trees *) + MaxLitLenCodes = 288; (* 256 bytes + end of block + 31 length codes *) + MaxNonSimpleCodes = MaxLitLenCodes - 256 - 1; (* maximal number of non-simple codes *) + MaxDistCodes = 31; + OpBase = -128; OpSpecial = 64; OpInvalid = 128; OpEndBlock = 32; OpExtra = 16; (* operations *) + + WindowBits = 15; WindowSize = ASH(1, WindowBits); (* always use 32k buffer *) + + (* decode state *) + CodeStart = 0; CodeLen = 1; CodeLenExt = 2; CodeDist = 3; CodeDistExt = 4; CodeCopy = 5; CodeLit = 6; + CodeWash = 7; CodeEnd = 8; CodeBad = 9; + + (* block state *) + BlkType = 0; BlkLens = 1; BlkStored = 2; BlkTable = 3; BlkBTree = 4; BlkDTree = 5; BlkCodes = 6; + BlkDry = 7; BlkDone = 8; BlkBad = 9; + + DeflateMethod* = 8; (** only supported compression method **) + PresetDict = 20H; (* inflate flag indicating use of a preset dictionary *) + + (* inflate stream state *) + InfMethod = 0; InfFlag = 1; InfDict4 = 2; InfDict3 = 3; InfDict2 = 4; InfDict1 = 5; InfDict0 = 6; + InfBlocks = 7; InfCheck4 = 8; InfCheck3 = 9; InfCheck2 = 10; InfCheck1 = 11; InfDone = 12; InfBad = 13; + + + TYPE + + (** result codes **) + Result* = RECORD + code-: LONGINT; (** result code including special conditions and errors **) + msg-: POINTER TO ARRAY OF CHAR; (** detailed error description if available **) + END; + + (* code parameters *) + Lengths = ARRAY OF SHORTINT; + Code = RECORD + bits: INTEGER; (* number of lookup bits *) + offset: INTEGER; (* offset in length array *) + size: INTEGER; (* number of codes *) + simple: INTEGER; (* number of simple codes *) + extra: ARRAY MaxNonSimpleCodes OF SHORTINT; (* number of extra bits for non-simple codes *) + base: ARRAY MaxNonSimpleCodes OF INTEGER; (* base length/distance for non-simple codes *) + END; + + (* tree nodes for decoding Huffman trees *) + Node = RECORD + base: INTEGER; (* literal, length base, distance base, or table offset *) + exop: SHORTINT; (* number of extra bits or operation *) + bits: SHORTINT; (* number of bits in this code or subcode *) + END; + Nodes = POINTER TO ARRAY OF Node; + + TreeNodes = RECORD + node: Nodes; (* available nodes *) + next: LONGINT; (* index of next available node *) + END; + + Tree = RECORD + node: Nodes; (* nodes where tree is stored *) + base: LONGINT; (* index of root table *) + bits: INTEGER; (* number of lookup bits *) + END; + + (* memory containing last WindowSize bytes of output *) + Window = ARRAY WindowSize OF CHAR; + + (* check function *) + CheckFunc = PROCEDURE (old: LONGINT; VAR buf: ARRAY OF CHAR; idx, len: LONGINT): LONGINT; + + (** inflate stream **) + Stream* = RECORD + in*, out*: ZlibBuffers.Buffer; (** input and output buffers (initialized by client) **) + (* totalIn-, totalOut-: LONGINT; (** number of bytes processed **) *) + res-: Result; (** result of last operation **) + wrapper-: BOOLEAN; (** if set, the stream has a zlib header and a checksum **) + open-: BOOLEAN; (** if set, stream is initialized **) + + (* window and lookahead buffer *) + window: POINTER TO Window; (* memory for the decompression window *) + read, write: LONGINT; (* window read and write index *) + checkFn: CheckFunc; (* function calculating checksum over output bytes *) + check: LONGINT; (* current output checksum *) + buf: LONGINT; (* bit buffer containing up to 32 lookup bits *) + bits: LONGINT; (* number of bits in lookup buffer = position of next bit *) + + (* inflate state machine *) + inf: RECORD + state: INTEGER; (* current state of stream *) + method: INTEGER; (* method byte for state InfFlag *) + marker: INTEGER; (* marker bytes for state InfBad *) + check: RECORD + calc: LONGINT; (* calculated sum *) + stored: LONGINT; (* stored sum *) + END + END; + + (* block state machine *) + block: RECORD + state: SHORTINT; (* current block state *) + last: BOOLEAN; (* set for last block *) + left: LONGINT; (* bytes left to copy for non-compressed blocks *) + nlit: INTEGER; (* number of literal/length codes *) + ndist: SHORTINT; (* number of distance codes *) + nclen: SHORTINT; (* number of code lengths *) + clen: ARRAY MaxLitLenCodes + MaxDistCodes OF SHORTINT; (* code lengths of bit, lit/len, or distance code *) + index: INTEGER; (* index of next code length *) + nodes: Nodes; (* memory for Huffman trees *) + btree: Tree; (* bit decoding tree *) + END; + + (* code state machine *) + decode: RECORD + state: SHORTINT; (* current decode state *) + lltree, dtree: Tree; (* literal/length and distance tree *) + tree: Tree; (* current decoding table *) + lit: INTEGER; (* decoded literal *) + extra: INTEGER; (* extra bits to get *) + len: INTEGER; (* decoded length *) + dist: INTEGER; (* distance back to copy from *) + END; + END; + + + VAR + FixedBuilt: BOOLEAN; (* set if fixed Huffman tables have been built *) + FixedLitLenTree, FixedDistTree: Tree; (* nodes for fixed literal/length and distance tree *) + Order: ARRAY 19 OF SHORTINT; (* order of code bit lengths *) + + + (*--- Results ---*) + + (* set error message *) + PROCEDURE SetMsg (VAR res: Result; msg: ARRAY OF CHAR); + VAR l: LONGINT; + BEGIN + l := 0; WHILE msg[l] # 0X DO INC(l) END; + NEW(res.msg, l+1); COPY(msg, res.msg^) + END SetMsg; + + + (*--- Huffman Decoding Tables ---*) + + PROCEDURE MakeLitLenCode (VAR code: Code; bits, offset, size, simple: INTEGER); + BEGIN + code.bits := bits; code.offset := offset; code.size := size; code.simple := simple; + IF simple < size THEN + code.extra[0] := 0; code.extra[1] := 0; code.extra[2] := 0; code.extra[3] := 0; + code.extra[4] := 0; code.extra[5] := 0; code.extra[6] := 0; code.extra[7] := 0; + code.extra[8] := 1; code.extra[9] := 1; code.extra[10] := 1; code.extra[11] := 1; + code.extra[12] := 2; code.extra[13] := 2; code.extra[14] := 2; code.extra[15] := 2; + code.extra[16] := 3; code.extra[17] := 3; code.extra[18] := 3; code.extra[19] := 3; + code.extra[20] := 4; code.extra[21] := 4; code.extra[22] := 4; code.extra[23] := 4; + code.extra[24] := 5; code.extra[25] := 5; code.extra[26] := 5; code.extra[27] := 5; + code.extra[28] := 0; code.extra[29] := 112; code.extra[30] := 112; + code.base[0] := 3; code.base[1] := 4; code.base[2] := 5; code.base[3] := 6; + code.base[4] := 7; code.base[5] := 8; code.base[6] := 9; code.base[7] := 10; + code.base[8] := 11; code.base[9] := 13; code.base[10] := 15; code.base[11] := 17; + code.base[12] := 19; code.base[13] := 23; code.base[14] := 27; code.base[15] := 31; + code.base[16] := 35; code.base[17] := 43; code.base[18] := 51; code.base[19] := 59; + code.base[20] := 67; code.base[21] := 83; code.base[22] := 99; code.base[23] := 115; + code.base[24] := 131; code.base[25] := 163; code.base[26] := 195; code.base[27] := 227; + code.base[28] := 258; code.base[29] := 0; code.base[30] := 0 + END + END MakeLitLenCode; + + PROCEDURE MakeDistCode (VAR code: Code; bits, offset, size, simple: INTEGER); + BEGIN + code.bits := bits; code.offset := offset; code.size := size; code.simple := simple; + IF simple < size THEN + code.extra[0] := 0; code.extra[1] := 0; code.extra[2] := 0; code.extra[3] := 0; + code.extra[4] := 1; code.extra[5] := 1; code.extra[6] := 2; code.extra[7] := 2; + code.extra[8] := 3; code.extra[9] := 3; code.extra[10] := 4; code.extra[11] := 4; + code.extra[12] := 5; code.extra[13] := 5; code.extra[14] := 6; code.extra[15] := 6; + code.extra[16] := 7; code.extra[17] := 7; code.extra[18] := 8; code.extra[19] := 8; + code.extra[20] := 9; code.extra[21] := 9; code.extra[22] := 10; code.extra[23] := 10; + code.extra[24] := 11; code.extra[25] := 11; code.extra[26] := 12; code.extra[27] := 12; + code.extra[28] := 13; code.extra[29] := 13; + code.base[0] := 1; code.base[1] := 2; code.base[2] := 3; code.base[3] := 4; + code.base[4] := 5; code.base[5] := 7; code.base[6] := 9; code.base[7] := 13; + code.base[8] := 17; code.base[9] := 25; code.base[10] := 33; code.base[11] := 49; + code.base[12] := 65; code.base[13] := 97; code.base[14] := 129; code.base[15] := 193; + code.base[16] := 257; code.base[17] := 385; code.base[18] := 513; code.base[19] := 769; + code.base[20] := 1025; code.base[21] := 1537; code.base[22] := 2049; code.base[23] := 3073; + code.base[24] := 4097; code.base[25] := 6145; code.base[26] := 8193; code.base[27] := 12289; + code.base[28] := 16385; code.base[29] := 24577 + END + END MakeDistCode; + + PROCEDURE MakeFixedLitLenCode (VAR len: Lengths; VAR code: Code); + VAR i: LONGINT; + BEGIN + ASSERT(LEN(len) >= 288, 100); + FOR i := 0 TO 143 DO len[i] := 8 END; + FOR i := 144 TO 255 DO len[i] := 9 END; + FOR i := 256 TO 279 DO len[i] := 7 END; + FOR i := 280 TO 287 DO len[i] := 8 END; + MakeLitLenCode(code, 9, 0, 288, 257) + END MakeFixedLitLenCode; + + PROCEDURE MakeFixedDistCode (VAR len: Lengths; VAR code: Code); + VAR i: LONGINT; + BEGIN + ASSERT(LEN(len) >= 30, 100); + FOR i := 0 TO 29 DO len[i] := 5 END; + MakeDistCode(code, 5, 0, 30, 0) + END MakeFixedDistCode; + + (* build huffman tree for given code *) + PROCEDURE BuildTree (VAR clen: Lengths; VAR code: Code; VAR tn: TreeNodes; VAR tree: Tree; VAR res: LONGINT); + CONST + maxLen = 15; (* maximum bit length of any code *) + VAR + l, lbits, min, max, dbits, len, bits, b: LONGINT; (* bit lengths *) + c, idx: LONGINT; (* code index *) + codes: ARRAY maxLen+1 OF INTEGER; (* number of codes of each length *) + unused, size, count, entries: LONGINT; (* code counts *) + offset: ARRAY maxLen+1 OF INTEGER; (* offset into index table for each length *) + off: INTEGER; + index: ARRAY MaxLitLenCodes OF INTEGER; (* symbol numbers ordered by code length *) + backup: ARRAY maxLen OF LONGINT; (* projection of current pattern to each level *) + pat, p, inc: LONGINT; (* current code pattern *) + tab, t: LONGINT; (* pointers into Huffman nodes *) + level: LONGINT; (* current table level *) + table: ARRAY maxLen OF LONGINT; (* current table index for each open level *) + node: Node; + BEGIN + (* compute number of codes for each bit length *) + FOR l := 0 TO maxLen DO + codes[l] := 0 + END; + FOR c := 0 TO code.size - 1 DO + INC(codes[clen[code.offset + c]]) + END; + IF codes[0] = code.size THEN (* all codes have len = 0 *) + tree.node := NIL; tree.base := 0; tree.bits := 0; res := Ok; + RETURN + END; + + lbits := code.bits; (* number of lookup bits *) + l := 1; WHILE (l <= maxLen) & (codes[l] = 0) DO INC(l) END; + min := l; IF lbits < min THEN lbits := SHORT(min) END; + l := maxLen; WHILE (l > 0) & (codes[l] = 0) DO DEC(l) END; + max := l; IF lbits > max THEN lbits := SHORT(max) END; + tree.bits := SHORT(lbits); (* adjusted number of lookup bits *) + + (* add number of unused codes to last code length count *) + l := min; unused := ASH(1, min); + LOOP + DEC(unused, LONG(codes[l])); + IF unused < 0 THEN res := DataError; RETURN END; (* more codes for length requested than available *) + IF l = max THEN EXIT END; + INC(l); unused := 2*unused (* can append either 0 or 1 to yet unused codes *) + END; + INC(codes[max], SHORT(unused)); + + (* generate starting offsets into index table for each length *) + l := 1; offset[1] := 0; off := 0; + WHILE l < max DO + INC(off, codes[l]); INC(l); offset[l] := off + END; + + (* create index to code symbol ordered by code length *) + FOR c := 0 TO code.size-1 DO + l := clen[code.offset + c]; + IF l # 0 THEN + index[offset[l]] := SHORT(c); INC(offset[l]) + END + END; + size := offset[max]; (* effective number of codes *) + + (* generate Huffman codes and tables for each level *) + backup[0] := 0; pat := 0; idx := 0; + dbits := -lbits; level := -1; (* dbits = lookupBits * level (number of decoded bits) *) + FOR len := min TO max DO + count := codes[len]; + WHILE count > 0 DO + WHILE len > dbits + lbits DO (* code length too long to fit in current table *) + INC(level); INC(dbits, lbits); (* previous table had size tbits *) + + (* compute minimum size <= lookup bits for next table *) + bits := max - dbits; + IF bits > lbits THEN bits := lbits END; (* limit number of bits for table *) + b := len - dbits; entries := ASH(1, b); (* try table with size len-dbits *) + IF entries > count THEN + (* + codes of length len do not use all slots in table of length b. however, these unused slots + will be used by longer codes having the same prefix. + *) + DEC(entries, count); + IF b < bits THEN + l := len; + LOOP + INC(b); IF b = bits THEN EXIT END; (* mustn't make table any larger *) + entries := 2*entries; INC(l); + IF entries <= codes[l] THEN EXIT END; (* enough codes to use up b bits *) + DEC(entries, LONG(codes[l])) + END + END + END; + + (* allocate table from available Huffman nodes *) + entries := ASH(1, b); + IF tn.next + entries > LEN(tn.node^) THEN + res := MemError; RETURN + END; + tab := tn.next; table[level] := tab; INC(tn.next, entries); + + (* connect to previous table *) + IF level > 0 THEN + backup[level] := pat; (* save pattern for backing up *) + node.bits := SHORT(SHORT(lbits)); (* bits to dump before this table *) + node.exop := OpBase + SHORT(SHORT(b)); (* bits in this table *) + t := ASH(pat, -(dbits - lbits)); (* offset of pattern within previous table *) + node.base := SHORT(tab - table[level-1] - t); (* offset to this table *) + tn.node[table[level-1] + t] := node (* link previous table entry to this table *) + ELSE + tree.node := tn.node; tree.base := tab + END + END; + + (* set up table entry *) + node.bits := SHORT(SHORT(len - dbits)); + IF idx >= size THEN + node.exop := OpBase + OpSpecial + OpInvalid (* out of codes *) + ELSIF index[idx] < code.simple THEN (* simple code *) + IF index[idx] < 256 THEN node.exop := OpBase ELSE node.exop := OpBase + OpSpecial + OpEndBlock END; + node.base := index[idx]; (* simple code is just the value *) + INC(idx) + ELSE (* non-simple => lookup in extra/base tables *) + node.exop := OpBase + OpSpecial + OpExtra + code.extra[index[idx] - code.simple]; + node.base := code.base[index[idx] - code.simple]; + INC(idx) + END; + + (* fill all table entries having common relevant code bits *) + p := ASH(pat, -dbits); inc := ASH(1, len - dbits); + WHILE p < entries DO + tn.node[tab + p] := node; INC(p, inc) + END; + + (* increment the code pattern (in reverse bit order) *) + l := len-1; + WHILE ODD(ASH(pat, -l)) DO (* generates carry *) + DEC(pat, ASH(1, l)); (* equivalent to xor since pat.l is set *) + DEC(l) + END; + INC(pat, ASH(1, l)); (* equivalent to xor since pat.l is clear *) + + (* backup over finished tables *) + WHILE pat MOD ASH(1, dbits) # backup[level] DO (* entry in previous table no longer compatible with this table *) + DEC(level); DEC(dbits, lbits) + END; + + DEC(count) + END + END; + + IF (unused # 0) & (max # 1) THEN res := BufError (* incomplete table *) + ELSE res := Ok + END + END BuildTree; + + + (*--- Auxiliary Routines ---*) + + (* copy as much as possible from sliding window to output buffer *) + PROCEDURE Flush (VAR s: Stream); + VAR n: LONGINT; + BEGIN + (* get number of bytes to copy *) + IF s.read <= s.write THEN n := s.write - s.read + ELSE n := WindowSize - s.read (* first copy only up to end of window *) + END; + IF n > s.out.avail THEN n := s.out.avail END; + IF n > 0 THEN + IF s.res.code = BufError THEN s.res.code := Ok END; + IF s.checkFn # NIL THEN (* update output check sum *) + s.check := s.checkFn(s.check, s.window^, s.read, n) + END; + + (* copy from window to output buffer *) + ZlibBuffers.WriteBytes(s.out, s.window^, s.read, n); + INC(s.read, n) + END; + + IF s.read = WindowSize THEN (* wrap read/write index and continue at start of window *) + s.read := 0; + IF s.write = WindowSize THEN s.write := 0 END; + + (* get number of bytes to copy *) + n := s.write - s.read; + IF n > s.out.avail THEN n := s.out.avail END; + IF n > 0 THEN + IF s.res.code = BufError THEN s.res.code := Ok END; + IF s.checkFn # NIL THEN (* update output check sum *) + s.check := s.checkFn(s.check, s.window^, s.read, n) + END; + + (* copy from window to output buffer *) + ZlibBuffers.WriteBytes(s.out, s.window^, s.read, n); + INC(s.read, n) + END + END + END Flush; + + (* transfer bits from input buffer to bit buffer and return if successful *) + PROCEDURE Need (VAR s: Stream; bits: LONGINT): BOOLEAN; + VAR byte: CHAR; + BEGIN + WHILE s.bits < bits DO + IF s.in.avail = 0 THEN + Flush(s); + RETURN FALSE + END; + ZlibBuffers.Read(s.in, byte); + INC(s.buf, ASH(ORD(byte), s.bits)); INC(s.bits, 8) (* one byte more in buffer now *) + END; + RETURN TRUE + END Need; + + PROCEDURE Dump (VAR s: Stream; bits: LONGINT); + BEGIN + s.buf := SYSTEM.LSH(s.buf, -bits); DEC(s.bits, bits) + END Dump; + + PROCEDURE NeedOut (VAR s: Stream; VAR wavail: LONGINT): BOOLEAN; + BEGIN + IF wavail = 0 THEN + IF (s.write = WindowSize) & (s.read # 0) THEN + s.write := 0; wavail := s.read-1 + END; + IF wavail = 0 THEN + Flush(s); + IF (s.write = WindowSize) & (s.read # 0) THEN + s.write := 0; wavail := s.read-1; + END; + IF wavail = 0 THEN + RETURN FALSE + END + END + END; + RETURN TRUE + END NeedOut; + + + (*--- Codes ---*) + + PROCEDURE NewCodes (VAR s: Stream; VAR lltree, dtree: Tree); + BEGIN + s.decode.lltree := lltree; s.decode.dtree := dtree; + s.decode.state := CodeStart + END NewCodes; + + PROCEDURE FreeCodes (VAR s: Stream); + BEGIN + s.decode.lltree.node := NIL; s.decode.dtree.node := NIL; s.decode.tree.node := NIL + END FreeCodes; + + (* Called with number of bytes left to write in window (wavail) at least 258 (the maximum + string length) and number of input bytes available (s.in.avail) at least ten. The ten bytes + are six bytes for the longest length/distance pair plus four bytes for overloading the bit buffer. *) + PROCEDURE InflateFast (VAR s: Stream; VAR wavail: LONGINT); + VAR inavail, base, len, dist, index: LONGINT; byte: CHAR; node: Node; exop: INTEGER; + BEGIN + inavail := s.in.avail; + REPEAT + WHILE s.bits < 20 DO (* maximal bits for lit/len code, including extra bits *) + ZlibBuffers.Read(s.in, byte); + INC(s.buf, ASH(ORD(byte), s.bits)); INC(s.bits, 8) + END; + base := s.decode.lltree.base; node.base := 0; exop := s.decode.lltree.bits; + REPEAT + base := base + node.base + s.buf MOD ASH(1, exop); + node := s.decode.lltree.node[base]; + Dump(s, node.bits); + exop := LONG(node.exop) - OpBase + UNTIL (exop = 0) OR ODD(exop DIV OpSpecial); + IF exop = 0 THEN (* literal *) + s.window[s.write] := CHR(node.base); INC(s.write); DEC(wavail) + ELSIF ODD(exop DIV OpExtra) THEN (* length code *) + exop := exop MOD OpExtra; + len := node.base + s.buf MOD ASH(1, exop); + Dump(s, exop); + WHILE s.bits < 15 DO (* maximal bits for distance code *) + ZlibBuffers.Read(s.in, byte); + INC(s.buf, ASH(ORD(byte), s.bits)); INC(s.bits, 8) + END; + base := s.decode.dtree.base; node.base := 0; exop := s.decode.dtree.bits; + REPEAT + base := base + node.base + s.buf MOD ASH(1, exop); + node := s.decode.dtree.node[base]; + Dump(s, node.bits); + exop := LONG(node.exop) - OpBase + UNTIL ODD(exop DIV OpSpecial); + IF ODD(exop DIV OpExtra) THEN (* distance code *) + exop := exop MOD OpExtra; + WHILE s.bits < exop DO (* need up to 13 extra bits *) + ZlibBuffers.Read(s.in, byte); + INC(s.buf, ASH(ORD(byte), s.bits)); INC(s.bits, 8) + END; + dist := node.base + s.buf MOD ASH(1, exop); + Dump(s, exop); + DEC(wavail, len); + index := s.write - dist; + IF index < 0 THEN + IF -index < len THEN (* crosses window bounds *) + INC(len, index); + IF s.write - index <= WindowSize + index THEN (* no overlap *) + SYSTEM.MOVE(SYSTEM.ADR(s.window[WindowSize + index]), SYSTEM.ADR(s.window[s.write]), -index); + DEC(s.write, index) + ELSE (* be safe *) + index := WindowSize + index; + REPEAT + s.window[s.write] := s.window[index]; INC(s.write); INC(index) + UNTIL index = WindowSize + END; + index := 0 + ELSE + INC(index, WindowSize) + END + END; + IF len > 0 THEN + IF index + len <= s.write THEN (* no overlap *) + SYSTEM.MOVE(SYSTEM.ADR(s.window[index]), SYSTEM.ADR(s.window[s.write]), len); + INC(s.write, len); + ELSE + REPEAT + s.window[s.write] := s.window[index]; INC(s.write); INC(index); + DEC(len) + UNTIL len = 0 + END + END + ELSE + SetMsg(s.res, "invalid distance code"); s.res.code := DataError; + len := inavail - s.in.avail; + IF s.bits DIV 8 < len THEN len := s.bits DIV 8 END; + ZlibBuffers.Reread(s.in, len); DEC(s.bits, 8*len); s.buf := s.buf MOD ASH(1, s.bits); + RETURN + END + ELSE + len := inavail - s.in.avail; + IF s.bits DIV 8 < len THEN len := s.bits DIV 8 END; + ZlibBuffers.Reread(s.in, len); DEC(s.bits, 8*len); s.buf := s.buf MOD ASH(1, s.bits); + IF ODD(exop DIV OpEndBlock) THEN s.res.code := StreamEnd + ELSE SetMsg(s.res, "invalid literal/length code"); s.res.code := DataError + END; + RETURN + END + UNTIL (wavail < 258) OR (s.in.avail < 10); + + (* can no longer guarantee enough space *) + len := inavail - s.in.avail; + IF s.bits DIV 8 < len THEN len := s.bits DIV 8 END; + ZlibBuffers.Reread(s.in, len); DEC(s.bits, 8*len); s.buf := s.buf MOD ASH(1, s.bits); + s.res.code := Ok + END InflateFast; + + PROCEDURE InflateCodes (VAR s: Stream); + VAR wavail, base, index: LONGINT; node: Node; exop: INTEGER; + BEGIN + IF s.write < s.read THEN wavail := s.read - s.write - 1 + ELSE wavail := WindowSize - s.write + END; + LOOP + CASE s.decode.state OF + | CodeStart: (* try fast inflation while enough space available *) + IF (wavail >= 258) & (s.in.avail >= 10) THEN + InflateFast(s, wavail); + IF s.res.code # Ok THEN + IF s.res.code = StreamEnd THEN s.decode.state := CodeWash + ELSE s.decode.state := CodeBad + END; + EXIT + END + END; + s.decode.tree := s.decode.lltree; + s.decode.state := CodeLen + + | CodeLen: (* get literal/length code *) + IF ~Need(s, s.decode.tree.bits) THEN EXIT END; + base := s.decode.tree.base + s.buf MOD ASH(1, s.decode.tree.bits); + node := s.decode.tree.node[base]; + Dump(s, node.bits); + exop := LONG(node.exop) - OpBase; + IF exop = 0 THEN (* literal *) + s.decode.lit := node.base; + s.decode.state := CodeLit + ELSIF ODD(exop DIV OpExtra) THEN (* need extra bits *) + s.decode.extra := exop MOD OpExtra; + s.decode.len := node.base; + s.decode.state := CodeLenExt + ELSIF ~ODD(exop DIV OpSpecial) THEN (* hop to next table *) + s.decode.tree.bits := exop; + s.decode.tree.base := base + node.base + ELSIF ODD(exop DIV OpEndBlock) THEN (* end of block *) + s.decode.state := CodeWash + ELSE (* invalid code *) + SetMsg(s.res, "invalid literal/length code"); + s.res.code := DataError; s.decode.state := CodeBad; + Flush(s); + EXIT + END + + | CodeLenExt: (* get extra bits for length codes *) + IF ~Need(s, s.decode.extra) THEN EXIT END; + INC(s.decode.len, SHORT(s.buf MOD ASH(1, s.decode.extra))); + Dump(s, s.decode.extra); + s.decode.tree := s.decode.dtree; + s.decode.state := CodeDist + + | CodeDist: (* get distance code *) + IF ~Need(s, s.decode.tree.bits) THEN EXIT END; + base := s.decode.tree.base + s.buf MOD ASH(1, s.decode.tree.bits); + node := s.decode.tree.node[base]; + Dump(s, node.bits); + exop := LONG(node.exop) - OpBase; + IF ODD(exop DIV OpExtra) THEN (* need extra bits *) + s.decode.extra := exop MOD OpExtra; + s.decode.dist := node.base; + s.decode.state := CodeDistExt + ELSIF ~ODD(exop DIV OpSpecial) THEN (* need more bits *) + s.decode.tree.bits := exop; + s.decode.tree.base := base + node.base + ELSE (* invalid code *) + SetMsg(s.res, "invalid distance code"); + s.res.code := DataError; s.decode.state := CodeBad; + Flush(s); + EXIT + END + + | CodeDistExt: (* get extra bits for distance *) + IF ~Need(s, s.decode.extra) THEN EXIT END; + INC(s.decode.dist, SHORT(s.buf MOD ASH(1, s.decode.extra))); + Dump(s, s.decode.extra); + s.decode.state := CodeCopy + + | CodeCopy: (* copy within window *) + index := (s.write - s.decode.dist) MOD WindowSize; (* position of string to copy *) + WHILE s.decode.len # 0 DO + IF ~NeedOut(s, wavail) THEN EXIT END; + s.window[s.write] := s.window[index]; INC(s.write); DEC(wavail); + index := (index+1) MOD WindowSize; + DEC(s.decode.len) + END; + s.decode.state := CodeStart + + | CodeLit: (* append literal to window *) + IF ~NeedOut(s, wavail) THEN EXIT END; + s.window[s.write] := CHR(s.decode.lit); INC(s.write); DEC(wavail); + s.decode.state := CodeStart + + | CodeWash: (* block finished but window may not be empty *) + IF s.bits > 7 THEN (* return unused byte, if any *) + ASSERT(s.bits < 16, 110); (* otherwise InflateCodes grabbed too many bytes *) + DEC(s.bits, 8); s.buf := s.buf MOD ASH(1, s.bits); + ZlibBuffers.Reread(s.in, 1) + END; + Flush(s); + IF s.read # s.write THEN EXIT + ELSE s.decode.state := CodeEnd + END + + | CodeEnd: + s.res.code := StreamEnd; + EXIT + + | CodeBad: + s.res.code := DataError; + EXIT + + ELSE + s.res.code := StreamError; + EXIT + END + END + END InflateCodes; + + + (*--- Block Handling ---*) + + PROCEDURE ResetBlocks (VAR s: Stream; VAR check: LONGINT); + VAR buf: ARRAY 1 OF CHAR; + BEGIN + check := s.check; + s.block.state := BlkType; s.buf := 0; s.bits := 0; + s.read := 0; s.write := 0; + IF s.checkFn # NIL THEN + s.check := s.checkFn(0, buf, 0, -1) + END + END ResetBlocks; + + PROCEDURE NewBlocks (VAR s: Stream; checkFn: CheckFunc); + BEGIN + NEW(s.block.nodes, MaxNodes); NEW(s.window); + IF (s.block.nodes = NIL) OR (s.window = NIL) THEN + s.block.nodes := NIL; s.window := NIL; + s.res.code := MemError + ELSE + s.checkFn := checkFn; + ResetBlocks(s, s.check); + s.res.code := Ok + END + END NewBlocks; + + PROCEDURE FreeBlocks (VAR s: Stream); + BEGIN + ResetBlocks(s, s.check); + s.block.nodes := NIL; s.window := NIL + END FreeBlocks; + + PROCEDURE InflateBlocks (VAR s: Stream); + VAR + wavail, t, cnt, len: LONGINT; tn: TreeNodes; clen: ARRAY MaxLitLenCodes OF SHORTINT; code: Code; res: LONGINT; + node: Node; lltree, dtree: Tree; + BEGIN + IF s.write < s.read THEN wavail := s.read - s.write - 1 + ELSE wavail := WindowSize - s.write + END; + LOOP + CASE s.block.state OF + | BlkType: (* begin of block, determine if last and compression method *) + IF ~Need(s, 3) THEN EXIT END; + t := s.buf MOD 8; s.block.last := ODD(t); + Dump(s, 3); + CASE t DIV 2 OF + | 0: (* no compression *) + Dump(s, s.bits MOD 8); (* go to byte boundary *) + s.block.state := BlkLens + | 1: (* compressed with fixed Huffman codes *) + IF ~FixedBuilt THEN + NEW(tn.node, MaxFixedNodes); tn.next := 0; + MakeFixedLitLenCode(clen, code); + BuildTree(clen, code, tn, FixedLitLenTree, res); + ASSERT(res = Ok, 110); + MakeFixedDistCode(clen, code); + BuildTree(clen, code, tn, FixedDistTree, res); + ASSERT((res = Ok) OR (res = BufError), 111); (* allow incomplete code *) + FixedBuilt := TRUE + END; + NewCodes(s, FixedLitLenTree, FixedDistTree); + s.block.state := BlkCodes + | 2: (* compressed with dynamic codes *) + s.block.state := BlkTable + | 3: (* illegal *) + SetMsg(s.res, "invalid block type"); + s.block.state := BlkBad; s.res.code := DataError; + Flush(s); + EXIT + END + + | BlkLens: (* read length of uncompressed block *) + IF ~Need(s, 32) THEN EXIT END; + IF ASH(-(s.buf+1), -16) MOD 10000H # s.buf MOD 10000H THEN + SetMsg(s.res, "invalid stored block lengths"); + s.block.state := BlkBad; s.res.code := DataError; + Flush(s); + EXIT + END; + s.block.left := s.buf MOD 10000H; + s.buf := 0; s.bits := 0; (* dump all bits *) + IF s.block.left # 0 THEN s.block.state := BlkStored; + ELSIF s.block.last THEN s.block.state := BlkDry + ELSE s.block.state := BlkType + END + + | BlkStored: (* copy uncompressed bytes from input buffer to window *) + IF s.in.avail = 0 THEN + Flush(s); + EXIT + END; + IF ~NeedOut(s, wavail) THEN EXIT END; + t := s.block.left; + IF t > s.in.avail THEN t := s.in.avail END; + IF t > wavail THEN t := wavail END; + IF s.write + t > WindowSize THEN t := WindowSize - s.write END; (* new, not in original ZLIB source code *) + IF t > 0 THEN + ZlibBuffers.ReadBytes(s.in, s.window^, s.write, t) + ELSE (* new, not in original ZLIB source code *) + Flush(s); + EXIT + END; + INC(s.write, t); DEC(wavail, t); + DEC(s.block.left, t); + IF s.block.left = 0 THEN + IF s.block.last THEN s.block.state := BlkDry + ELSE s.block.state := BlkType + END + END + + | BlkTable: (* get number of code lengths for each tree *) + IF ~Need(s, 14) THEN EXIT END; (* 5 (#lit/len-257) + 5 (#dist-1) + 4 (#codelen-4) *) + t := s.buf MOD 4000H; + s.block.nlit := SHORT(257 + t MOD 20H); t := t DIV 20H; + s.block.ndist := SHORT(SHORT(1 + t MOD 20H)); t := t DIV 20H; + s.block.nclen := SHORT(SHORT(4 + t)); + IF (s.block.nlit > 286) OR (s.block.ndist > 30) THEN + SetMsg(s.res, "too many length or distance symbols"); + s.block.state := BlkBad; s.res.code := DataError; + Flush(s); + EXIT + END; + Dump(s, 14); + s.block.index := 0; + s.block.state := BlkBTree (* ready to read code lengths *) + + | BlkBTree: (* get code lengths for code length tree *) + WHILE s.block.index < s.block.nclen DO (* get bit lengths of code *) + IF ~Need(s, 3) THEN EXIT END; + s.block.clen[Order[s.block.index]] := SHORT(SHORT(s.buf MOD 8)); + INC(s.block.index); + Dump(s, 3) + END; + WHILE s.block.index < 19 DO + s.block.clen[Order[s.block.index]] := 0; + INC(s.block.index) + END; + tn.node := s.block.nodes; tn.next := 0; + code.bits := 7; code.offset := 0; code.size := 19; code.simple := 19; + BuildTree(s.block.clen, code, tn, s.block.btree, res); + IF res = DataError THEN + SetMsg(s.res, "oversubscribed dynamic bit lengths tree"); + s.block.state := BlkBad + ELSIF (res = BufError) OR (s.block.btree.bits = 0) THEN + SetMsg(s.res, "incomplete dynamic bit lengths tree"); + res := DataError; s.block.state := BlkBad + END; + IF res # Ok THEN + s.res.code := res; + Flush(s); + EXIT + END; + s.block.index := 0; + s.block.state := BlkDTree (* can now decode lit/len and distance code lengths *) + + | BlkDTree: (* get code lengths for literal/length and distance trees *) + WHILE s.block.index < s.block.nlit + s.block.ndist DO + IF ~Need(s, s.block.btree.bits) THEN EXIT END; + t := s.block.btree.base + s.buf MOD ASH(1, s.block.btree.bits); + node := s.block.btree.node[t]; + IF node.base < 16 THEN (* code length *) + Dump(s, node.bits); + s.block.clen[s.block.index] := SHORT(node.base); + INC(s.block.index) + ELSE + CASE node.base OF + | 16: (* repeat previous length 3-6 times, using another 2 bits *) + IF ~Need(s, node.bits+2) THEN EXIT END; + Dump(s, node.bits); cnt := 3 + s.buf MOD 4; Dump(s, 2); + IF s.block.index = 0 THEN + SetMsg(s.res, "invalid bit length repeat (no previous code length)"); + s.res.code := DataError; s.block.state := BlkBad; + Flush(s); + EXIT + END; + len := s.block.clen[s.block.index-1] + | 17: (* repeat code length 0 for 3-10 times, using another 3 bits *) + IF ~Need(s, node.bits+3) THEN EXIT END; + Dump(s, node.bits); cnt := 3 + s.buf MOD 8; Dump(s, 3); len := 0 + | 18: (* repeat code length 0 for 11-138 times, using another 7 bits *) + IF ~Need(s, node.bits+7) THEN EXIT END; + Dump(s, node.bits); cnt := 11 + s.buf MOD 128; Dump(s, 7); len := 0 + END; + IF s.block.index + cnt > s.block.nlit + s.block.ndist THEN + SetMsg(s.res, "invalid bit length repeat"); + s.res.code := DataError; s.block.state := BlkBad; + Flush(s); + EXIT + END; + REPEAT + s.block.clen[s.block.index] := SHORT(SHORT(len)); + INC(s.block.index); DEC(cnt) + UNTIL cnt = 0 + END + END; + + (* build dynamic trees for literal/length and distance codes *) + tn.node := s.block.nodes; tn.next := 0; + MakeLitLenCode(code, 9, 0, s.block.nlit, 257); + BuildTree(s.block.clen, code, tn, lltree, res); + IF (res # Ok) OR (lltree.bits = 0) THEN + IF res = DataError THEN + SetMsg(s.res, "oversubscribed literal/length tree") + ELSIF res # MemError THEN + SetMsg(s.res, "incomplete literal/length tree"); res := DataError + END + ELSE + MakeDistCode(code, 6, s.block.nlit, s.block.ndist, 0); + BuildTree(s.block.clen, code, tn, dtree, res); + IF (res # Ok) OR (dtree.bits = 0) & (s.block.nlit > 257) THEN + IF res = DataError THEN + SetMsg(s.res, "oversubscribed distance tree") + ELSIF res = BufError THEN + SetMsg(s.res, "incomplete distance tree"); res := DataError + ELSIF res # MemError THEN + SetMsg(s.res, "empty distance tree with lengths"); res := DataError + END + END + END; + IF res # Ok THEN + IF res = DataError THEN s.block.state := BlkBad END; + s.res.code := res; + Flush(s); + EXIT + END; + NewCodes(s, lltree, dtree); + s.block.state := BlkCodes + + | BlkCodes: (* decompress input bits using current codes *) + InflateCodes(s); + IF s.res.code # StreamEnd THEN + Flush(s); + EXIT + END; + s.res.code := Ok; + FreeCodes(s); + IF s.block.last THEN s.block.state := BlkDry + ELSE s.block.state := BlkType + END + + | BlkDry: (* run out of input, waiting for output buffer to become empty *) + Flush(s); + IF s.read # s.write THEN EXIT END; + s.block.state := BlkDone + + | BlkDone: (* nothing more to do *) + s.res.code := StreamEnd; + EXIT + + | BlkBad: (* error in data *) + s.res.code := DataError; + EXIT + + ELSE (* programming error *) + s.res.code := StreamError; + EXIT + END + END + END InflateBlocks; + + PROCEDURE SetBlockDict (VAR s: Stream; VAR dict: ARRAY OF CHAR; offset, len: LONGINT); + BEGIN + ASSERT((len <= WindowSize) & (offset + len <= LEN(dict)), 100); + SYSTEM.MOVE(SYSTEM.ADR(dict[0]), SYSTEM.ADR(s.window[0]), len); + s.read := len; s.write := len + END SetBlockDict; + + PROCEDURE BlockSyncPoint (VAR s: Stream): BOOLEAN; + BEGIN + RETURN s.block.state = BlkLens + END BlockSyncPoint; + + + (*--- Inflate Streams ---*) + + PROCEDURE Reset0(VAR stream: Stream); + VAR check: LONGINT; + BEGIN + IF stream.open THEN + stream.res.msg := NIL; + IF stream.wrapper THEN stream.inf.state := InfMethod ELSE stream.inf.state := InfBlocks END; + ResetBlocks(stream, check); + stream.res.code := Ok + ELSE + stream.res.code := StreamError + END + END Reset0; + + (** reset an opened inflate stream (equivalent to closing and reopening) **) + PROCEDURE Reset* (VAR stream: Stream); + BEGIN + Reset0(stream); + IF stream.open THEN + ZlibBuffers.Reset(stream.in); ZlibBuffers.Reset(stream.out); + END + END Reset; + + (** initialize inflate stream; if 'wrapper' is not set, the stream has no zlib header and no checksum **) + PROCEDURE Open* (VAR stream: Stream; wrapper: BOOLEAN); + VAR checkFn: CheckFunc; + BEGIN + stream.res.msg := NIL; + stream.wrapper := wrapper; stream.open := TRUE; + IF wrapper THEN checkFn := Zlib.Adler32 ELSE checkFn := NIL END; + NewBlocks(stream, checkFn); + IF stream.res.code = Ok THEN + Reset(stream) + END + END Open; + + (** close inflate stream **) + PROCEDURE Close* (VAR stream: Stream); + BEGIN + FreeBlocks(stream); + stream.res.code := Ok + END Close; + + (** inflate until either input or output buffer runs out; if op is 'Finish', Inflate returns with either 'StreamEnd' or an error **) + PROCEDURE Inflate* (VAR stream: Stream; flush: SHORTINT); + VAR res: LONGINT; byte: CHAR; (* inxt, onxt: LONGINT; *) + BEGIN + IF ~stream.open THEN + stream.res.code := StreamError + ELSE + IF flush = Finish THEN res := BufError (* must never run out of buffer space *) + ELSE res := Ok (* can return anytime if some progress has been made *) + END; + stream.res.code := BufError; (* set result code for case that no progress can be done *) + LOOP + IF stream.inf.state IN {InfMethod, InfFlag, InfDict4..InfDict1, InfCheck4..InfCheck1} THEN (* need byte *) + IF stream.in.avail = 0 THEN EXIT END; + stream.res.code := res; + ZlibBuffers.Read(stream.in, byte); + END; + CASE stream.inf.state OF + | InfMethod: (* get compression method and number of window bits *) + stream.inf.method := ORD(byte); + IF stream.inf.method MOD 10H # DeflateMethod THEN + stream.inf.state := InfBad; stream.inf.marker := 5; (* can't sync *) + SetMsg(stream.res, "unknown compression method") + ELSIF stream.inf.method DIV 10H + 8 > WindowBits THEN + stream.inf.state := InfBad; stream.inf.marker := 5; (* can't sync *) + SetMsg(stream.res, "invalid window size") + ELSE + stream.inf.state := InfFlag + END + | InfFlag: (* get flag byte *) + IF (ASH(stream.inf.method, 8) + ORD(byte)) MOD 31 # 0 THEN + stream.inf.state := InfBad; stream.inf.marker := 5; (* can't sync *) + SetMsg(stream.res, "incorrect header check") + ELSIF ODD(ORD(byte) DIV PresetDict) THEN + stream.inf.state := InfDict4 + ELSE + stream.inf.state := InfBlocks + END + + | InfDict4: (* getting first byte of dictionary checksum *) + stream.inf.check.stored := ASH(ORD(byte), 24); + stream.inf.state := InfDict3 + | InfDict3: (* getting second byte of dictionary checksum *) + INC(stream.inf.check.stored, ASH(ORD(byte), 16)); + stream.inf.state := InfDict2 + | InfDict2: (* getting third byte of dictionary checksum *) + INC(stream.inf.check.stored, ASH(ORD(byte), 8)); + stream.inf.state := InfDict1 + | InfDict1: (* getting final byte of dictionary checksum *) + INC(stream.inf.check.stored, LONG(ORD(byte))); + stream.inf.state := InfDict0; + stream.res.code := NeedDict; + EXIT + | InfDict0: (* client didn't provide dictionary as requested *) + stream.inf.state := InfBad; stream.inf.marker := 0; (* can try sync *) + SetMsg(stream.res, "need dictionary"); + stream.res.code := StreamError; + EXIT + + | InfBlocks: (* decoding blocks *) + (* inxt := stream.in.next; onxt := stream.out.next; *) + InflateBlocks(stream); + (* INC(stream.totalIn, stream.in.next - inxt); INC(stream.totalOut, stream.out.next - onxt); *) + IF stream.res.code = DataError THEN + stream.inf.state := InfBad; stream.inf.marker := 0 (* can try sync *) + ELSIF stream.res.code = StreamEnd THEN + stream.res.code := res; + ResetBlocks(stream, stream.inf.check.calc); + IF stream.wrapper THEN stream.inf.state := InfCheck4 + ELSE stream.inf.state := InfDone + END + ELSE + IF stream.res.code = Ok THEN stream.res.code := res END; + EXIT + END + + | InfCheck4: (* get first byte of checksum *) + stream.inf.check.stored := ASH(ORD(byte), 24); + stream.inf.state := InfCheck3 + | InfCheck3: (* get second byte of checksum *) + INC(stream.inf.check.stored, ASH(ORD(byte), 16)); + stream.inf.state := InfCheck2 + | InfCheck2: (* get third byte of checksum *) + INC(stream.inf.check.stored, ASH(ORD(byte), 8)); + stream.inf.state := InfCheck1 + | InfCheck1: (* get final byte of checksum *) + INC(stream.inf.check.stored, LONG(ORD(byte))); + IF stream.inf.check.stored # stream.inf.check.calc THEN + stream.inf.state := InfBad; stream.inf.marker := 5; (* can't sync *) + SetMsg(stream.res, "incorrect data check") + ELSE + stream.inf.state := InfDone + END + + | InfDone: (* nothing more to do *) + stream.res.code := StreamEnd; + EXIT + | InfBad: (* error in stream *) + stream.res.code := DataError; + EXIT + END + END + END + END Inflate; + + (** set dictionary if inflate returned 'NeedDict' **) + PROCEDURE SetDictionary* (VAR stream: Stream; VAR dict: ARRAY OF CHAR; dictLen: LONGINT); + VAR len, idx: LONGINT; + BEGIN + IF stream.open & (stream.inf.state = InfDict0) THEN + IF Zlib.Adler32(1, dict, 0, dictLen) = stream.inf.check.stored THEN + len := dictLen; idx := 0; + IF len >= WindowSize THEN + len := WindowSize-1; + idx := dictLen - len + END; + SetBlockDict(stream, dict, idx, len); + stream.inf.state := InfBlocks; + stream.res.code := Ok + ELSE + stream.res.code := DataError; + END + ELSE + stream.res.code := StreamError + END + END SetDictionary; + + (** try to synchronize stream to end of block generated with 'SyncFlush' or 'FullFlush' **) + PROCEDURE Sync* (VAR stream: Stream); + VAR m: LONGINT; mark: ARRAY 4 OF CHAR; byte: CHAR; + BEGIN + IF ~stream.open THEN + stream.res.code := StreamError + ELSE + IF stream.inf.state # InfBad THEN + stream.inf.state := InfBad; stream.inf.marker := 0 + END; + IF stream.in.avail = 0 THEN + stream.res.code := BufError + ELSE + mark[0] := 0X; mark[1] := 0X; mark[2] := 0FFX; mark[3] := 0FFX; + m := stream.inf.marker; + WHILE (stream.in.avail > 0) & (m < 4) DO + ZlibBuffers.Read(stream.in, byte); + IF byte = mark[m] THEN INC(m) + ELSIF byte = 0X THEN m := 0 + ELSE m := 4-m + END; + END; + stream.inf.marker := SHORT(m); + + IF m # 4 THEN (* need more characters in order to decide *) + stream.res.code := DataError + ELSE + Reset0(stream); + stream.inf.state := InfBlocks; + stream.res.code := Ok + END + END + END + END Sync; + + (** return if inflate is currently at end of block generated with 'SyncFlush' or 'FullFlush' **) + PROCEDURE SyncPoint* (VAR stream: Stream): BOOLEAN; + BEGIN + IF stream.open THEN + RETURN BlockSyncPoint(stream) + ELSE + stream.res.code := StreamError; + RETURN FALSE + END + END SyncPoint; + + (** uncompress complete stream and return output length in len **) + PROCEDURE Uncompress* (VAR src, dst: ARRAY OF CHAR; srcoffset, srclen, dstoffset, dstlen: LONGINT; VAR len: LONGINT; VAR res: Result); + VAR s: Stream; + BEGIN + ZlibBuffers.Init(s.in, src, srcoffset, srclen, srclen); + ZlibBuffers.Init(s.out, dst, dstoffset, dstlen, dstlen); + Open(s, TRUE); + IF s.res.code = Ok THEN + Inflate(s, Finish); + IF s.res.code = StreamEnd THEN + len := s.out.totalOut; + Close(s); + res := s.res + ELSE + res := s.res; + IF res.code = Ok THEN res.code := BufError END; + Close(s) + END + ELSE + res := s.res + END + END Uncompress; + + +BEGIN + FixedBuilt := FALSE; + Order[0] := 16; Order[1] := 17; Order[2] := 18; Order[3] := 0; Order[4] := 8; Order[5] := 7; Order[6] := 9; + Order[7] := 6; Order[8] := 10; Order[9] := 5; Order[10] := 11; Order[11] := 4; Order[12] := 12; Order[13] := 3; + Order[14] := 13; Order[15] := 2; Order[16] := 14; Order[17] := 1; Order[18] := 15 +END ZlibInflate. diff --git a/src/lib/s3/ZlibReaders.Mod b/src/lib/s3/ZlibReaders.Mod new file mode 100644 index 00000000..23100cc7 --- /dev/null +++ b/src/lib/s3/ZlibReaders.Mod @@ -0,0 +1,113 @@ +(* ETH Oberon, Copyright 2001 ETH Zuerich Institut fuer Computersysteme, ETH Zentrum, CH-8092 Zuerich. +Refer to the "General ETH Oberon System Source License" contract available at: http://www.oberon.ethz.ch/ *) + +MODULE ZlibReaders; (** Stefan Walthert **) + +IMPORT + Files := OakFiles, Zlib, ZlibBuffers, ZlibInflate; + +CONST + (** result codes **) + Ok* = ZlibInflate.Ok; StreamEnd* = ZlibInflate.StreamEnd; + FileError* = -1; StreamError* = ZlibInflate.StreamError; DataError* = ZlibInflate.DataError; BufError* = ZlibInflate.BufError; + + BufSize = 4000H; + +TYPE + (** structure for reading from a file with deflated data **) + Reader* = RECORD + res-: LONGINT; (** current stream state **) + crc32-: LONGINT; (* crc32 of uncompressed data *) + wrapper-: BOOLEAN; (** if set, a zlib header and a checksum are present **) + eof: BOOLEAN; (* set if at end of input file and input buffer empty *) + r: Files.Rider; + in: POINTER TO ARRAY BufSize OF CHAR; (* input buffer space *) + s: ZlibInflate.Stream; (* decompression stream *) + END; + + +(** open reader on a Rider for input; is wrapper is not set, no zlib header and no checksum are present **) +PROCEDURE Open*(VAR r: Reader; wrapper: BOOLEAN; VAR fr: Files.Rider); +BEGIN + r.wrapper := wrapper; + r.eof := fr.eof; + ZlibInflate.Open(r.s, wrapper); + IF r.s.res.code = ZlibInflate.Ok THEN + NEW(r.in); ZlibBuffers.Init(r.s.in, r.in^, 0, BufSize, 0); + r.crc32 := Zlib.CRC32(0, r.in^, -1, -1); + r.r := fr; + r.res := Ok + ELSE + r.res := r.s.res.code + END +END Open; + +(** read specified number of bytes into buffer and return number of bytes actually read **) +PROCEDURE ReadBytes*(VAR r: Reader; VAR buf: ARRAY OF CHAR; offset, len: LONGINT; VAR read: LONGINT); +BEGIN + ASSERT((0 <= offset) & (0 <= len) & (offset + len <= LEN(buf)), 100); + IF ~r.s.open THEN + r.res := StreamError; read := 0 + ELSIF (r.res < Ok) OR (r.res = StreamEnd) OR (len <= 0) THEN + read := 0 + ELSE + ZlibBuffers.Init(r.s.out, buf, offset, len, len); + WHILE (r.s.out.avail # 0) & (r.res = Ok) DO + IF r.s.in.avail = 0 THEN + Files.ReadBytes(r.r, r.in^, BufSize); + ZlibBuffers.Rewind(r.s.in, BufSize - r.r.res); + IF r.s.in.avail = 0 THEN + r.eof := TRUE; + IF r.r.res < 0 THEN + r.res := FileError + END + END + END; + IF r.res = Ok THEN + ZlibInflate.Inflate(r.s, ZlibInflate.NoFlush); + r.res := r.s.res.code + END + END; + r.crc32 := Zlib.CRC32(r.crc32, buf, offset, len - r.s.out.avail); + read := len - r.s.out.avail + END +END ReadBytes; + +(** read decompressed byte **) +PROCEDURE Read*(VAR r: Reader; VAR ch: CHAR); +VAR + buf: ARRAY 1 OF CHAR; read: LONGINT; +BEGIN + ReadBytes(r, buf, 0, 1, read); + ch := buf[0] +END Read; + +(** close reader **) +PROCEDURE Close*(VAR r: Reader); +BEGIN + ZlibInflate.Close(r.s); + r.in := NIL; + IF r.res = StreamEnd THEN + r.res := Ok + END +END Close; + +(** uncompress deflated data from scr and write them to dst **) +PROCEDURE Uncompress*(VAR src, dst: Files.Rider; VAR crc32: LONGINT; VAR res: LONGINT); +VAR + r: Reader; buf: ARRAY BufSize OF CHAR; read: LONGINT; +BEGIN + Open(r, FALSE, src); + IF r.res = Ok THEN + REPEAT + ReadBytes(r, buf, 0, BufSize, read); + Files.WriteBytes(dst, buf, read) + UNTIL (r.res # Ok) OR (read = 0); + crc32 := r.crc32; + Close(r) + END; + res := r.res +END Uncompress; + + +END ZlibReaders. diff --git a/src/lib/s3/ZlibWriters.Mod b/src/lib/s3/ZlibWriters.Mod new file mode 100644 index 00000000..4e6d2ebd --- /dev/null +++ b/src/lib/s3/ZlibWriters.Mod @@ -0,0 +1,161 @@ +(* ETH Oberon, Copyright 2001 ETH Zuerich Institut fuer Computersysteme, ETH Zentrum, CH-8092 Zuerich. +Refer to the "General ETH Oberon System Source License" contract available at: http://www.oberon.ethz.ch/ *) + +MODULE ZlibWriters; (** Stefan Walthert **) + +IMPORT + Files := OakFiles, Zlib, ZlibBuffers, ZlibDeflate; + +CONST + (** result codes **) + Ok* = ZlibDeflate.Ok; StreamEnd* = ZlibDeflate.StreamEnd; + StreamError* = ZlibDeflate.StreamError; DataError* = ZlibDeflate.DataError; BufError* = ZlibDeflate.BufError; + + (** flush values **) + NoFlush* = ZlibDeflate.NoFlush; + SyncFlush* = ZlibDeflate.SyncFlush; + FullFlush* = ZlibDeflate.FullFlush; + + (** compression levels **) + DefaultCompression* = ZlibDeflate.DefaultCompression; NoCompression* = ZlibDeflate.NoCompression; + BestSpeed* = ZlibDeflate.BestSpeed; BestCompression* = ZlibDeflate.BestCompression; + + (** compression strategies **) + DefaultStrategy* = ZlibDeflate.DefaultStrategy; Filtered* = ZlibDeflate.Filtered; HuffmanOnly* = ZlibDeflate.HuffmanOnly; + + BufSize = 10000H; + +TYPE + (** structure for writing deflated data in a file **) + Writer* = RECORD + res-: LONGINT; (** current stream state **) + flush-: SHORTINT; (** flush strategy **) + wrapper-: BOOLEAN; (** if set, zlib header and checksum are generated **) + r: Files.Rider; (* file rider *) + pos: LONGINT; (* logical position in uncompressed input stream *) + crc32-: LONGINT; (** crc32 of uncompressed data **) + out: POINTER TO ARRAY BufSize OF CHAR; (* output buffer space *) + s: ZlibDeflate.Stream (* compression stream *) + END; + + +(** change deflate parameters within the writer **) +PROCEDURE SetParams*(VAR w: Writer; level, strategy, flush: SHORTINT); +BEGIN + IF flush IN {NoFlush, SyncFlush, FullFlush} THEN + ZlibDeflate.SetParams(w.s, level, strategy); + w.flush := flush; + w.res := w.s.res + ELSE + w.res := StreamError + END +END SetParams; + +(** open writer on a Files.Rider **) +PROCEDURE Open*(VAR w: Writer; level, strategy, flush: SHORTINT; wrapper: BOOLEAN; r: Files.Rider); +BEGIN + IF flush IN {NoFlush, SyncFlush, FullFlush} THEN + w.flush := flush; + w.wrapper := wrapper; + ZlibDeflate.Open(w.s, level, strategy, FALSE); + IF w.s.res = Ok THEN + NEW(w.out); ZlibBuffers.Init(w.s.out, w.out^, 0, BufSize, BufSize); + w.crc32 := Zlib.CRC32(0, w.out^, -1, -1); + w.r := r; + w.res := Ok + ELSE + w.res := w.s.res + END + ELSE + w.res := StreamError + END +END Open; + +(** write specified number of bytes from buffer into and return number of bytes actually written **) +PROCEDURE WriteBytes*(VAR w: Writer; VAR buf: ARRAY OF CHAR; offset, len: LONGINT; VAR written: LONGINT); +BEGIN + ASSERT((0 <= offset) & (0 <= len) & (len <= LEN(buf)), 110); + IF ~w.s.open THEN + w.res := StreamError; written := 0 + ELSIF (w.res < Ok) OR (len <= 0) THEN + written := 0 + ELSE + ZlibBuffers.Init(w.s.in, buf, offset, len, len); + WHILE (w.res = Ok) & (w.s.in.avail # 0) DO + IF (w.s.out.avail = 0) THEN + Files.WriteBytes(w.r, w.out^, BufSize); + ZlibBuffers.Rewrite(w.s.out) + END; + IF w.res = Ok THEN + ZlibDeflate.Deflate(w.s, w.flush); + w.res := w.s.res + END + END; + w.crc32 := Zlib.CRC32(w.crc32, buf, offset, len - w.s.in.avail); + written := len - w.s.in.avail + END; +END WriteBytes; + +(** write byte **) +PROCEDURE Write*(VAR w: Writer; ch: CHAR); +VAR + buf: ARRAY 1 OF CHAR; + written: LONGINT; +BEGIN + buf[0] := ch; + WriteBytes(w, buf, 0, 1, written) +END Write; + +(** close writer **) +PROCEDURE Close*(VAR w: Writer); +VAR + done: BOOLEAN; + len: LONGINT; +BEGIN + ASSERT(w.s.in.avail = 0, 110); + done := FALSE; + LOOP + len := BufSize - w.s.out.avail; + IF len # 0 THEN + Files.WriteBytes(w.r, w.out^, len); + ZlibBuffers.Rewrite(w.s.out) + END; + IF done THEN EXIT END; + ZlibDeflate.Deflate(w.s, ZlibDeflate.Finish); + IF (len = 0) & (w.s.res = BufError) THEN + w.res := Ok + ELSE + w.res := w.s.res + END; + done := (w.s.out.avail # 0) OR (w.res = StreamEnd); + IF (w.res # Ok) & (w.res # StreamEnd) THEN EXIT END + END; + ZlibDeflate.Close(w.s); + w.res := w.s.res +END Close; + +(** compress srclen bytes from src to dst with specified level and strategy. dstlen returns how many bytes have been written. **) +PROCEDURE Compress*(VAR src, dst: Files.Rider; srclen: LONGINT; VAR dstlen: LONGINT; level, strategy: SHORTINT; VAR crc32: LONGINT; VAR res: LONGINT); +VAR + w: Writer; buf: ARRAY BufSize OF CHAR; totWritten, written, read: LONGINT; +BEGIN + Open(w, level, strategy, NoFlush, FALSE, dst); + IF w.res = Ok THEN + totWritten := 0; + REPEAT + IF (srclen - totWritten) >= BufSize THEN read := BufSize + ELSE read := srclen - totWritten + END; + Files.ReadBytes(src, buf, read); + WriteBytes(w, buf, 0, read - src.res, written); + INC(totWritten, written) + UNTIL (w.res # Ok) OR (totWritten >= srclen); + Close(w); + crc32 := w.crc32; + dstlen := Files.Pos(w.r) - Files.Pos(dst); + END; + res := w.res +END Compress; + + +END ZlibWriters. diff --git a/src/lib/v4/OakFiles.Mod b/src/lib/v4/OakFiles.Mod index 1cbc274f..9a20afd8 100644 --- a/src/lib/v4/OakFiles.Mod +++ b/src/lib/v4/OakFiles.Mod @@ -626,6 +626,11 @@ Especially Length would become fairly complex. Write(R, CHR(x MOD 128)) END WriteNum; + PROCEDURE GetName*(f: File; VAR name: ARRAY OF CHAR); + BEGIN + COPY (f.workName, name); + END GetName; + PROCEDURE Finalize(o: SYSTEM.PTR); VAR f: File; res: LONGINT; BEGIN