kplib.pas

一个delphi中压缩的组件VCLZip

unit KpLib;

{$P-}                                                   { turn off open parameters }
{$R-}                                                   { 12/24/98 2.17 }
{$Q-}                                                   { 12/24/98 2.17 }
{$B-} { turn off complete boolean eval }                { 12/24/98  2.17 }
{$V-} { turn off strict var strings }                   { 02/10/99  2.17+ }

interface

{$I KPDEFS.INC}

uses
   {$IFNDEF WIN32}
   WinProcs,
   WinTypes,
   {$IFNDEF NOLONGNAMES}
   kpLName,
   {$ENDIF}
   {$ELSE}
   Windows,
   {$ENDIF}
   {$IFNDEF NOSTREAMBUFF}
   kpSStrm,
   {$ENDIF}
   SysUtils,
   {$IFDEF KPSMALL}
   kpSmall,
   {$ELSE}
   FileCtrl,
   {$ENDIF}
   Classes,
   kpMatch, kpZipObj{$IFNDEF NO_RES}, kpzcnst{$ENDIF};

const
   WILDCARD_RECURSE           = '>';
   WILDCARD_NORECURSE         = '|';

type
   BYTEPTR = ^Byte;
   PSearchRec = ^TSearchRec;
   {$IFNDEF WIN32}
   DWord = LongInt;
   {$ENDIF}

   {$IFDEF NODISKUTILS}
   str11 = string[11];
   {$ENDIF}

   {$IFDEF ISBCB}
   Comp = Double;
   {$ENDIF}

   {$IFNDEF NOSTREAMBUFF}
   TLFNFileStream = class(TS_BufferStream)
      theFile: TFileStream;
      function GetHandle: Integer;
      {$ELSE}
   TLFNFileStream = class(TFileStream)
      {$ENDIF}
   PUBLIC
      constructor CreateFile(const FileName: string; Mode: Word; FlushOut: Boolean;
                             BufSize: Integer);
      destructor Destroy; OVERRIDE;
      {$IFNDEF NOSTREAMBUFF}
      property Handle: Integer READ GetHandle;
      {$ENDIF}
   end;

   TConversionOperation = (SHORTEN, LENGTHEN);

   TSearchData = class(TObject)
   PUBLIC
      Directory: string;
      Pattern: string;
      SearchResult: Integer;
      SearchRec: TSearchRec;
      NoFiles: Boolean;
      procedure Next;
      constructor Create(Path, MatchPattern: string);
      destructor Destroy; OVERRIDE;
   end;

   TDirSearch = class
   PRIVATE
      FDirStack: array[0..20] of TSearchData;
      FCurrentLevel: Integer;
      FPattern: string;
      FRecurse: Boolean;
      FWildDirStack: TStrings;
      FNumWildDirs: Integer;
      FWildDirID: Integer;

      function IsChildDir(SR: TSearchRec): Boolean;
      function IsDir(SR: TSearchRec): Boolean;
   PUBLIC
      constructor Create(const StartingDir, Pattern: string; RecurseDirs: Boolean);
      destructor Destroy; OVERRIDE;
      function NextFile(var SR: TSearchRec): string;
      property Recurse: Boolean READ FRecurse WRITE FRecurse DEFAULT False;
   end;


function kpmin(a, b: BIGINT): BIGINT;
function kpmax(a, b: BIGINT): BIGINT;


function CRate(uc, c: LongInt): LongInt;
function CBigRate(uc, c: Comp): LongInt;
function BlockCompare(const Buf1, Buf2; Count: Integer): Boolean;
function DOSToUnixFilename(fn: PChar): PChar;
function UnixToDOSFilename(fn: PChar): PChar;
function RightStr(str: string; count: Integer): string;
function LeftStr(str: string; count: Integer): string;
function IsWildCard(fname: string): Boolean;
function FileDate(fname: string): TDateTime;
function GoodTimeStamp(theTimeStamp: LongInt): LongInt;

procedure ForceDirs(Dir: string);
function DirExists(Dir: string): Boolean;
function File_Exists(const FileName: string): Boolean;
procedure GetDirectory(D: Byte; var S: string);
procedure ChDirectory(const S: string);
function DoRenameCopy(const FromFile, ToFile: string): boolean;
procedure FileCopy(const FromFile, ToFile: string);
function PCharToStr(CStr: PChar): string;
function StrToPChar(Str: string): PChar;

function GetVolumeLabel(Disk: string): string;
function SetVolLabel(Disk, NewLabel: string): LongBool;

function TempFileName(Pathname: string): string;
procedure OemFilter(var fname: string);

{$IFNDEF Ver100}
procedure Assert(Value: Boolean; Msg: string);
{$ENDIF}

{$IFDEF WIN32}
function StringAsPChar(var S: string): PChar;
{$ELSE}
procedure SetLength(var S: string; NewLength: Integer);
function Trim( const S: string ): String;
procedure ZeroMemory(p: Pointer; count: LongInt);
procedure MoveMemory(dest, source: Pointer; count: Integer);
function GetEnvVar(EnvVar: string): string;
function GetTempPath(BufferSize: Integer; PathBuffer: PChar): LongInt;
function StringAsPChar(var S: OpenString): PChar;
function ExtractFileDir(FName: string): string;
function ExtractFileDrive(FName: string): string;       { 3/29/98 2.1 }

{$IFNDEF NOLONGNAMES}
function LFN_CreateFile(FName: string): LongBool;
function LFN_FileExists(LName: string): Boolean;
function LFN_GetShortFileName(LName: string): string;
{$ENDIF}
function LFN_Shorten(LName: string): string;
function LFN_WIN31LongPathToShort(LName: string): string;
{$ENDIF}

{$IFNDEF NOLONGNAMES}
function LFN_ConvertLFName(LName: string; ConvertOperation: TConversionOperation): string;
{$ENDIF}

{$IFNDEF WIN32}                                         { 4/22/98 2.11 }
var
   OSVersion                  : LongInt;
   IsNT                       : Boolean;
{$ENDIF}

implementation

{$IFNDEF KPSMALL}
uses
   Dialogs
   {$IFNDEF WIN32}
   {$IFNDEF NODISKUTILS}
   , kpDUtil
   {$ENDIF}
   {$ENDIF};
{$ENDIF}

{$IFNDEF WIN32}
var
  DOSChars                   : array[0..77] of char;
{$ENDIF}
const
   {$IFNDEF WIN32}
   FNameChars                 : set of Char =
      ['A'..'Z', 'a'..'z', '0'..'9', '_', '^', '$', '~', '!', '#', '%', '&', '-', '{', '}',
      '@',
      '`', '''', ')', '('];
   {$ENDIF}
   WildCardChars              : set of Char =
      ['*', '?', MATCH_CHAR_RANGE_OPEN, WILDCARD_RECURSE, WILDCARD_NORECURSE];  { Removed ] added > and <  7/24/98 }

constructor TLFNFileStream.CreateFile(const FileName: string; Mode: Word; FlushOut: Boolean;
                                      BufSize: Integer);
var
   FName                      : string;
begin
   FName := FileName;
   {$IFNDEF WIN32}
     {$IFNDEF NOLONGNAMES}
     if OSVersion > 3 then
     begin
      if (Mode = fmCreate) then
         LFN_CreateFile(FName);
      FName := LFN_ConvertLFName(FName, SHORTEN);
     end
     else
     {$ENDIF}
      FName := LFN_WIN31LongPathToShort(FName);
   {$ENDIF}
   {$IFNDEF NOSTREAMBUFF}
   theFile := TFileStream.Create(Fname, Mode);
   inherited Create(theFile, BufSize);
   {$IFDEF WIN32}
   { Only if one of the write mode bits are set }
   FlushOnDestroy := FlushOut and ((Mode and 3) > 0);
   {$ENDIF}
   {$ELSE}
   inherited Create(FName, Mode);
   {$ENDIF}
end;

destructor TLFNFileStream.Destroy;
begin
   inherited Destroy;
   {$IFNDEF NOSTREAMBUFF}
   theFile.Free; { Must Free after calling inherited Destroy so that }
   {$ENDIF} { buffers can be flushed out by Destroy }
end;

{$IFNDEF NOSTREAMBUFF}

function TLFNFileStream.GetHandle: Integer;
begin
   Result := theFile.Handle;
end;

{$ENDIF}

constructor TSearchData.Create(Path, MatchPattern: string);
begin
   NoFiles := False;
   Directory := Path;
   if RightStr(Directory, 1) <> '\' then
      Directory := Directory + '\';
   Pattern := MatchPattern;
   SearchResult := FindFirst(Directory + '*.*', faAnyFile, SearchRec);
   if SearchResult <> 0 then {This should never happen though since we always use *.*}
      NoFiles := True; {to avoid hanging on NT systems with empty directories}
end;

destructor TSearchData.Destroy;
begin
   if not NoFiles then
      SysUtils.FindClose(SearchRec); {don't call if FindFirst didn't find any files}
   inherited Destroy;
end;

procedure TSearchData.Next;
begin
   if (SearchResult = 0) then
      SearchResult := Findnext(SearchRec);
end;

constructor TDirSearch.Create(const StartingDir, Pattern: string; RecurseDirs: Boolean);

   procedure ParseWildDir(var wilddir: string);
   var
      i, j                    : Integer;
      Remaining               : string;
   begin
      i := 1;
      while (i <= Length(wilddir)) and not (wilddir[i] in WildCardChars) do
         Inc(i);
      j := i;
      while (wilddir[j] <> '\') do
         Dec(j);
      Remaining := RightStr(wilddir, Length(wilddir) - j);
      wilddir := LeftStr(wilddir, j);
      i := 1;
      j := 0;
      while (i <= Length(Remaining)) do
      begin
         if (Remaining[i] = '\') then
         begin
            FWildDirStack.Add(LeftStr(Remaining, i - 1));
            Remaining := RightStr(Remaining, Length(Remaining) - i);
            i := 1;
            Inc(j);
         end
         else
            Inc(i);
      end;
      FNumWildDirs := j;
   end;

var
   StartDir                   : string;
   thisPattern                : string;
begin
   inherited Create;
   StartDir := StartingDir;
   if RightStr(StartDir, 1) <> '\' then
      StartDir := StartDir + '\';
   if IsWildCard(StartDir) then
   begin
      FWildDirStack := TStringList.Create;
      ParseWildDir(StartDir);
      FWildDirID := 0;
   end
   else
   begin
      FWildDirID := -1;
      FNumWildDirs := 0;
      FWildDirStack := nil;
   end;
   FCurrentLevel := 0;
   FPattern := Pattern;
   if FNumWildDirs > 0 then
      thisPattern := FWildDirStack[0]
   else
      thisPattern := FPattern;
   FDirStack[FCurrentLevel] := TSearchData.Create(StartDir, thisPattern);
   FRecurse := RecurseDirs;
end;

destructor TDirSearch.Destroy;
begin
   FWildDirStack.Free;
end;

function TDirSearch.IsChildDir(SR: TSearchRec): Boolean;
begin
   Result := (SR.Attr and faDirectory > 0) and (SR.Name <> '.') and (SR.Name <> '..');
end;

function TDirSearch.IsDir(SR: TSearchRec): Boolean;
begin
   Result := (SR.Attr and faDirectory > 0);
end;

function TDirSearch.NextFile(var SR: TSearchRec): string;
var
   FullDir                    : string;
   SData                      : TSearchData;
begin
   SData := FDirStack[FCurrentLevel];
   while True do
   begin
      if SData.SearchResult <> 0 then
      begin
         SData.Free;
         FDirStack[FCurrentLevel] := nil;
         if FCurrentLevel = 0 then
         begin
            Result := '';                               {Thats it folks!}
            break;
         end;
         Dec(FCurrentLevel);                            { Pop back up a level }
         SData := FDirStack[FCurrentLevel];
         {ChDirectory( SData.Directory );}
         {GetDirectory( 0, dbgFullDir );}
         if (FCurrentLevel < FNumWildDirs) then
            Dec(FWildDirID);
         SData.Next;
      end;
      { Added wildcards-in-paths feature 7/22/98  2.14 }
      if (FCurrentLevel < FNumWildDirs) then
      begin
         while ((SData.SearchResult = 0) and ((not IsChildDir(SData.SearchRec)) or
            (not IsMatch(FWildDirStack[FWildDirID], SData.SearchRec.Name)))) do
            SData.Next;
         if (SData.SearchResult = 0) then
         begin
            Inc(FCurrentLevel);
            {ChDirectory( SData.SearchRec.Name );}
            {GetDirectory( 0, FullDir );}{ Get full directory name }
            FullDir := SData.Directory + SData.SearchRec.Name;
            Inc(FWildDirID);
            if (FCurrentLevel < FNumWildDirs) then
               FDirStack[FCurrentLevel] := TSearchData.Create(FullDir,
                  FWildDirStack[FWildDirID])
            else
               FDirStack[FCurrentLevel] := TSearchData.Create(FullDir, FPattern);
            SData := FDirStack[FCurrentLevel];
            SData.Next;
         end;
         Continue;
      end;
      while ((SData.SearchResult = 0) and (IsDir(SData.SearchRec) and (not FRecurse))) do
         SData.Next;
      if (SData.SearchResult = 0) and (IsChildDir(SData.SearchRec)) and (FRecurse) then
      begin
         Inc(FCurrentLevel);
         {ChDirectory( SData.SearchRec.Name );}
         {GetDirectory( 0, FullDir );}{ Get full directory name }
         FullDir := SData.Directory + SData.SearchRec.Name;
         FDirStack[FCurrentLevel] := TSearchData.Create(FullDir, FPattern);
         {SData := FDirStack[FCurrentLevel];}
         Result := FullDir + '\';
         Break;
      end
      else
         if (SData.SearchResult = 0) and (not IsDir(SData.SearchRec)) then
         begin
            if ExtractFileExt(SData.SearchRec.Name) = '' then { this gets files with }
               SData.SearchRec.Name := SData.SearchRec.Name + '.'; { no extention         }
            if IsMatch(FPattern, SData.SearchRec.Name) then
            begin
               if SData.SearchRec.Name[Length(SData.SearchRec.Name)] = '.' then
                  SetLength(SData.SearchRec.Name, Length(SData.SearchRec.Name) - 1);
               SR.Size := SData.SearchRec.Size; { Modified for D2 mem leak 4/15/99  2.17+}
               Result := SData.Directory + SData.SearchRec.Name;
               SData.Next;
               Break;
            end
            else
               SData.Next;
         end
         else
            SData.Next;
   end;
end;

function kpmin(a, b: BIGINT): BIGINT;
begin
   if a < b then
      Result := a
   else
      Result := b;
end;

function kpmax(a, b: BIGINT): BIGINT;
begin
   if a > b then
      Result := a
   else
      Result := b;
end;

function CRate(uc, c: LongInt): LongInt;
var
   R, S                       : Extended;
begin
   if uc > 0 then
   begin
      S := c;
      S := S * 100;
      R := S / uc;
   end
   else
      R := 0;
   Result := kpmin(Round(R), 100);
end;

function CBigRate(uc, c: Comp): LongInt;
var
   R                          : Comp;
begin
   {$IFDEF ASSERTS}
   Assert(c <= uc, 'Total Done more than total');
   {$ENDIF}
   if uc > 0 then
   begin
      R := (c * 100) / uc;
   end
   else
      R := 0;
   Result := kpmin(Round(R), 100);
end;

function DOSToUnixFilename(fn: PChar): PChar;
var
   slash                      : PChar;
begin
   slash := StrScan(fn, '\');
   while (slash <> nil) do
   begin
      slash[0] := '/';
      slash := StrScan(fn, '\');
   end;
   Result := fn;
end;

function UnixToDOSFilename(fn: PChar): PChar;
var
   slash                      : PChar;
begin
   slash := StrScan(fn, '/');
   while (slash <> nil) do
   begin
      slash[0] := '\';
      slash := StrScan(fn, '/');
   end;
   Result := fn;
end;

function RightStr(str: string; count: Integer): string;
begin
   Result := Copy(str, kpmax(1, Length(str) - (count - 1)), count);
end;

function LeftStr(str: string; count: Integer): string;
begin
   Result := Copy(str, 1, count);
end;

function IsWildCard(fname: string): Boolean;
var
   i                          : Integer;
begin
   i := 1;
   while (i <= Length(fname)) and not (fname[i] in WildCardChars) do
      Inc(i);
   if i > Length(fname) then
      Result := False
   else
      Result := True;
end;

{ Added 4/21/98  2.11  to avoid date/time conversion exceptions }

function GoodTimeStamp(theTimeStamp: LongInt): LongInt;