kplib.pas

这是在磁疗用DELPHI编写一套安装软件的程序源码

      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;
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
      if (fname <> '') and (fname[Length(fname)] = '\') then
        Delete(fname,Length(fname),1);
      Result := FileDateToDateTime(GoodTimeStamp(kpFileAge(fname)));
   except
      Result := Now;
   end;
   {$IFDEF SKIPCODE}
   f := FileOpen(fname, fmOpenRead);
   Result := FileDateToDateTime(FileGetDate(f));
   FileClose(f);
   {$ENDIF}
end;

function kpFileAge(const PathName: string): Integer;
var
  Handle: THandle;
  FindData: TWin32FindData;
  LocalFileTime: TFileTime;
begin
  Handle := FindFirstFile(PChar(PathName), FindData);
  if Handle <> INVALID_HANDLE_VALUE then
  begin
    Windows.FindClose(Handle);
    FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFileTime);
    if FileTimeToDosDateTime(LocalFileTime, LongRec(Result).Hi,
LongRec(Result).Lo) then
      Exit;
  end;
  Result := -1;
end;

procedure ForceDirs(Dir: string);
begin
  ForceCreateDirectories(Dir);
end;

function File_Exists(const FileName: string): Boolean;
begin
   Result := FileExists(Filename);
end;

function DirExists(Dir: string): Boolean;
begin
   Result := kpSmall.DirExists(Dir);
end;

procedure GetDirectory(D: Byte; var S: string);
begin
   GetDir(D, S);
end;

procedure ChDirectory(const S: string);
begin
   ChDir(S);
end;

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                       : TkpFileStream;
   msg1, msg2                 : string;
begin
   if DoRenameCopy(FromFile, ToFile) then exit;  { 2.21b4+ }
   S := TkpFileStream.Create(FromFile, fmOpenRead);
   try
      T := TkpFileStream.Create(ToFile, fmOpenWrite or fmCreate);
      try
         if T.CopyFrom(S, 0) = 0 then
         begin
            msg1 := LoadStr(IDS_NOCOPY) + FromFile + ' -> ' + ToFile;
            msg2 := LoadStr(IDS_ERROR);
            raise Exception.Create(msg2 + ': ' + msg1);
            // 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 isDriveRemovable(Drive: String): Boolean;
{$IFNDEF WIN32}
var
  DiskNo:  Integer;
{$ENDIF}
begin
  Result := False;
  {$IFDEF WIN32}
  if (GetDriveType(StringAsPChar(Drive)) = DRIVE_REMOVABLE) or
     (GetDriveType(StringAsPChar(Drive)) = DRIVE_CDROM) then
  {$ELSE}
  DiskNo := Ord(RootPath[1]) - 65;                 { -65 for 16bit GetDriveType }
  if (GetDriveType(DiskNo) = DRIVE_REMOVABLE) then
  {$ENDIF}
  Result := True;
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;
         FindClose(SR);
      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
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);