scriptfunc_r.pas

源代码

    function ExtractFilePathNoDrive(const FileName: string): string;
    begin
      Result := PathExtractPath(FileName);
      Result := Copy(Result, PathDrivePartLength(FileName) + 1, Maxint);
    end;

    procedure SplitDirs(var Path: string; var Dirs: array of PChar;
      var DirCount: Integer);
    var
      I, J: Integer;
    begin
      I := 1;
      J := 0;
      while I <= Length(Path) do
      begin
        if Path[I] = '\' then             { Do not localize }
        begin
          Path[I] := #0;
          Dirs[J] := @Path[I + 1];
          Inc(J);
        end;
        Inc(I, CharLength(Path, I));
      end;
      DirCount := J - 1;
    end;

  begin
    if PathCompare(PathExtractDrive(BaseName), PathExtractDrive(DestName)) = 0 then
    begin
      BasePath := ExtractFilePathNoDrive(BaseName);
      DestPath := ExtractFilePathNoDrive(DestName);
      SplitDirs(BasePath, BaseDirs, BaseDirCount);
      SplitDirs(DestPath, DestDirs, DestDirCount);
      I := 0;
      while (I < BaseDirCount) and (I < DestDirCount) do
      begin
        if PathCompare(BaseDirs[I], DestDirs[I]) = 0 then
          Inc(I)
        else Break;
      end;
      Result := '';
      for J := I to BaseDirCount - 1 do
        Result := Result + '..\';              { Do not localize }
      for J := I to DestDirCount - 1 do
        Result := Result + DestDirs[J] + '\';  { Do not localize }
      Result := Result + PathExtractName(DestName);
    end else Result := DestName;
  end;

var
  PStart: Cardinal;
  OldName: String;
  NewDateSeparator, NewTimeSeparator: Char;
  OldDateSeparator, OldTimeSeparator: Char;
begin
  PStart := Stack.Count-1;
  Result := True;

  if Proc.Name = 'BEEP' then begin
    Beep();
  end else if Proc.Name = 'TRIM' then begin
    Stack.SetString(PStart, Trim(Stack.GetString(PStart-1)));
  end else if Proc.Name = 'TRIMLEFT' then begin
    Stack.SetString(PStart, TrimLeft(Stack.GetString(PStart-1)));
  end else if Proc.Name = 'TRIMRIGHT' then begin
    Stack.SetString(PStart, TrimRight(Stack.GetString(PStart-1)));
  end else if Proc.Name = 'GETCURRENTDIR' then begin
    Stack.SetString(PStart, GetCurrentDir());
  end else if Proc.Name = 'SETCURRENTDIR' then begin
    Stack.SetBool(PStart, SetCurrentDir(Stack.GetString(PStart-1)));
  end else if Proc.Name = 'EXPANDFILENAME' then begin
    Stack.SetString(PStart, PathExpand(Stack.GetString(PStart-1)));
  end else if Proc.Name = 'EXPANDUNCFILENAME' then begin
    Stack.SetString(PStart, ExpandUNCFileName(Stack.GetString(PStart-1)));
  end else if Proc.Name = 'EXTRACTRELATIVEPATH' then begin
    Stack.SetString(PStart, ExtractRelativePath(Stack.GetString(PStart-1), Stack.GetString(PStart-2)));
  end else if Proc.Name = 'EXTRACTFILEDIR' then begin
    Stack.SetString(PStart, PathExtractDir(Stack.GetString(PStart-1)));
  end else if Proc.Name = 'EXTRACTFILEDRIVE' then begin
    Stack.SetString(PStart, PathExtractDrive(Stack.GetString(PStart-1)));
  end else if Proc.Name = 'EXTRACTFILEEXT' then begin
    Stack.SetString(PStart, PathExtractExt(Stack.GetString(PStart-1)));
  end else if Proc.Name = 'EXTRACTFILENAME' then begin
    Stack.SetString(PStart, PathExtractName(Stack.GetString(PStart-1)));
  end else if Proc.Name = 'EXTRACTFILEPATH' then begin
    Stack.SetString(PStart, PathExtractPath(Stack.GetString(PStart-1)));
  end else if Proc.Name = 'CHANGEFILEEXT' then begin
    Stack.SetString(PStart, PathChangeExt(Stack.GetString(PStart-1), Stack.GetString(PStart-2)));
  end else if Proc.Name = 'FILESEARCH' then begin
    Stack.SetString(PStart, FileSearch(Stack.GetString(PStart-1), Stack.GetString(PStart-2)));
  end else if Proc.Name = 'RENAMEFILE' then begin
    OldName := Stack.GetString(PStart-1);
    if PathCompare(OldName, SetupLdrOriginalFilename) <> 0 then
      Stack.SetBool(PStart, RenameFile(OldName, Stack.GetString(PStart-2)))
    else
      Stack.SetBool(PStart, False);
  end else if Proc.Name = 'DELETEFILE' then begin
    Stack.SetBool(PStart, DeleteFile(Stack.GetString(PStart-1)));
  end else if Proc.Name = 'CREATEDIR' then begin
    Stack.SetBool(PStart, CreateDir(Stack.GetString(PStart-1)));
  end else if Proc.Name = 'REMOVEDIR' then begin
    Stack.SetBool(PStart, RemoveDir(Stack.GetString(PStart-1)));
  end else if Proc.Name = 'COMPARESTR' then begin
    Stack.SetInt(PStart, CompareStr(Stack.GetString(PStart-1), Stack.GetString(PStart-2)));
  end else if Proc.Name = 'COMPARETEXT' then begin
    Stack.SetInt(PStart, CompareText(Stack.GetString(PStart-1), Stack.GetString(PStart-2)));
  end else if Proc.Name = 'FORMAT1' then begin
    Stack.SetString(PStart, Format(Stack.GetString(PStart-1), [Stack.GetString(PStart-2)]));
  end else if Proc.Name = 'FORMAT2' then begin
    Stack.SetString(PStart, Format(Stack.GetString(PStart-1), [Stack.GetString(PStart-2), Stack.GetString(PStart-3)]));
  end else if Proc.Name = 'FORMAT3' then begin
    Stack.SetString(PStart, Format(Stack.GetString(PStart-1), [Stack.GetString(PStart-2), Stack.GetString(PStart-3), Stack.GetString(PStart-4)]));
  end else if Proc.Name = 'FORMAT4' then begin
    Stack.SetString(PStart, Format(Stack.GetString(PStart-1), [Stack.GetString(PStart-2), Stack.GetString(PStart-3), Stack.GetString(PStart-4), Stack.GetString(PStart-5)]));
  end else if Proc.Name = 'GETDATETIMESTRING' then begin
    OldDateSeparator := DateSeparator;
    OldTimeSeparator := TimeSeparator;
    try
      NewDateSeparator := Stack.GetString(PStart-2)[1];
      NewTimeSeparator := Stack.GetString(PStart-3)[1];
      if NewDateSeparator <> #0 then
        DateSeparator := NewDateSeparator;
      if NewTimeSeparator <> #0 then
        TimeSeparator := NewTimeSeparator;
      Stack.SetString(PStart, FormatDateTime(Stack.GetString(PStart-1), Now()));
    finally
      TimeSeparator := OldTimeSeparator;
      DateSeparator := OldDateSeparator;
    end;
  end else if Proc.Name = 'SYSERRORMESSAGE' then begin
    Stack.SetString(PStart, Win32ErrorString(Stack.GetInt(PStart-1)));
  end else
    Result := False;
end;

procedure FindDataToFindRec(const FindData: TWin32FindData;
  var FindRec: TFindRec);
begin
  FindRec.Name := FindData.cFileName;
  FindRec.Attributes := FindData.dwFileAttributes;
  FindRec.SizeHigh := FindData.nFileSizeHigh;
  FindRec.SizeLow := FindData.nFileSizeLow;
end;

function _FindFirst(const FileName: String; var FindRec: TFindRec): Boolean;
var
  FindHandle: THandle;
  FindData: TWin32FindData;
begin
  FindHandle := FindFirstFile(PChar(FileName), FindData);
  if FindHandle <> INVALID_HANDLE_VALUE then begin
    FindRec.FindHandle := FindHandle;
    FindDataToFindRec(FindData, FindRec);
    Result := True;
  end
  else begin
    FindRec.FindHandle := 0;
    Result := False;
  end;
end;

function _FindNext(var FindRec: TFindRec): Boolean;
var
  FindData: TWin32FindData;
begin
  Result := (FindRec.FindHandle <> 0) and FindNextFile(FindRec.FindHandle, FindData);
  if Result then
    FindDataToFindRec(FindData, FindRec);
end;

procedure _FindClose(var FindRec: TFindRec);
begin
  if FindRec.FindHandle <> 0 then begin
    Windows.FindClose(FindRec.FindHandle);
    FindRec.FindHandle := 0;
  end;
end;

{ FileCtrl }
function FileCtrlProc(Caller: TPSExec; Proc: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;

  function ForceDirectories(Dir: string): Boolean;
  begin
    Dir := RemoveBackslashUnlessRoot(Dir);
    if (PathExtractPath(Dir) = Dir) or DirExists(Dir) then
      Result := True
    else
      Result := ForceDirectories(PathExtractPath(Dir)) and CreateDir(Dir);
  end;

var
  PStart: Cardinal;
begin
  PStart := Stack.Count-1;
  Result := True;

  if Proc.Name = 'FORCEDIRECTORIES' then begin
    Stack.SetBool(PStart, ForceDirectories(Stack.GetString(PStart-1)));
  end else
    Result := False;
end;

{ VerInfo }
function VerInfoProc(Caller: TPSExec; Proc: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
var
  PStart: Cardinal;
  VersionNumbers: TFileVersionNumbers;
begin
  PStart := Stack.Count-1;
  Result := True;

  if Proc.Name = 'GETVERSIONNUMBERS' then begin
    if GetVersionNumbers(Stack.GetString(PStart-1), VersionNumbers) then begin
      Stack.SetInt(PStart-2, VersionNumbers.MS);
      Stack.SetInt(PStart-3, VersionNumbers.LS);
      Stack.SetBool(PStart, True);
    end else
      Stack.SetBool(PStart, False);
  end else if Proc.Name = 'GETVERSIONNUMBERSSTRING' then begin
    if GetVersionNumbers(Stack.GetString(PStart-1), VersionNumbers) then begin
      Stack.SetString(PStart-2, Format('%u.%u.%u.%u', [VersionNumbers.MS shr 16,
        VersionNumbers.MS and $FFFF, VersionNumbers.LS shr 16, VersionNumbers.LS and $FFFF]));
      Stack.SetBool(PStart, True);
    end else
      Stack.SetBool(PStart, False);
  end else
    Result := False;
end;

type
  TDllProc = function(const Param1, Param2: Longint): Longint; stdcall;

{ Windows }
function WindowsProc(Caller: TPSExec; Proc: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
var
  PStart: Cardinal;
  DllProc: TDllProc;
  DllHandle: THandle;
  S: String;
begin
  PStart := Stack.Count-1;
  Result := True;

  if Proc.Name = 'SLEEP' then begin
    Sleep(Stack.GetInt(PStart));
  end else if Proc.Name = 'FINDWINDOWBYCLASSNAME' then begin
    Stack.SetInt(PStart, FindWindow(PChar(Stack.GetString(PStart-1)), nil));
  end else if Proc.Name = 'FINDWINDOWBYWINDOWNAME' then begin
    Stack.SetInt(PStart, FindWindow(nil, PChar(Stack.GetString(PStart-1))));
  end else if Proc.Name = 'SENDMESSAGE' then begin
    Stack.SetInt(PStart, SendMessage(Stack.GetInt(PStart-1), Stack.GetInt(PStart-2), Stack.GetInt(PStart-3), Stack.GetInt(PStart-4)));
  end else if Proc.Name = 'POSTMESSAGE' then begin
    Stack.SetBool(PStart, PostMessage(Stack.GetInt(PStart-1), Stack.GetInt(PStart-2), Stack.GetInt(PStart-3), Stack.GetInt(PStart-4)));
  end else if Proc.Name = 'SENDNOTIFYMESSAGE' then begin
    Stack.SetBool(PStart, SendNotifyMessage(Stack.GetInt(PStart-1), Stack.GetInt(PStart-2), Stack.GetInt(PStart-3), Stack.GetInt(PStart-4)));
  end else if Proc.Name = 'REGISTERWINDOWMESSAGE' then begin
    Stack.SetInt(PStart, RegisterWindowMessage(PChar(Stack.GetString(PStart-1))));
  end else if Proc.Name = 'SENDBROADCASTMESSAGE' then begin
    Stack.SetInt(PStart, SendMessage(HWND_BROADCAST, Stack.GetInt(PStart-1), Stack.GetInt(PStart-2), Stack.GetInt(PStart-3)));
  end else if Proc.Name = 'POSTBROADCASTMESSAGE' then begin
    Stack.SetBool(PStart, PostMessage(HWND_BROADCAST, Stack.GetInt(PStart-1), Stack.GetInt(PStart-2), Stack.GetInt(PStart-3)));
  end else if Proc.Name = 'SENDBROADCASTNOTIFYMESSAGE' then begin
    Stack.SetBool(PStart, SendNotifyMessage(HWND_BROADCAST, Stack.GetInt(PStart-1), Stack.GetInt(PStart-2), Stack.GetInt(PStart-3)));
  end else if Proc.Name = 'LOADDLL' then begin
    DllHandle := SafeLoadLibrary(Stack.GetString(PStart-1), SEM_NOOPENFILEERRORBOX);
    if DllHandle <> 0 then
      Stack.SetInt(PStart-2, 0)
    else
      Stack.SetInt(PStart-2, GetLastError());
    Stack.SetInt(PStart, DllHandle);
  end else if Proc.Name = 'CALLDLLPROC' then begin
    @DllProc := GetProcAddress(Stack.GetInt(PStart-1), PChar(Stack.GetString(PStart-2)));
    if Assigned(DllProc) then begin
      Stack.SetInt(PStart-5, DllProc(Stack.GetInt(PStart-3), Stack.GetInt(PStart-4)));
      Stack.SetBool(PStart, True);
    end else
      Stack.SetBool(PStart, False);
  end else if Proc.Name = 'FREEDLL' then begin
    Stack.SetBool(PStart, FreeLibrary(Stack.GetInt(PStart-1)));
  end else if Proc.Name = 'CREATEMUTEX' then begin
    CreateMutex(nil, False, PChar(Stack.GetString(PStart)));
  end else if Proc.Name = 'OEMTOCHARBUFF' then begin
    S := Stack.GetString(PStart);
    OemToCharBuff(PChar(S), PChar(S), Length(S));
    Stack.SetString(PStart, S);
  end else if Proc.Name = 'CHARTOOEMBUFF' then begin
    S := Stack.GetString(PStart);
    CharToOemBuff(PChar(S), PChar(S), Length(S));
    Stack.SetString(PStart, S);
  end else
    Result := False;
end;

{ Ole2 }
function Ole2Proc(Caller: TPSExec; Proc: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
begin
  Result := True;

  if Proc.Name = 'COFREEUNUSEDLIBRARIES' then begin
    CoFreeUnusedLibraries;
  end else
    Result := False;
end;

{ Logging }
function LoggingProc(Caller: TPSExec; Proc: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
var
  PStart: Cardinal;
begin
  PStart := Stack.Count-1;
  Result := True;

  if Proc.Name = 'LOG' then begin
    Log(Stack.GetString(PStart));
  end else
    Result := False;
end;

{ Other }
function OtherProc(Caller: TPSExec; Proc: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;

  function GetExceptionMessage: String;
  begin
    if Caller.ExceptionCode = erNoError then