Delphi & Pascal (česká wiki)
Přejít na: navigace, hledání
{ LZO.PAS                                                              }
{                                                                      }
{ LZO.PAS - object-oriented interface for LZH.PAS                      }
{ see: http://en.wikipedia.org/wiki/LHA_(file_format)#Canonical_LZH    }
{                                                                      }
{   LZO.PAS based on:                                                  }
{                                                                      }
{   LZHUF.C English version 1.0 based on Japanese version 29-NOV-1988  }
{   Haruhiko OKUMURA:   LZSS coded                                     }
{   Haruyasu YOSHIZAKI: Adaptive Huffman Coding coded                  }
{   Kenji RIKITAKE:     Edited and translated to English               }
{   Peter Sawatzki,                                                    }
{   Wayne Sullivan:     Converted to Turbo Pascal 5.0                  }
{   Joe Jared:          Assembler and Atari Port (12/16/92.. ??/??/??) }
{   Andres Cvitkovich:  object-oriented interface   (TP5.5+)           }
{                                                                      }
{ note:  ONLY ONE INSTANCE OF THUFF (OR DERIVATES) MAY BE USED BY NOW. }
{        YOU MUST ASSURE THIS IN YOUR PROGRAMS.                        }
{        THAT MEANS, USAGE OF THUFF IS A 'CRITICAL SECTION'.           }
{                                                                      }
{ Datum: 31.07.1993                              http://www.trsek.com  }
 
{$A+,B-,D+,E+,F-,G-,I+,L+,N+,O+,R-,S+,V-,X+}
 
unit LZO;
 
interface uses LZH;
 
const EngineVer = LZH.EngineVer;
 
type PHuff = ^THuff;
     THuff = Object                     {*** abstract - inherit for use! ***}
       Compressing: boolean;     { true on compression, false on decompress }
       constructor Init;
       destructor  Done; virtual;
       function    Compress (Bytes: longint): longint; virtual;
       procedure   Expand; virtual;
       function    ReadBuf (var data; size: word): longint; virtual;
       function    WriteBuf (var data; size: word): longint; virtual;
                   { have to return n/of bytes actually read/written
                     or -1 on error (unix-like) }
       procedure   Error (code: integer); virtual;
                   { code=0: error reading, 1: error writing }
     END;
 
var LZHused: boolean;                         { true if unit already in use }
 
implementation
 
var ActualHuff: PHuff;
 
procedure ReadBufLo; far;               { lo-level procedure, called by LZH }
var res: longint;
begin
  with LZHMem^ do begin
    inptr := 0;
    res   := ActualHuff^.ReadBuf (inbuf, SizeOf (inbuf));
    if res = -1 then begin
      ActualHuff^.Error (0);
      inend := 0
    end else
      inend := word (res)
  end
end;
 
procedure WriteBufLo; far;              { lo-level procedure, called by LZH }
begin
  with LZHMem^ do begin
    if ActualHuff^.WriteBuf (outbuf, outptr) <> outptr then
      ActualHuff^.Error (1);
    outptr := 0
  end
end;
 
constructor THuff.Init;
begin
  if LZHused then exit else LZHused := TRUE;
  ActualHuff := @Self;
  InitLZH;
  LZHMem^.outend := SizeOf (LZHMem^.outbuf);          {> unsure about these }
  LZHMem^.outptr := 0;                                {> two lines (placed) }
end;
 
destructor THuff.Done;
begin
  ActualHuff := NIL;
  DInitLZH;
  LZHused := FALSE
end;
 
function THuff.Compress (Bytes: longint): longint;
begin
  Compressing := TRUE;
  {ReadBufLo;}
  LZHMem^.Ebytes := Bytes;
  Encode;
  Compress := LZHMem^.codesize
end;
 
procedure THuff.Expand;
begin
  Compressing := FALSE;
 { ReadBufLo;}
  Decode
end;
 
function THuff.ReadBuf (var data; size: word): longint;
begin
  Writeln ('*** ABSTRACT METHOD HAS BEEN CALLED! ***');
  Halt (255)
end;
 
function THuff.WriteBuf (var data; size: word): longint;
begin
  Writeln ('*** ABSTRACT METHOD HAS BEEN CALLED! ***');
  Halt (255)
end;
 
procedure THuff.Error (code: integer);
begin
  Write ('*** ERROR ');
  if code=0 then
    Write ('READ')
  else
    Write ('WRIT');
  Writeln ('ING DATA ***');
  Halt (255)
end;
 
begin
  ReadToBuffer    := ReadBufLo;
  WriteFromBuffer := WriteBufLo;
  LZHused := FALSE
end.