chieflz.pas

delhpi下lzss加密算法源码及例子

{$ifdef Windows}
  faFiles = faReadOnly+faSysFile+faHidden+faArchive+0;
  faDirs  = faSysFile+faHidden+faDirectory+0;
{$else Windows}
  faFiles = ReadOnly+SysFile+Hidden+Archive+0;
  faDirs  = SysFile+Hidden+Directory+0;
{$endif Windows}

VAR
{$ifdef Windows}
 Dir:  TSearchRec;
{$else Windows}
 Dir:  SearchRec;
{$endif Windows}

{$ifndef Win32}
OldFMode   : byte;
Temp       : TLZPathStr;
l, LZTot   : LongInt;
{$endif Win32}

Path,
s1, s2     : TLZPathStr;
fSpecName  : TLZPathStr;
i          : LongInt;
t          : Text;
UseFile    : boolean;
Hed        : TLZArchiveHeader;
FoundName  : TLZPathStr;
MemRec,
DirCount,
DirCountEx : TLZSSWord;
DirArray   : PLZDirArray;
DirTimes   : PDirTimes;
PIndex     : LongInt;
NewPIndex  : LongInt;
RepRec     : TLZReportRec;

begin
{$ifdef aDLL}
  if IsLZInitialized then
  {$ifdef Win32}
    RaiseError(EChiefLZDLL,SBusyChief);
  {$else}
    begin
      LZArchive := -20; {busy}
      Exit
    end
  {$endif};
 {$endif aDLL}

  if not LZInit then
  {$ifdef Win32}
    RaiseError(EChiefLZError,SInitFailed);
  {$else}
    begin
      LZArchive := -10; {init error}
      Exit
    end;
  {$endif}

 {$ifdef Win32}
  try { finally }
 {$endif}

  s1:= {$ifdef Win32} fSpec
       {$else}        StrPas(fSpec)
       {$endif};
  s2:= {$ifdef Win32} ExpandFileName(ArchName)
       {$else}        StrPas(ArchName)
       {$endif};

 {are we reading from a file?}
  UseFile := False;
  i := Pos('/F=', Uppercase(s1));
  If i > 0 then
    begin
      Delete(s1, 1, i+2);
      UseFile := True;
      LZRecurseDirs := LZNoRecurse
    end;

  if (Length(s1)=0) or (Length(s2)=0) then
  {$ifdef Win32}
    RaiseError(EChiefLZError,SInvalidParams);
  {$else}
    begin
      LZDone;
      Exit
    end;
  {$endif}

{$ifdef Win32}

  s1 := ExpandFileName(s1);
  if AnsiCompareText(s1,s2) = 0 then
    RaiseErrorStr(EChiefLZArchive,SSameFileName,s1);

  AssignFile(OutFile, s2);
  Rewrite(OutFile, 1);
  try { finally }
    Result := 0;

    New(jR);
    try { finally }           
      Hed.Count := 0;
      DirCount := 0;

    { get the filenames for the archive }
      if UseFile then { - use a LIST file }
        begin
          Path := '';
          AssignFile(t, s1);
          Reset(t);
          try { finally }
            while not EOF(t) do
              begin
                Readln(t,s1);
                if (Length(s1)<>0) and
                   (AnsiCompareText(s1,s2) <> 0) and
                    FileExists(s1) then
                  begin
                  {$IFDEF Debug}
                    if Hed.Count > MaxChiefLZArchiveSize then
                      raise EChiefLZDebug.Create('Too many archive files');
                  {$ENDIF}
                    if Hed.Count >= MaxChiefLZArchiveSize then
                      break;
                    inc(Hed.Count);
                    with jr^[Hed.Count] do
                      begin
                        IsBigDir := False;
                        BigDirID := 0;
                        BigCompressed := True;
                        uBigSizes := fSize(s1);
                        BigTimes := sfTime(s1);
                        BigFileVersion := GetFileVersion(s1);
                        BigNames := s1
                      end
                  end {s1 <> s2}
              end; {not EOF(t)}
            if Hed.Count = 0 then
              RaiseError(EChiefLZArchive, SNoValidFileName)
          finally
            CloseFile(t)
          end
        end
{
  We do not have a LIST file, so find filespecs ...
}
        else
          begin
            Path := ExtractFilePath(s1);
            fSpecName := ExtractFileName(s1);
            New(DirArray);
            try {finally}
              DirArray^[0] := Path;

              if LZRecurseDirs <> LZNoRecurse then
{
  `Recurse' through subdirectories for files matching the given mask.
  There are 2 levels of recursion - full recursion and immediate-subdirs...
}
              begin
                New(DirTimes);
                try {finally}

                  i := 0;
                  repeat
                    if (LZRecurseDirs <> LZNoRecurse) and
                       (FindFirst(DirArray^[i]+'*', faDirs, Dir) = 0) then
                    try {finally}
                      repeat
                        if Dir.Attr and faDirectory <> 0 then
                          begin
                            FoundName := GetFoundFileName(Dir);
                            if (FoundName <> '.') and
                               (FoundName <> '..') then
                              begin
                              {$IFDEF Debug}
                                if DirCount > MaxChiefLZDirectories then
                                  raise EChiefLZDebug.Create('DirArray^ bounds exceeded');
                              {$ENDIF}
                                if DirCount >= MaxChiefLZDirectories then
                                  break;
                                inc(DirCount);
                                DirArray^[DirCount] :=
                                                    DirArray^[i]+FoundName+'\';
                                DirTimes^[DirCount] := Dir.Time
                              end
                          end
                      until FindNext(Dir) <> 0
                    finally
                      SysUtils.FindClose(Dir)
                    end;

                    if i = 0 then
                      begin
                        Inc(i);
{
            Turn directory-recursion off - have only looked in
            immediate subdirectories ...
}
                        if LZRecurseDirs = LZRecurseOnce then
                          Dec(LZRecurseDirs)
                      end
                    else if not IsFileInDir(DirArray^[i]+fSpecName) then
                      begin
                        DirArray^[i] := '';  { Destroy string ... }
                        Move(DirArray^[i+1],
                             DirArray^[i],
                            (DirCount-i)*SizeOf(DirArray^[0]));
                        Move(DirTimes^[i+1],
                             DirTimes^[i],
                            (DirCount-i)*SizeOf(DirTimes^[1]));
{
  I think I'm messing too deeply with long strings here... If I am correct,
  then I need to set the element DirArray[DirCount] to be an empty string
  WITHOUT TAMPERING WITH THE REFERENCE COUNTS !!! I.e. the element must be
  typecast to a pointer and set to nil...
}
                        Pointer(DirArray[DirCount]) := nil;
                        Dec(DirCount)
                      end
                    else
                      begin
                        Inc(Hed.Count);
                        with jr^[Hed.Count] do
                          begin
                            IsBigDir  := True;
                            BigDirID  := i;
                            BigTimes  := DirTimes^[i];
{
  These two fields irrelevant for directories ...
}
                            BigSizes  := 0;
                            uBigSizes := 0;
{}
                            BigFileVersion := '-';
                            BigNames  := RemoveBackSlash(DirArray^[i])
                          end;
                        Inc(i)
                      end

                  until i > DirCount

                finally
                  Dispose(DirTimes)
                end;
{
  Find the parents for each directory ...
}
                DirCountEx := DirCount;
                for i := 1 to DirCount do
                  begin
{
  Search for a hole in the directory structure ...
}
                    FoundName :=
                            ExtractFilePath(RemoveBackSlash(DirArray^[i]));
                    PIndex := GetDirIndex(FoundName,DirArray,DirCountEx);
{
  If such a hole exists, we must store headers for all the missing
  directories between Path and FoundName WORKING FORWARDS, or we'll
  give some of the directories the wrong parents ...
}
                    if PIndex < 0 then
                      begin
                        PIndex := 0;
                        s1 := Path;
                        repeat
                          s1 := FirstDirectoryBetween(s1,FoundName);
                          NewPIndex := GetDirIndex(s1,DirArray,DirCountEx);
                          if NewPIndex < 0 then
                            begin
{
  Do we have room for another directory ... ?
}
                            {$IFDEF Debug}
                              if DirCountEx > MaxChiefLZDirectories then
                                raise EChiefLZDebug.Create('Too many ChiefLZ directories.');
                            {$ENDIF}
                              if DirCountEx >= MaxChiefLZDirectories then
                                Break;

                              inc(DirCountEx);
                              DirArray^[DirCountEx] := s1;
                              inc(Hed.Count);
                              with jr^[Hed.Count] do
                                begin
                                  BigNames := RemoveBackSlash(s1);
                                  BigTimes := NulFileDate;
                                  IsBigDir := True; 
                                  BigDirID := DirCountEx;
                                  BigParentDir := PIndex;
{
  These fields irrelevant for directories ...
}
                                  BigSizes  := 0;
                                  uBigSizes := 0;
{}
                                  BigFileVersion := '-'
                                end;
                              NewPIndex := DirCountEx
                            end;
                          PIndex := NewPIndex
                        until Length(s1) = Length(FoundName)
                      end; {PIndex < 0}
{
  Now we're sure it exists, store Parent-index for directory i ...
}
                    jr^[i].BigParentDir := PIndex

                  end { 1 <= i <= DirCount }
              end; { LZRecurseDirs }
{
   Look through the directory list (only the ones with files in!) and
   create an archive of files from them. Note that DirArray^[0] is
   the Path directory ...
}
              for i := 0 to DirCount do
                if FindFirst(DirArray^[i]+fSpecName, faFiles, Dir) = 0 then
                  try { finally }
                    repeat
                      s1 := DirArray^[i] + GetFoundFileName(Dir);
                    {$IFDEF Debug}
                    { Did not put faDirectory in Attr mask, so
                      **shouldn't** see any directories ...   }
                      if Dir.Attr and faDirectory <> 0 then
                        raise EChiefLZDebug.Create('Found directory when expecting file');
                    {$ENDIF}
{
  Check that we are not trying to archive the output file ...
}
                      if AnsiCompareText(s1,s2) <> 0 then
                        begin
                        {$IFDEF Debug}
                          if Hed.Count > MaxChiefLZArchiveSize then
                            raise EChiefLZDebug.Create('Max archive size exceeded.');
                        {$ENDIF}
                          if Hed.Count >= MaxChiefLZArchiveSize then
                            Break;
                          inc(Hed.Count);
                          with jr^[Hed.Count] do
                            begin
                              IsBigDir  := False;
                              BigDirID  := i;
                              BigCompressed := True;
                              uBigSizes := Dir.Size;
                              BigSizes  := Dir.Size;
                              BigTimes  := Dir.Time;
                              BigNames  := s1;
                              BigFileVersion := GetFileVersion(s1);
                            end
                        end
                    until FindNext(Dir) <> 0
                  finally
                    SysUtils.FindClose(Dir)
                  end

            finally
              Dispose(DirArray)
            end
          end;

        Hed.Signature := MyLZSignature;
        MemRec := SizeOf(TLZFileRec)*Hed.Count + SizeOf(TLZCount);

        {fix the header}
        GetMem(jr2, MemRec);
        try { finally }

          FillChar(jr2^, MemRec, 0);
          jr2^.Count := Hed.Count;
          for i := 1 to Hed.Count do
            with jr2^.Files[i], jr^[i] do
              begin
                IsDir  := IsBigDir;
                DirID  := BigDirID;
                ParentDir := BigParentDir;
                Compressed := BigCompressed;
                Sizes  := BigSizes;
                uSizes := uBigSizes;
                Times  := BigTimes;
                FileVersion := BigFileVersion;
                Names  := ExtractFileName(BigNames)
              end;
        { write the header }
          BlockWrite(OutFile, Hed.Signature, SizeOf(Hed.Signature));
                                                     {main header}
          BlockWrite(OutFile, jr2^, MemRec);         {file headers}

        { loop through each file }
          for i := 1+DirCount to Hed.Count do
            with jr^[i] do
              begin
                AssignFile(InFile,BigNames);
                InitReportRec(RepRec, jr^[i]);
                BlankRec := RepRec;

                FileMode := fmOpenRead; { Win32 only allows 0 <= FileMode <= 2 }
              {$I-}                     { However, share access is FILE_SHARE_READ }
                Reset(InFile, 1);
              {$I+}
                if IOResult <> 0 then    { Exception block generates   }
                  with jr2^.Files[i] do  { false compiler warning ...  }
                    begin                { Handle error using IOResult }
                      Sizes  := 0;
                      uSizes := 0;
                      Compressed := False;
                      Continue
                    end;

                try { finally }
               { report procedure }
                  inc(Result);
                  if Assigned(aProc) then aProc(RepRec,-1);
                  LZReportProc := aProc;
                  with jr2^.Files[i] do
                    if IsChiefLZFile(BigNames) or
                       IsChiefLZArchive(BigNames) then
                 { Just copy (compressed) file into archive ... }
                      begin
                        Sizes := MyFCopy(InFile,OutFile,
                                         LZ_UNKNOWN_LENGTH,doReportOnRead);
                        Compressed := False
                      end
                    else
                 { Compress the file into the archive ... }
                      Sizes := ArchiveSquash(InFile, OutFile, aProc)
                finally
                  CloseFile(InFile);
                  if Assigned(aProc) then
                    begin
                      RepRec.Names := '';
                      aProc(RepRec,-2)
                    end
                end
              end; { 1+DirCount <= i <= Count }

        { write header again }
          Seek(OutFi