kplib.pas

一个delphi中压缩的组件VCLZip

var
   Hour, Min, Sec             : WORD;
   Year, Month, Day           : WORD;
   Modified                   : Boolean;
begin
   Result := theTimeStamp;
   Hour := LongRec(Result).Lo shr 11;
   Min := LongRec(Result).Lo shr 5 and 63;
   Sec := LongRec(Result).Lo and 31 shl 1;

   Year := LongRec(Result).Hi shr 9 + 1980;
   Month := LongRec(Result).Hi shr 5 and 15;
   Day := LongRec(Result).Hi and 31;

   Modified := False;
   if Hour > 23 then
   begin
      Modified := True;
      Hour := 23;
   end;
   if Min > 59 then
   begin
      Modified := True;
      Min := 59;
   end;
   if Sec > 59 then
   begin
      Modified := True;
      Sec := 59;
   end;
   if Year < 1980 then
   begin
      Modified := True;
      Year := 1980;
   end;
   if Year > 2099 then
   begin
      Modified := True;
      Year := 2099;
   end;
   if Month > 12 then
   begin
      Modified := True;
      Month := 12;
   end;
   if Month < 1 then
   begin
      Modified := True;
      Month := 1;
   end;
   if Day > 31 then
   begin
      Modified := True;
      Day := 31;
   end;
   if Day < 1 then
   begin
      Modified := True;
      Day := 1;
   end;

   if Modified then
   begin
      LongRec(Result).Hi := Day or (Month shl 5) or ((Year - 1980) shl 9);
      LongRec(Result).Lo := (Sec shr 1) or (Min shl 5) or (Hour shl 11);
   end;

end;

function FileDate(fname: string): TDateTime;
{
var
  f: Integer;
}
begin
   { Converted to using FileAge 3/29/98 2.1 }
   try
      Result := FileDateToDateTime(GoodTimeStamp(FileAge(fname)));
   except
      Result := Now;
   end;
   {$IFDEF SKIPCODE}
   f := FileOpen(fname, fmOpenRead);
   Result := FileDateToDateTime(FileGetDate(f));
   FileClose(f);
   {$ENDIF}
end;

procedure ForceDirs(Dir: string);
begin
   {$IFDEF WIN32}
   {$IFNDEF KPSMALL}
   ForceDirectories(Dir);
   {$ELSE}
   ForceCreateDirectories(Dir);
   {$ENDIF}
   {$ELSE}
   {$IFNDEF NOLONGNAMES}
   if OSVersion > 3 then
   begin
      if Dir[Length(Dir)] = '\' then
         SetLength(Dir, Length(Dir) - 1);
      if (Length(Dir) < 3) or DirectoryExists(Dir) then Exit;
      ForceDirs(ExtractFilePath(Dir));
      W32CreateDirectory(StringAsPChar(Dir), nil, id_W32CreateDirectory);
   end
   else
      {$ENDIF}
   begin
      Dir := LFN_WIN31LongPathToShort(Dir);
      {$IFNDEF KPSMALL}
      ForceDirectories(Dir);
      {$ELSE}
      ForceCreateDirectories(Dir);
      {$ENDIF}
   end;
   {$ENDIF}
end;

function File_Exists(const FileName: string): Boolean;
begin
   {$IFDEF WIN32}
   Result := FileExists(Filename);
   {$ELSE}
   {$IFNDEF NOLONGNAMES}
   if OSVersion > 3 then
      Result := LFN_FileExists(Filename)
   else
      {$ENDIF}
      Result := FileExists(LFN_WIN31LongPathToShort(Filename));
   {$ENDIF}
end;

function DirExists(Dir: string): Boolean;
begin
   {$IFDEF WIN32}
   {$IFDEF KPSMALL}
   Result := kpSmall.DirExists(Dir);
   {$ELSE}
   Result := DirectoryExists(Dir);
   {$ENDIF}
   {$ELSE}
   {$IFNDEF NOLONGNAMES}
   if OSVersion > 3 then
      Result := LFN_FileExists(Dir)
   else
      {$ENDIF}
   begin
      Dir := LFN_WIN31LongPathToShort(Dir);
      {$IFDEF KPSMALL}
      Result := kpSmall.DirExists(Dir);
      {$ELSE}
      Result := DirectoryExists(Dir);
      {$ENDIF}
   end;
   {$ENDIF}
end;

procedure GetDirectory(D: Byte; var S: string);
{$IFNDEF WIN32}
var
   Drive                      : array[0..3] of Char;
   DirBuf, SaveBuf            : array[0..259] of Char;
   {$ENDIF}
begin
   {$IFDEF WIN32}
   GetDir(D, S);
   {$ELSE}
   {$IFNDEF NOLONGNAMES}
   if OSVersion > 3 then
   begin
      if D <> 0 then
      begin
         Drive[0] := Chr(D + Ord('A') - 1);
         Drive[1] := ':';
         Drive[2] := #0;
         W32GetCurrentDirectory(SizeOf(SaveBuf), SaveBuf, id_W32GetCurrentDirectory);
         W32SetCurrentDirectory(Drive, id_W32SetCurrentDirectory);
      end;
      W32GetCurrentDirectory(SizeOf(DirBuf), DirBuf, id_W32GetCurrentDirectory);
      if D <> 0 then W32SetCurrentDirectory(SaveBuf, id_W32SetCurrentDirectory);
      S := StrPas(PChar(@DirBuf));
   end
   else
      {$ENDIF}
      GetDir(D, S); {We should never be Getting a long Dirname in Win31}
   {$ENDIF}
end;

procedure ChDirectory(const S: string);
{$IFNDEF WIN32}
var
   Dir                        : string;
   {$ENDIF}
begin
   {$IFDEF WIN32}
   ChDir(S);
   {$ELSE}
   {$IFNDEF NOLONGNAMES}
   {Added Check for NT 3/1/98 for version 2.03}
   if (OSVersion > 3) and (not IsNT) then
   begin
      Dir := S;
      W32SetCurrentDirectory(StringAsPChar(Dir), id_W32SetCurrentDirectory)
   end
   else
      if IsNT then
      begin
         {Dir := LFN_WIN31LongPathToShort(S);}
         Dir := LFN_ConvertLFName(S, SHORTEN);
         ChDir(Dir);
      end
      else
         {$ENDIF}
      begin
         Dir := s;
         if (length(Dir) > 3) and (Dir[length(Dir)] = '\') then
            Delete(Dir, length(Dir), 1);
         ChDir(Dir);
      end;
   {$ENDIF}
end;

{$IFDEF SKIP_CODE}

procedure FileCopy(const FromFile, ToFile: string);
var
   FromF, ToF                 : file;
   NumRead, NumWritten        : Integer;
   Buf                        : array[1..2048] of Char;
begin
  if DoRenameCopy(FromFile, ToFile) then exit;
   AssignFile(FromF, FromFile);
   Reset(FromF, 1);                                     { Record size = 1 }
   AssignFile(ToF, ToFile);                             { Open output file }
   Rewrite(ToF, 1);                                     { Record size = 1 }
   repeat
      BlockRead(FromF, Buf, SizeOf(Buf), NumRead);
      BlockWrite(ToF, Buf, NumRead, NumWritten);
   until (NumRead = 0) or (NumWritten <> NumRead);
   CloseFile(FromF);
   CloseFile(ToF);
end;
{$ENDIF}

function DoRenameCopy(const FromFile, ToFile: string): boolean;
{ function to rename instead of copy a file if source and destination
  are on the same disk.  Thanks to Dennis Passmore.   11/27/00  2.21b4+
}
var
  fTempName: string;
  FromF: file;
  IOerr: integer;
  ecode: integer;
begin
  result := false;
  IOerr := IOResult;
{$undef IPlus}
{$ifopt I+}
{$define IPlus}
{$endif}
{$I-}
  if (AnsiCompareText(ExtractFileDrive(FromFile), ExtractFileDrive(ToFile)) = 0) then
  begin
    fTempName := '';
    ecode := SetErrormode(SEM_FAILCRITICALERRORS);
    if FileExists(ToFile) then
    begin
      fTempName := ToFile+'$$$';
      AssignFile(FromF, ToFile);
      System.Rename(FromF, fTempName);
      IOerr := IOresult;
    end;
    if (IOerr = 0) then
    begin
      AssignFile(FromF, FromFile);
      System.Rename(FromF, ToFile);
      Result := IOresult = 0;
      if Result and (fTempName <> '') and FileExists(fTempName) then
      begin
        AssignFile(FromF, fTempName);
        System.Erase(FromF);
        {if (IOresult <> 0) then;}
      end;
    end;
    SetErrormode(ecode);
  end;
{$ifdef IPlus}
{$I+}
{$undef IPlus}
{$endif}
end;

procedure FileCopy(const FromFile, ToFile: string);
var
   S, T                       : TFileStream;
   msg1, msg2                 : string;
begin
   if DoRenameCopy(FromFile, ToFile) then exit;  { 2.21b4+ }
   S := TFileStream.Create(FromFile, fmOpenRead);
   try
      T := TFileStream.Create(ToFile, fmOpenWrite or fmCreate);
      try
         if T.CopyFrom(S, 0) = 0 then
         begin
            {$IFDEF NO_RES}
            msg1 := 'Could not copy from ' + FromFile + ' to ' + ToFile;
            msg2 := 'Error';
            {$ELSE}
            msg1 := LoadStr(IDS_NOCOPY) + FromFile + ' -> ' + ToFile;
            msg2 := LoadStr(IDS_ERROR);
            {$ENDIF}
            MessageBox(0, StringAsPChar(msg1), StringAsPChar(msg2), MB_OK);
         end;
      finally
         T.Free;
      end;
   finally
      S.Free;
   end;
end;

function PCharToStr(CStr: PChar): string;
begin
   if CStr = nil then
      Result := ''
   else
   begin
      {$IFDEF WIN32}
      SetLength(Result, StrLen(CStr));
      Move(CStr^, Result[1], Length(Result));
      {$ELSE}
      Result := StrPas(CStr);
      {$ENDIF}
   end;
end;

function StrToPChar(Str: string): PChar;
begin
   if Str = '' then
      Result := nil
   else
   begin
      Result := StrAlloc(Length(Str) + 1);
      {$IFDEF WIN32}
      StrCopy(Result, PChar(Str));
      {$ELSE}
      StrPCopy(Result, Str);
      {$ENDIF}
   end;
end;

function SetVolLabel(Disk, NewLabel: string): LongBool;
{$IFNDEF WIN32}
var
   DiskLabel                  : Str11;
   Drive                      : Char;
   {$ENDIF}
begin
   {$IFNDEF NODISKUTILS}
   {$IFDEF WIN32}
   { Make sure label is deleted first }
   SetVolumeLabel(StringAsPChar(Disk), nil);
   { Set the new label }
   Result := SetVolumeLabel(StringAsPChar(Disk), StringAsPChar(NewLabel));
   {$ELSE}
   Drive := Chr(Ord(Disk[1]));                          { removed -64 on 3/9/98 2.03 }
   DiskLabel := NewLabel;
   SetDiskLabel(DiskLabel, Drive);
   Result := LongBool(True);
   {$ENDIF}
   {$ELSE}
   Result := False;
   {$ENDIF}
end;

function GetVolumeLabel(Disk: string): string;
{$IFNDEF NODISKUTILS}
{$IFNDEF WIN32}

   procedure PadVolumeLabel(var Name: Str11);
      { procedure pads Volume Label string with spaces }
   var
      i                       : integer;
   begin
      for i := Length(Name) + 1 to 11 do
         Name := Name + ' ';
   end;
   {$ENDIF}
var
   Dummy2, Dummy3             : DWORD;
   {$IFNDEF WIN32}
   SR                         : TSearchRec;
   DriveLetter                : Char;
   SearchString               : string[7];
   tmpResult                  : Str11;
   P                          : Byte;
   Dummy1                     : DWORD;
   Dummy4                     : string;
   DiskLabel                  : Str11;
   {$ELSE}
   DiskLabel                  : array[0..13] of char;
   {$ENDIF}
   {$ENDIF}
begin
   {$IFNDEF NODISKUTILS}
   {$IFDEF WIN32}
   GetVolumeInformation(StringAsPChar(Disk), DiskLabel, SizeOf(DiskLabel),
      nil, Dummy2, Dummy3, nil, 0);
   Result := StrPas(DiskLabel);
   {$ELSE}
   if OSVersion = 3 then
   begin
      { Replaced old call because INT call wasn't working correctly.  11/4/98  2.17 }
      SearchString := Disk[1] + ':\*.*';
      { find vol label }
      if FindFirst(SearchString, faVolumeID, SR) = 0 then
      begin
         P := Pos('.', SR.Name);
         if P > 0 then
         begin                                          { if it has a dot... }
            tmpResult := '           ';                 { pad spaces between name }
            Move(SR.Name[1], tmpResult[1], P - 1);      { and extension }
            Move(SR.Name[P + 1], tmpResult[9], 3);
         end
         else
         begin
            tmpResult := SR.Name;                       { otherwise, pad to end }
            PadVolumeLabel(tmpResult);
         end;
      end
      else
         tmpResult := '';

      Result := tmpResult;
      {DiskNum := Ord(Disk[1])-64;}
      {GetMediaID( DiskNum, info );}
      {Result := info.volName;}
   end
   else
   begin
      GetVolumeInformation(Disk, DiskLabel, Dummy1, Dummy2, Dummy3, Dummy4);
      Result := DiskLabel;
   end;
   {$ENDIF}
   {$ELSE}
   Result := '';
   {$ENDIF}
end;

{ Added 5/5/98  2.12 }

function TempFileName(Pathname: string): string;
var
   TmpFileName                : array[0..255] of Char;
begin
   {$IFNDEF WIN32}
   GetTempFileName('C', 'KPZ', 0, TmpFileName);
   if Pathname[Length(Pathname)] = '\' then
      Result := Pathname + ExtractFilename(PCharToStr(TmpFileName))
   else
      Result := Pathname + '\' + ExtractFilename(PCharToStr(TmpFileName))
         {$ELSE}
   GetTempFileName(StringAsPChar(Pathname), 'KPZ', 0, TmpFileName);
   Result := PCharToStr(TmpFileName);
   {$ENDIF}
end;

procedure OemFilter(var fname: string);
begin
   {$IFDEF WIN32}
   CharToOem(@fname[1], @fname[1]);
   {$ELSE}
   AnsiToOem(StringAsPChar(fname), StringAsPChar(fname));
   {$ENDIF}
   {$IFDEF WIN32}
   OemToChar(@fname[1], @fname[1]);
   {$ELSE}
   OemToAnsi(StringAsPChar(fname), StringAsPChar(fname));
   {$ENDIF}
end;

{$IFNDEF Ver100}
{ A very simple assert routine for D1 and D2 }

procedure Assert(Value: Boolean; Msg: string);
begin
   {$IFDEF ASSERTS}
   if not Value then
      ShowMessage(Msg);
   {$ENDIF}
end;
{$ENDIF}

{$IFDEF WIN32}

function BlockCompare(const Buf1, Buf2; Count: Integer): Boolean;
type
   BufArray = array[0..MaxInt - 1] of Char;
var
   I                          : Integer;
begin
   Result := False;
   for I := 0 to Count - 1 do
      if BufArray(Buf1)[I] <> BufArray(Buf2)[I] then Exit;
   Result := True;
end;

function StringAsPChar(var S: string): PChar;
begin
   Result := PChar(S);
end;

{$ELSE} { These functions are defined for 16 bit }

function BlockCompare(const Buf1, Buf2; Count: Integer): Boolean; ASSEMBLER;
asm
        PUSH    DS
        LDS     SI,Buf1
        LES     DI,Buf2
        MOV     CX,Count
        XOR     AX,AX
        CLD
        REPE    CMPSB
        JNE     @@1
        INC     AX
@@1:    POP     DS