kplib.pas

dephi vcl控件

end;

procedure SetLength(var S: string; NewLength: Integer);
begin
   S[0] := Char(LoByte(NewLength));
end;

function Trim( const S: string ): String;
var
  i,j: Integer;
begin
  if Length(s) = 0 then
     result := ''
  else
   begin
     i := 1;
     while (S[i]=' ') do
        inc(i);
     j := length(S);
     while (S[j]=' ')do
        dec(j);
     result := copy(S,i,j-i);
   end;
end;

procedure ZeroMemory(p: Pointer; count: LongInt);
var
   b                          : BYTEPTR;
   i                          : LongInt;
begin
   b := BYTEPTR(p);
   for i := 0 to count - 1 do
   begin
      b^ := 0;
      Inc(b);
   end;
end;

procedure MoveMemory(dest, source: Pointer; count: Integer);
var
   d, s                       : BYTEPTR;
   i                          : Integer;
begin
   d := BYTEPTR(dest);
   s := BYTEPTR(source);
   for i := 0 to count - 1 do
   begin
      d^ := s^;
      Inc(d);
      Inc(s);
   end;
end;

function StringAsPChar(var S: OpenString): PChar;
begin
   if Length(S) = High(S) then
      Dec(S[0]);
   S[Ord(Length(S)) + 1] := #0;
   Result := @S[1];
end;

function GetEnvVar(EnvVar: string): string;
var
   P                          : PChar;
begin
   Result := '';
   P := GetDOSEnvironment;
   if Length(EnvVar) > 253 then
      SetLength(EnvVar, 253);
   EnvVar := EnvVar + '=';
   StringAsPChar(EnvVar);
   while P^ <> #0 do
      if StrLIComp(P, @EnvVar[1], Length(EnvVar)) <> 0 then
         Inc(P, StrLen(P) + 1)
      else
      begin
         Inc(P, Length(EnvVar));
         Result := StrPas(P);
         break;
      end;
end;

function GetTempPath(BufferSize: Integer; PathBuffer: PChar): LongInt;
var
   thePath                    : string;
begin
   thePath := GetEnvVar('TMP');
   if thePath = '' then
      thePath := GetEnvVar('TEMP');
   if thePath = '' then
      GetDir(0, thePath);
   if thePath[Length(thePath)] <> '\' then
      thePath := thePath + '\';
   StrPCopy(PathBuffer, thePath);
   Result := Length(thePath);
end;

{ Added this function 3/29/98 2.1 }

function ExtractFileDir(FName: string): string;
{ExtractFileDir does not include the rightmost '\'}
begin
   Result := ExtractFilePath(FName);
   if (Result <> '') and (Result <> '\') and (not (RightStr(Result, 2) = ':\')) then
      SetLength(Result, Length(Result) - 1);
end;

function ExtractFileDrive(FName: string): string;
begin
   Result := '';
   if (Length(FName) < 2) or (FName[2] <> ':') then
      exit;
   Result := LeftStr(FName, 2);
end;

{$IFNDEF NOLONGNAMES}

function LFN_CreateFile(FName: string): LongBool;
const
   GENERIC_READ               = $80000000;
   GENERIC_WRITE              = $40000000;
   CREATE_NEW                 = 1;
   CREATE_ALWAYS              = 2;
   OPEN_EXISTING              = 3;
   OPEN_ALWAYS                = 4;
   TRUNCATE_EXISTING          = 5;
   FILE_ATTRIBUTE_NORMAL      = $00000080;
var
   theHandle                  : LongInt;
begin
   theHandle := W32CreateFile(StringAsPChar(FName), GENERIC_WRITE, 0, nil, CREATE_ALWAYS,
      FILE_ATTRIBUTE_NORMAL, 0, id_W32CreateFile);
   Result := W32CloseHandle(theHandle, id_W32CloseHandle);
end;

function LFN_GetShortFileName(LName: string): string;
var
   ffd                        : WIN32_FIND_DATA;
   r                          : LongInt;
begin
   r := W32FindFirstFile(StringAsPChar(LName), ffd, id_W32FindFirstFile);
   if (r <> -1) and (StrPas(ffd.cAlternateFileName) <> '') then
      Result := ExtractFilePath(LName) + StrPas(ffd.cAlternateFileName)
   else
      Result := LName;
   if (r <> -1) then
      W32FindClose(r, id_W32FindClose);
end;
{$ENDIF}

function hash(S: string; M: LongInt): LongInt;
var
   i                          : Integer;
   g                          : LongInt;
begin
   Result := 0;
   for i := 1 to Length(S) do
   begin
      Result := (Result shl 4) + Byte(S[i]);
      g := Result and $F0000000;
      if (g <> 0) then
         Result := Result xor (g shr 24);
      Result := Result and (not g);
   end;
   Result := Result mod M;
end;

function LFN_Shorten(LName: string): string;
var
   i                          : Integer;
   Extent                     : string;
   HashChar                   : Char;
begin
   HashChar := #0;
   i := Length(LName);
   while (i > 0) do
   begin
      if LName[i] = '.' then
         break;
      Dec(i);
   end;
   if i > 0 then
   begin
      if Length(LName) - i > 3 then
         HashChar := DOSChars[hash(LName, 78)];
      Extent := Copy(LName, i, 4);
      if HashChar <> #0 then
      begin
         Extent[4] := HashChar;
         HashChar := #0;
      end;
      if i > 9 then
         HashChar := DOSChars[hash(LName, 78)];
      SetLength(LName, kpmin(i - 1, 8));
      if HashChar <> #0 then
         LName[8] := HashChar;
   end
   else
   begin
      Extent := '';
      if Length(LName) > 8 then
         HashChar := DOSChars[hash(LName, 78)];
      SetLength(LName, kpmin(Length(LName), 8));
   end;
   for i := 1 to Length(LName) do
      if not (LName[i] in FNameChars) then
         LName[i] := '_';
   Result := LName + Extent;
end;

function LFN_WIN31LongPathToShort(LName: string): string;
var
   tempShortPath              : string;
   tmpStr                     : string;
   p                          : PChar;
   count, r, i, j             : Integer;
   EndSlash                   : Boolean;
begin
   count := 0;
   EndSlash := False;
   tempShortPath := '';
   if (LName[2] = ':') and (LName[3] <> '\') then
      Insert('\', LName, 3);
   if (LName[Length(LName)] = '\') then
   begin
      EndSlash := True;
      Dec(LName[0]);
   end;
   if (LName[1] = '\') then
      j := 2
   else
      j := 1;

   for i := j to Length(LName) do
      if LName[i] = '\' then
      begin
         LName[i] := #0;
         Inc(count);
      end;
   LName[Length(LName) + 1] := #0;
   p := @LName[j];
   if p[1] = ':' then
   begin
      tempShortPath := StrPas(p) + '\';
      p := StrEnd(p);
      Inc(p);
      Dec(count);
   end;
   for i := 0 to count do
   begin
      tmpStr := StrPas(p);
      tmpStr := LFN_Shorten(tmpStr);
      tempShortPath := tempShortPath + tmpStr + '\';
      p := StrEnd(p);
      Inc(p);
   end;
   if not EndSlash then
      Dec(tempShortPath[0]);
   Result := tempShortPath;
end;

{$IFNDEF NOLONGNAMES}

function LFN_FileExists(LName: string): Boolean;
var
   ffd                        : WIN32_FIND_DATA;
   r                          : LongInt;
begin
   if LName[Length(LName)] = '\' then
      Dec(LName[0]);
   r := W32FindFirstFile(StringAsPChar(LName), ffd, id_W32FindFirstFile);
   if r <> -1 then
   begin
      Result := True;
      W32FindClose(r, id_W32FindClose);
   end
   else
      Result := False;

end;
{$ENDIF}
{$ENDIF}

{$IFNDEF NOLONGNAMES}

function LFN_ConvertLFName(LName: string; ConvertOperation: TConversionOperation): string;
var
   tempOrigPath               : array[0..255] of char;
   tempNewPath                : string;
   p                          : PChar;
   count, i, j                : Integer;
   r                          : LongInt;
   {$IFDEF WIN32}
   ffd                        : TWin32FindData;
   {$ELSE}
   ffd                        : WIN32_FIND_DATA;
   {$ENDIF}
   EndSlash                   : Boolean;
   HasDrive                   : Boolean;                { For UNC's 3/26/98  2.1 }
begin
   HasDrive := False;
   count := 0;
   EndSlash := False;
   tempNewPath := '';
   tempOrigPath[0] := #0;
   if (LName[2] = ':') and (LName[3] <> '\') then
      Insert('\', LName, 3);
   if (LName[Length(LName)] = '\') then
   begin
      EndSlash := True;
      SetLength(LName, Length(LName) - 1);
   end;
   if (LName[1] = '\') then
   begin
      tempNewPath := '\';
      j := 2
   end
   else
      if ExtractFileDrive(LName) <> '' then             { For UNC's 3/26/98  2.1 }
      begin
         j := Length(ExtractFileDrive(LName)) + 1;
         HasDrive := True;
      end
      else
         j := 1;
   for i := j to Length(LName) do
      if LName[i] = '\' then
      begin
         LName[i] := #0;
         Inc(count);
      end;
   LName[Length(LName) + 1] := #0;
   if HasDrive then
      j := 1;                                           { 4/12/98 2.11 }
   p := @LName[j];
   if HasDrive then
   begin
      StrCopy(tempOrigPath, p);
      StrCat(tempOrigPath, '\');
      tempNewPath := StrPas(p) + '\';
      p := StrEnd(p);
      p^ := '\';
      Inc(p);
      Dec(count);
   end;
   for i := 0 to count do
   begin
      StrCat(tempOrigPath, p);
      {$IFDEF WIN32}
      r := FindFirstFile(tempOrigPath, ffd);
      {$ELSE}
      r := W32FindFirstFile(tempOrigPath, ffd, id_W32FindFirstFile);
      {$ENDIF}
      if ConvertOperation = LENGTHEN then
      begin
         if (r <> -1) then
            tempNewPath := tempNewPath + StrPas(ffd.cFileName) + '\'
      end
      else
      begin
         if (r <> -1) and (StrPas(ffd.cAlternateFileName) <> '') then
            tempNewPath := tempNewPath + StrPas(ffd.cAlternateFileName) + '\'
         else
            tempNewPath := tempNewPath + StrPas(p) + '\';
      end;
      StrCat(tempOrigPath, '\');
      p := StrEnd(p);
      p^ := '\';
      Inc(p);
      if (r <> -1) then
         {$IFDEF WIN32}
         Windows.FindClose(r);
      {$ELSE}
         W32FindClose(r, id_W32FindClose);
      {$ENDIF}
   end;
   if not EndSlash then
      SetLength(tempNewPath, Length(tempNewPath) - 1);
   Result := tempNewPath;
end;
{$ENDIF}

{$IFNDEF WIN32}
const
   WF_WINNT                   = $4000;

var
   c                          : char;
   i                          : Integer;
begin
   { Added NT Check 3/1/98 for version 2.03 }
   IsNT := (GetWinFlags and WF_WINNT) <> 0;
   if IsNT then
      OSVersion := 4
   else
   begin
      OSversion := GetVersion;
      if (Lo(LOWORD(OSversion)) > 3) or
         ((Lo(LOWORD(OSversion)) = 3) and (Hi(LOWORD(OSversion)) = 95)) then
         OSversion := 4                                 { WIN95 or higher }
      else
         OSversion := 3;                                { WIN31 }
   end;

   {OSVersion := 3;}{ Uncomment these 2 lines to emulate WIN31 on WIN95 or NT }
   {IsNT := False;}{ Useful for testing WIN31 long filename support }
   for c := Low(Char) to High(Char) do
      if c in FNameChars then
      begin
         DOSChars[i] := c;
         Inc(i);
      end;
{$ENDIF}

   { $Id: KPLib.pas,v 1.28 2000-12-16 16:50:09-05 kp Exp kp $ }

   { $Log: KPLib.pas,v $
   { Revision 1.28  2000-12-16 16:50:09-05  kp
   { 2.21 Final Release 12/12/00
   {
   { Revision 1.27  2000-05-21 18:47:52-04  kp
   { - Moved declarations of signature globals out and into kpzipobj.
   {
   { Revision 1.26  2000-05-13 17:03:38-04  kp
   { - Added code to handle BufferedStreamSize property for TLFNFileStream
   { - Changed zip signature constants to real global variables.  Setting of these variables
   {   happens in kpzipobj.pas Initialization section
   {
   { Revision 1.25  1999-12-05 09:30:54-05  kp
   { - Added BIGINT def to kpmin and kpmax
   { - Got rid of kpDiskFree
   {
   { Revision 1.24  1999-10-17 12:08:16-04  kp
   { - Removed $IFNDEF ISBCB from kpmin and kpmax
   {
   { Revision 1.23  1999-10-17 12:00:50-04  kp
   { - Changed min and max to kpmin and kpmax
   {
   { Revision 1.22  1999-10-11 20:40:10-04  kp
   { - Added flushing parameter to TLFNFileStream
   {
   { Revision 1.21  1999-09-16 20:09:00-04  kp
   { - Moved defines to KPDEFS.INC
   {
   { Revision 1.20  1999-09-14 21:28:55-04  kp
   { - Removed FlushAlways stuff from this file
   { - Added Trim function for D1
   {
   { Revision 1.19  1999-09-01 18:26:44-04  kp
   { - Added capability to flush buffered stream to disk after every flush of the buffered streams
   {   buffer.  Used the OnFlushBuffer event to do it.
   {
   { Revision 1.18  1999-08-25 19:04:01-04  kp
   { - Fixes for D1
   {
   { Revision 1.17  1999-06-27 13:53:29-04  kp
   { - Minor fix to kpDiskFree  (changed Integer to DWORD)
   {
   { Revision 1.16  1999-06-18 16:45:59-04  kp
   { - Modified to handle adding directory entries when doing recursive zips (AddDirEntries property)
   {
   { Revision 1.15  1999-06-01 21:56:57-04  kp
   { - Ran through the formatter
   {
   { Revision 1.14  1999-04-24 21:12:58-04  kp
   { - Fixed D2 memory leak
   {
   { Revision 1.13  1999-04-10 10:20:53-04  kp
   { - Added conditionals so that NOLONGNAMES and NODISKUTILS wont get set in 32bit
   { - Added code to SetVolLabel to delete label before setting it.
   {
   { Revision 1.12  1999-03-30 19:43:22-05  kp
   { - Modified so that defining MAKESMALL will create a much smaller component.
   {
   { Revision 1.11  1999-03-23 17:43:40-05  kp
   { - added ifdef around DWord definition
   {
   { Revision 1.10  1999-03-22 17:35:29-05  kp
   { - moved comments to bottom
   { - removed dependency on kpDrvs (affects D1 only)
   { - added asserts ifdef to CBigRate
   {
   { Revision 1.9  1999-03-20 11:45:05-05  kp
   { - Fixed problem where setting ZipComment to '' caused an access violation
   {
   { Revision 1.8  1999-03-15 21:58:58-05  kp
   { <>
   {
   { Revision 1.7  1999-03-14 21:32:07-05  kp
   { - Fixed problem of With SData not working
   {
   { Revision 1.6  1999-02-10 18:12:26-05  kp
   { Added directive to turn off Strict Var Strings compiler option
   {
   { Revision 1.4  1999-01-25 19:13:01-05  kp
   { Modifed compiler directives
   { }

   { Sun 10 May 1998   16:58:46  Version: 2.12
   { - Added TempPath property
   { - Fixed RelativePaths bug
   { - Fixed bug related to files in FilesList that don't exist
   }
   {
   {  Mon 27 Apr 1998   18:37:41  Version: 2.11
   { Added ExtractDeviceDrive and GoodTimeStamp
   }
   {
   { Tue 24 Mar 1998   19:00:23
   { Modifications to allow files and paths to be stored in DOS
   { 8.3 filename format.  New property is Store83Names.
   }
   {
   { Wed 11 Mar 1998   21:10:16  Version: 2.03
   { Version 2.03 Files containing many fixes
   }

   { Sun 01 Mar 1998   10:25:17
   { Modified so that D1 would recognize NT.  Modified return
   { values for W32FindFirstFile to be LongInt instead of
   { Integer.
   }

end.