{ XLA.PAS                                   Copyright (c) Ivan Rebo }
{ https://github.com/IRebo/utek/tree/master/old-199x-version        }
{                                                                   }
{ Author: Ivan Rebo                                                 }
{ Datum: 20.01.1995                           http://www.trsek.com  }

Unit XLA;
{#F}
{$I-}
{$G+,N-,E-}

Interface

Uses
	XMisc2, Dos;

Const
	None = 0; {No compression : store only}
	LZS  = 1; {LZS77 compression algorithm}
	Best = 8; {Not Used}
Type
	XLAOutProcType = procedure( var Data; size : word );
	XLAInProcType  = procedure( var Data; size : word; var actual : longint );
Var
	ModeUsed : word;
	XLAOutProc : XLAOutProcType;
{ This procedure is called by the XLA decoding routines everytime a new
	packet of data has been uncompressed. The data is stored in data and the
	amount of data is stored in size. The procedure that is pointed at by
	this variable must be declared far.}
	XLAInProc  : XLAInProcType;
{ This procedure is called by the XLA encoding routines everytime a new
	packet of data is requested. The data has to be stored in data and the
	amount of data that has to be passed back is stored in size.
	If size bytes can't be provided then the actual amount of data
	transferred is put in actual. If there is no more data, then actual must
	be set to 0. The procedure that is pointed at by this variable must be
	declared far.}
	ratio : integer;
{ This variable contains the compression ratio in % of the last file that
	was added to the archive with XLAPut. The value is invalid if no files
	have been added. }
Function  XLZSLoad( FName : string ) : boolean;
{ Loads a standalone file with name FName. Calls XLAOutProc. Returns true if
	successful, false otherwise.}
function  XCloseArchive : boolean;
{ This function has to be called when the program doesn't need to access the
	XLA file any more. If the archive was opened with XCreateArchive or
	XUpdateArchive the the XEndArchive function must be called instead,
	otherwise the XLA file will be corrupt. Frees all the memory allocated to
	the uncompression routines. Returns true if successful.}
function  XOpenArchive( filename : string ) : boolean;
{ Opens an already existing XLA file for reading. Reads in the archive's
	directory. Returns true if successful.}
function  XLAGet( fname : string ) : boolean;
{ Extracts a file from the currently open archive. Calls XLAOutProc.
	Returns true if successful.}
function  XLAGetFileInfo( fname : string; var origsize, compsize : longint; mode : word ) : boolean;
{ Collects information about a particular file in the archive. Origsize
	contains the length of the uncompressed file. Compsize contains the size of
	the compressed file. Mode contains the algorithm used to store the file.
	Returns true if successful.}
function  XLAFindFirst( pattern : string; var match : string ) : boolean;
{ Searches through the archive's directory for the first file matching pattern.
	and returns it in match. pattern can contain * wildcards in the standard DOS
	notation. It doesn't support ? wildcards. Returns true if successful.}
function  XLAFindNext( var match : string ) : boolean;
{ Finds the next file matching the pattern given in a previous call to
	XLAFindFirst and returns it in match. Returns true if successful.}
Implementation

const
	TableSize = 5003;
	LargestCode = 4095;
	NoCode = -1;
	N           = 4096;
	F           = 18;
	THRESHOLD   = 2;
	NUL         = N * 2;

	BUFSIZE = 1024;
	InBufPtr  : WORD = BUFSIZE;
	InBufSize : WORD = BUFSIZE;
	OutBufPtr : WORD = 0;

Type
	PWorkspace = ^TWorkspace;
	TWorkspace = record
		TextBuf : Array[0.. N + F - 2] OF byte;
		Left,Mom:  Array [0..N] OF word;
		Right: Array [0..N + 256] OF word;
	end;

	THeader = record
		sig : array[0..3] of char;
		posdir, sizedir : longint;
	end;

	TFile = record
		name : array[0..11] of char;
		posfile, sizefile, sizecomp : longint;
		algorithm : word;
	end;

	PXLADir = ^TXLADir;
	TXLADir = record
		item : TFile;
		next : PXLADir;
	end;

Var
	XLAFile : File;
	Header : THeader;
	XLADir, CurrentDir : PXLADir;
	TotalSize, BytesWritten : longint;

	printcount, height,
	matchPos, matchLen,
	lastLen, printPeriod : WORD;
	opt : BYTE;
	SearchPattern : string;

	Workspace : PWorkspace;

	codeBuf: Array [0..16] of BYTE;

	Inbuf,OutBuf : Array[0..PRED(BUFSIZE)] of BYTE;

	ArchiveOpen : boolean;

Procedure InitBuffers;
var
	tmp : ^byte;
begin
	while true do
	begin
		new( Workspace );
		if ofs(Workspace^)<>0 then
		begin
			dispose( Workspace );
			new( tmp );
		end else break;
	end;
end;

Procedure CleanUp;
begin
	Dispose( Workspace );
end;

procedure CleanUpAll;
var
	tmp : PXLADir;
begin
	while XLADir<>nil do
	begin
		tmp := XLADir^.next;
		dispose( XLADir );
		XLADir := tmp;
	end;
	CleanUp;
end;


Function MemoryReadChunk: word;

var
	Actual : longint;

begin
	XLAInProc( InBuf, BufSize, Actual );
	TotalSize := TotalSize + Actual;
	MemoryReadChunk := Actual;
end;

Procedure MemoryGetc; Assembler;
asm
	push    bx
	mov     bx, inBufPtr
	cmp     bx, inBufSize
	jb      @getc1
	push    cx
	push    dx
	push    di
	push    si
	call    MemoryReadChunk
	pop     si
	pop     di
	pop     dx
	pop     cx
	mov     inBufSize, ax
	or      ax, ax
	jz      @getc2
	xor     bx, bx
@getc1:
	mov     al, [Offset InBuf + bx]
	inc     bx
	mov     inBufPtr, bx
	pop     bx
	clc
	jmp     @end
@getc2:
	pop     bx
	stc
@end:
end;

Function DiskReadChunk: word;

var
	Actual : WORD;

begin
	if Bufsize > TotalSize then
		Actual := TotalSize
	else
		Actual := BufSize;
	if Actual > 0 then BlockRead(XLAFile,InBuf,Actual);
	TotalSize := TotalSize - Actual;
	DiskReadChunk := Actual;
end;

Procedure DiskGetc; Assembler;
asm
	push    bx
	mov     bx, inBufPtr
	cmp     bx, inBufSize
	jb      @getc1
	push    cx
	push    dx
	push    di
	push    si
	call    DiskReadChunk
	pop     si
	pop     di
	pop     dx
	pop     cx
	mov     inBufSize, ax
	or      ax, ax
	jz      @getc2
	xor     bx, bx
@getc1:
	mov     al, [Offset InBuf + bx]
	inc     bx
	mov     inBufPtr, bx
	pop     bx
	clc
	jmp     @end
@getc2:
	pop     bx
	stc
@end:
end;

Procedure MemoryWriteout;
begin
	XLAOutProc( OutBuf, OutBufPtr );
	BytesWritten := BytesWritten + OutBufPtr;
end;

Procedure MemoryPutc; Assembler;
asm
	push    bx
	mov     bx, outBufPtr
	mov     [OFFSet OutBuf + bx], al
	inc     bx
	cmp     bx, BUFSIZE
	jb      @putc1
	mov     OutBufPtr,BUFSIZE
	push    cx
	push    dx
	push    di
	push    si
	call    MemoryWriteOut
	pop     si
	pop     di
	pop     dx
	pop     cx
	xor     bx, bx
@putc1:
	mov     outBufPtr, bx
	pop     bx
end;

Procedure LZSDecode; Assembler;
asm
	les     dx, Workspace
	xor     dx, dx
	mov     di, N - F
@Decode2:
	shr     dx, 1
	or      dh, dh
	jnz     @Decode3
	push    es
	call    DiskGetC
	pop     es
	jc      @Decode9
	mov     dh, 0ffh
	mov     dl, al
@Decode3:
	test    dx, 1
	jz      @Decode4
	push    es
	call    DiskGetC
	pop     es
	jc      @Decode9
	mov     byte ptr es:[Offset TWorkspace.TextBuf + di], al
	inc     di
	and     di, N - 1
	push    es
	call    MemoryPutC
	pop     es
	jmp     @Decode2
@Decode4:
	push    es
	call    DiskGetC
	pop     es
	jc      @Decode9
	mov     ch, al
	push    es
	call    DiskGetC
	pop     es
	jc      @Decode9
	mov     bh, al
	mov     cl, 4
	shr     bh, cl
	mov     bl, ch
	mov     cl, al
	and     cl, 0fh
	add     cl, THRESHOLD
	inc     cl
@Decode5:
	and     bx, N - 1
	mov     al, byte ptr es:[Offset TWorkspace.TextBuf + bx]
	mov     byte ptr es:[Offset TWorkspace.TextBuf + di], al
	inc     di
	and     di, N - 1
	push    es
	call    MemoryPutC
	pop     es
	inc     bx
	dec     cl
	jnz     @Decode5
	jmp     @Decode2
@Decode9:
END;

function XLZSLoad( FName : string ) : boolean;
begin
	if ArchiveOpen then
	begin
		XLZSLoad := false;
		exit;
	end;
	assign( XLAFile, Fname );
	reset( XLAFile, 1 );
	if ioresult <> 0 then
	begin
		XLZSLoad := false;
		exit;
	end;
	TotalSize := filesize( XLAFile );
	InitBuffers;
	InBufPtr  := BUFSIZE;
	InBufSize := BUFSIZE;
	OutBufPtr := 0;
	FillChar(Workspace^.TextBuf,N+F-1,0);
	BytesWritten := 0;
	LZSdecode;
	MemoryWriteOut;
	close(XLAFile);
	CleanUp;
	XLZSLoad := true;
end;

procedure AddName( var P, Q : PXLADir );
begin
	if P<>nil then
		AddName( P^.next, Q )
	else
		P := Q;
end;

function XEndArchive : boolean;
var
	tmp : PXLADir;
begin
	if not ArchiveOpen then
	begin
		XEndArchive := false;
		exit;
	end;
	seek(XLAFile, header.posdir);
	tmp := XLADir;
	while tmp<>nil do
	begin
		blockwrite( XLAFile, tmp^.item, sizeof(TFile) );
		tmp := tmp^.next;
	end;
	seek( XLAFile, 0 );
	blockwrite( XLAFile, Header, SizeOf(THeader) );
	close( XLAFile );
	CleanUpAll;
	ArchiveOpen := false;
	XEndArchive := true;
end;

function XLAGetFileInfo( fname : string; var origsize, compsize : longint; mode : word ) : boolean;
var
	tmp : PXLADir;
	name : array[0..11] of char;
	i : integer;
begin
	if not ArchiveOpen then
	begin
		XLAGetFileInfo := false;
		exit;
	end;
	for i := 1 to 12 do
		if i<=length( fname ) then
			name[i-1] := fname[i]
		else
			name[i-1] := ' ';
	tmp :=XLADir;
	if tmp = nil then
	begin
		XLAGetFileInfo := false;
		exit;
	end;
	while not xcompare( name, tmp^.item.name, 13 ) do
	begin
		if tmp^.next = nil then
		begin
			XLAGetFileInfo := false;
			exit;
		end;
		tmp := tmp^.next;
	end;
	origsize := tmp^.item.sizefile;
	compsize := tmp^.item.sizecomp;
	mode := tmp^.item.algorithm;
	XLAGetFileInfo := true;
end;

function XLAGet( fname : string ) : boolean;
var
	i : integer;
	name : array[0..11] of char;
	tmp : PXLADir;
begin
	if not ArchiveOpen then
	begin
		XLAGet := false;
		exit;
	end;
	for i := 1 to 12 do
		if i<=length( fname ) then
			name[i-1] := fname[i]
		else
			name[i-1] := ' ';

	tmp := XLADir;

	while not( xcompare( name, tmp^.item.name, 13 ) ) do
	begin
		if tmp = nil then
		begin
			XLAGet := false;
			exit;
		end;
		tmp := tmp^.next;
	end;
	seek( XLAFile, tmp^.item.posfile );
	TotalSize := tmp^.item.sizecomp;
	InBufPtr  := bufsize;
	Inbufsize := bufsize;
	OutBufPtr := 0;
	FillChar(Workspace^.TextBuf,N+F-2,0);
	case tmp^.item.algorithm of
		None :
			begin
				while TotalSize >0 do
				begin
					if TotalSize >= bufsize then
						InBufSize := bufsize
					else
						InBufSize := TotalSize;
					blockread( XLAFile, InBuf, InBufSize );
					XLAOutProc( InBuf, InBufSize );
					TotalSize := TotalSize - InBufSize;
				end;
				ModeUsed := None;
			end;
		LZS :
			begin
				LZSdecode;
				MemoryWriteOut;
				ModeUsed := LZS;
			end;
	end;
	XLAGet := true;
end;

function XOpenArchive( filename : string ) : boolean;
var
	i : integer;
	tmp : PXLADir;
	sig : string[4];
begin
	if ArchiveOpen then
	begin
		XOpenArchive := false;
		exit;
	end;
	assign( XLAFile, filename );
	FileMode := 0;
	reset( XLAFile,1);
	FileMode := 2;
	if ioresult<>0 then
	begin
		XOpenArchive := false;
		exit;
	end;
	blockread( XLAFile, Header, sizeof(THeader) );
	sig := 'HOES';
	if not xcompare( Header.sig,sig[1],4 ) then
	begin
		XOpenArchive := false;
		exit;
	end;
	InitBuffers;
	XLADir := nil;
	seek( XLAFile, Header.posdir );
	for i := 1 to Header.sizedir do
	begin
		new(tmp);
		blockread( XLAFile, tmp^.item, sizeof(TFile) );
		tmp^.next := nil;
		AddName(XLADir, tmp);
	end;
	ArchiveOpen := true;
	XOpenArchive := true;
end;

function XCloseArchive : boolean;
begin
	if not ArchiveOpen then
		XCloseArchive := false
	else
	begin
		close( XLAFile );
		CleanUpAll;
		ArchiveOpen := false;
		XCloseArchive := true;
	end;
end;

function XLAFindNext( var match : string ) : boolean;
var
	d1, d2 : DirStr;
	n1, n2 : NameStr;
	e1, e2 : ExtStr;
	filename : PathStr;
	i : integer;
	wildname, wildext : byte;
	prefixname, prefixext : string[12];
	matchname, matchext : boolean;
begin
	FSplit( SearchPattern, d1, n1, e1 );
	wildname := pos( '*',n1 );
	wildext  := pos( '*',e1 );
	prefixname := copy( n1, 1, wildname-1 );
	prefixext  := copy( e1, 1, wildext-1 );

	while CurrentDir<>nil do
	begin
		move( CurrentDir^.item.name[0], filename[1], 12 );
		i := 0;
		while (i<=11) and ( CurrentDir^.item.name[i]<>' ') do
			inc(i);
		filename[0] := chr(i);
		FSplit( filename, d2, n2, e2 );
		if e2 ='' then e2 :='.';
		matchname := ((wildname=0) and (n1=n2)) or
								 ((wildname>0) and (copy(n2,1,wildname-1)=prefixname));
		matchext  := ((wildext=0) and (e1=e2)) or
								 ((wildext>0) and (copy(e2,1,wildext-1)=prefixext));
		if matchname and matchext then
		begin
			match := filename;
			CurrentDir := CurrentDir^.next;
			XLAFindNext := true;
			exit;
		end else
			CurrentDir := CurrentDir^.next;
	end;
	XLAFindNext := false;
end;

function XLAFindFirst( pattern : string; var match : string ) : boolean;
begin
	CurrentDir := XLADir;
	SearchPattern := pattern;
	XLAFindFirst := XLAFindNext( match );
end;
begin
	ArchiveOpen := false;
	XLADir := nil;
end.