521 lines
12 KiB
ObjectPascal
521 lines
12 KiB
ObjectPascal
|
|
{******************************************}
|
|
{ }
|
|
{ FastReport VCL }
|
|
{ Report Server misc utils }
|
|
{ }
|
|
{ Copyright (c) 1998-2021 }
|
|
{ by Fast Reports Inc. }
|
|
{ }
|
|
{******************************************}
|
|
|
|
unit frxServerUtils;
|
|
|
|
{$I frx.inc}
|
|
|
|
interface
|
|
|
|
uses
|
|
{$IFNDEF Linux}
|
|
Windows, ActiveX,
|
|
{$ELSE}
|
|
LCLType, LCLIntf, LCLProc,
|
|
{$ENDIF}
|
|
Classes, SysUtils, Messages, frxUtils;
|
|
|
|
function StrToHex(const s: AnsiString): AnsiString;
|
|
function HexToStr(const s : AnsiString) : AnsiString;
|
|
function Byte2Hex(const b: byte): AnsiString;
|
|
function GetHTTPErrorText(const ErrorCode: integer):AnsiString;
|
|
function GetUniqueFileName(const Path: String; const Prefix: String): String;
|
|
{$IFDEF Delphi12}
|
|
function Str2HTML(const Str: WideString): AnsiString; overload;
|
|
function Str2HTML(const Str: AnsiString): AnsiString; overload;
|
|
{$ELSE}
|
|
function Str2HTML(const Str: AnsiString): AnsiString;
|
|
{$ENDIF}
|
|
|
|
function HTML2Str(const Line: AnsiString): AnsiString;
|
|
function UnQuoteStr(const s: AnsiString): AnsiString;
|
|
function GetEnvVar(const VarName: String): String;
|
|
function MakeSessionId: AnsiString;
|
|
|
|
function frxGetAbsPath(const Path: String): String;
|
|
function frxGetRelPath(const Path: String): String;
|
|
function frxGetAbsPathDir(const Path: String; const Dir: String): String;
|
|
function frxGetRelPathDir(const Path: String; const Dir: String): String;
|
|
|
|
procedure frxTouchDir(const Path: String);
|
|
procedure SetCommaText(const Text: String; sl: TStrings; Comma: Char = ';');
|
|
function NormalDir(const DirName: string): string;
|
|
procedure CopyFile(const fFrom, fTo: String);
|
|
procedure CopyFiles(const sFrom, sTo, sNames, sExcept: String; const Recursive: Boolean);
|
|
procedure CopyFilesF(const sFrom, sTo, sNames, sExcept: String);
|
|
|
|
type
|
|
TfrxServerFormat = (sfHTM, sfXML, sfXLS, sfRTF, sfCSV, sfTXT, sfPDF, sfJPG, sfBMP, sfTIFF, sfGIF, sfFRP, sfODS, sfODT, sfHTMD);
|
|
TfrxServerOutputFormats = set of TfrxServerFormat;
|
|
TfrxHTTPQueryType = (qtGet, qtPost, qtHead);
|
|
|
|
implementation
|
|
|
|
uses StrUtils;
|
|
|
|
function StrToHex(const s: AnsiString): AnsiString;
|
|
var
|
|
Len, i: Integer;
|
|
C, H, L: Byte;
|
|
|
|
function HexChar(N : Byte) : AnsiChar;
|
|
begin
|
|
if (N < 10) then Result := AnsiChar(Chr(Ord('0') + N))
|
|
else Result := AnsiChar(Chr(Ord('A') + (N - 10)));
|
|
end;
|
|
|
|
begin
|
|
Len := Length(s);
|
|
SetLength(Result, Len shl 1);
|
|
for i := 1 to Len do begin
|
|
C := Ord(s[i]);
|
|
H := (C shr 4) and $f;
|
|
L := C and $f;
|
|
Result[i shl 1 - 1] := HexChar(H);
|
|
Result[i shl 1]:= HexChar(L);
|
|
end;
|
|
end;
|
|
|
|
function HexToStr(const s : AnsiString) : AnsiString;
|
|
var
|
|
Len, i: Integer;
|
|
C, H, L: Byte;
|
|
|
|
function CharHex(C: AnsiChar): Byte;
|
|
begin
|
|
C := UpCase(C);
|
|
if (C <= '9') then Result := Ord(C) - Ord('0')
|
|
else Result := Ord(C) - Ord('A') + 10;
|
|
end;
|
|
|
|
begin
|
|
Len := Length(s);
|
|
SetLength(Result, Len shr 1);
|
|
for i := 1 to Len shr 1 do begin
|
|
H := CharHex(s[i shl 1 - 1]);
|
|
L := CharHex(s[i shl 1]);
|
|
C := H shl 4 or L;
|
|
Result[i] := AnsiChar(Chr(C));
|
|
end;
|
|
end;
|
|
|
|
function Byte2Hex(const b: byte): AnsiString;
|
|
var
|
|
H, L: Byte;
|
|
function HexChar(N : Byte) : AnsiChar;
|
|
begin
|
|
if (N < 10) then Result := AnsiChar(Chr(Ord('0') + N))
|
|
else Result := AnsiChar(Chr(Ord('A') + (N - 10)));
|
|
end;
|
|
begin
|
|
SetLength(Result, 2);
|
|
H := (b shr 4) and $f;
|
|
L := b and $f;
|
|
Result[1] := HexChar(H);
|
|
Result[2]:= HexChar(L);
|
|
end;
|
|
|
|
function GetHTTPErrorText(const ErrorCode: integer):AnsiString;
|
|
begin
|
|
case errorcode of
|
|
400: result:= 'Bad Request';
|
|
401: result:= 'Unauthorized';
|
|
402: result:= 'Payment Required';
|
|
403: result:= 'Forbidden';
|
|
404: result:= 'Not Found';
|
|
405: result:= 'Method Not Allowed';
|
|
406: result:= 'Not Acceptable';
|
|
407: result:= 'Proxy Authentication Required';
|
|
408: result:= 'Request Timeout';
|
|
409: result:= 'Conflict';
|
|
410: result:= 'Gone';
|
|
411: result:= 'Length Required';
|
|
412: result:= 'Precondition Failed';
|
|
413: result:= 'Request Entity Too Large';
|
|
414: result:= 'Request-URI Too Long';
|
|
415: result:= 'Unsupported Media Type';
|
|
500: result:= 'Internal Server Error';
|
|
501: result:= 'Not Implemented'
|
|
else
|
|
Result := ''
|
|
end;
|
|
if Length(Result) > 0 then
|
|
Result := Result + ' (' + AnsiString(IntToStr(errorcode)) + ')';
|
|
end;
|
|
|
|
function GetUniqueFileName(const Path: String; const Prefix: String): String;
|
|
begin
|
|
{$IFDEF Delphi12}
|
|
Result := Path + PathDelim + Prefix + String(MakeSessionId) + '.tmp';
|
|
{$ELSE}
|
|
Result := Path + PathDelim + Prefix + MakeSessionId + '.tmp';
|
|
{$ENDIF}
|
|
end;
|
|
|
|
{$IFDEF Delphi12}
|
|
function Str2HTML(const Str: WideString): AnsiString;
|
|
begin
|
|
Result := Str2HTML(AnsiString(Str));
|
|
end;
|
|
{$ENDIF}
|
|
|
|
function Str2HTML(const Str: AnsiString): AnsiString;
|
|
var
|
|
i: Integer;
|
|
c: AnsiChar;
|
|
s: AnsiString;
|
|
begin
|
|
Result := '';
|
|
for i := 1 to Length(Str) do
|
|
begin
|
|
c := Str[i];
|
|
case c of
|
|
'0'..'9', 'A'..'Z', 'a'..'z', '.', '-': Result := Result + c;
|
|
else begin
|
|
s := c;
|
|
Result := Result + '%' + StrToHex(s);
|
|
end
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function HTML2Str(const Line: AnsiString): AnsiString;
|
|
var
|
|
i: Integer;
|
|
s, buf: AnsiString;
|
|
begin
|
|
Result := Line;
|
|
if Length(Result) > 0 then
|
|
begin
|
|
i := 1;
|
|
while i <= Length(Result) do
|
|
begin
|
|
if Result[i] = '%' then
|
|
begin
|
|
if i <= Length(Result) - 2 then
|
|
begin
|
|
s := Result[i + 1] + Result[i + 2];
|
|
buf := HexToStr(s);
|
|
Delete(Result, i, 2);
|
|
Result[i] := buf[1];
|
|
end
|
|
end
|
|
else
|
|
if Result[i] = '+' then
|
|
Result[i] := ' ';
|
|
i := i + 1;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function UnQuoteStr(const s: AnsiString): AnsiString;
|
|
begin
|
|
Result := s;
|
|
if Length(Result) > 0 then
|
|
begin
|
|
if (Result[1] = #39) and (Result[Length(Result)] = #39) then
|
|
begin
|
|
Delete(Result, 1, 1);
|
|
Delete(Result, Length(Result), 1);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function GetEnvVar(const VarName: String): String;
|
|
{$IFNDEF FPC}
|
|
var
|
|
buffer: PChar;
|
|
size: Integer;
|
|
const
|
|
BUF_SIZE = 4096;
|
|
{$ENDIF}
|
|
begin
|
|
{$IFNDEF FPC}
|
|
Result := '';
|
|
size := 0;
|
|
GetMem(buffer, BUF_SIZE);
|
|
if buffer <> nil then
|
|
size := GetEnvironmentVariable(PChar(VarName), buffer, BUF_SIZE);
|
|
if size > 0 then
|
|
Result := String(buffer);
|
|
FreeMem(buffer);
|
|
{$ELSE}
|
|
Result := GetEnvironmentVariable(VarName);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
function MakeSessionId: AnsiString;
|
|
{$IFNDEF Linux}
|
|
var
|
|
AGUID: TGUID;
|
|
AGUIDString: widestring;
|
|
begin
|
|
CoCreateGUID(AGUID);
|
|
SetLength(AGUIDString, 39);
|
|
StringFromGUID2(AGUID, PWideChar(AGUIDString), 39);
|
|
{$IFDEF Delphi12}
|
|
Result := AnsiString(PWideChar(AGUIDString));
|
|
{$ELSE}
|
|
Result := string(PWideChar(AGUIDString));
|
|
{$ENDIF}
|
|
Result := Copy(Result, 2, 36);
|
|
|
|
{$IFDEF Delphi12}
|
|
Result := AnsiString(StringReplace(String(Result), '-', '', [rfReplaceAll]));
|
|
{$ELSE}
|
|
Result := StringReplace(Result, '-', '', [rfReplaceAll]);
|
|
{$ENDIF}
|
|
end;
|
|
{$ELSE}
|
|
function RandStr(len: Integer):String;
|
|
const
|
|
HexDigits: array[0..15] of char = '0123456789ABCDEF';
|
|
var
|
|
i: Integer;
|
|
begin
|
|
Result := '';
|
|
for i := 1 to len do
|
|
Result := Result + HexDigits[Random(16)];
|
|
end;
|
|
|
|
begin
|
|
Result := RandStr(32);
|
|
end;
|
|
{$ENDIF}
|
|
|
|
function frxGetAbsPath(const Path: String): String;
|
|
begin
|
|
Result := frxGetAbsPathDir(Path, GetAppPath);
|
|
end;
|
|
|
|
function frxGetAbsPathDir(const Path: String; const Dir: String): String;
|
|
var
|
|
s: String;
|
|
i: Integer;
|
|
begin
|
|
s := Dir;
|
|
if Pos('.' + PathDelim, Path) = 1 then
|
|
Result := StringReplace(Path, '.' + PathDelim, s, [])
|
|
else
|
|
if Pos('..' + PathDelim, Path) = 1 then
|
|
begin
|
|
s := frxReverseString(s);
|
|
i := PosEx(PathDelim, s, 2);
|
|
if i > 0 then
|
|
s := Copy(s, i, Length(s) - i + 1);
|
|
Result := frxReverseString(s) + Copy(Path, 4, Length(Path) - 3);
|
|
end
|
|
else
|
|
begin
|
|
{$IFNDEF FPC}
|
|
if (Pos('%', Path) = 1) then
|
|
begin
|
|
SetLength(Result, MAX_PATH);
|
|
i := ExpandEnvironmentStrings(PChar(Path), PChar(@Result[1]), MAX_PATH);
|
|
SetLength(Result, i - 1);
|
|
end
|
|
else
|
|
{$ENDIF}
|
|
Result := Path;
|
|
if not((Pos(PathDelim, Result) = 1) or (Pos(':', Result) = 2)) then
|
|
Result := s + Result;
|
|
end;
|
|
end;
|
|
|
|
function frxGetRelPath(const Path: String): String;
|
|
begin
|
|
Result := frxGetRelPathDir(Path, GetAppPath);
|
|
end;
|
|
|
|
function frxGetRelPathDir(const Path: String; const Dir: String): String;
|
|
var
|
|
s1, s2: String;
|
|
begin
|
|
s1 := Dir;
|
|
s2 := frxGetAbsPathDir('..' + PathDelim, Dir);
|
|
if Pos(s1, Path) = 1 then
|
|
Result := StringReplace(Path, s1, '.' + PathDelim, [rfIgnoreCase])
|
|
else
|
|
if Pos(s2, Path) = 1 then
|
|
Result := StringReplace(Path, s2, '..' + PathDelim, [rfIgnoreCase])
|
|
else
|
|
Result := Path;
|
|
end;
|
|
|
|
procedure frxTouchDir(const Path: String);
|
|
{$IFNDEF FPC}
|
|
var
|
|
SecAtrtrs: TSecurityAttributes;
|
|
begin
|
|
if not DirectoryExists(Path) then
|
|
begin
|
|
SecAtrtrs.nLength := SizeOf(TSecurityAttributes);
|
|
SecAtrtrs.lpSecurityDescriptor := nil;
|
|
SecAtrtrs.bInheritHandle := true;
|
|
CreateDirectory(PChar(Path), @SecAtrtrs);
|
|
end;
|
|
end;
|
|
{$ELSE}
|
|
begin
|
|
if not DirectoryExists(Path) then
|
|
CreateDir(Path);
|
|
end;
|
|
{$ENDIF}
|
|
|
|
procedure SetCommaText(const Text: String; sl: TStrings; Comma: Char = ';');
|
|
var
|
|
i: Integer;
|
|
|
|
function ExtractCommaName(s: string; var Pos: Integer): string;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
i := Pos;
|
|
while (i <= Length(s)) and (s[i] <> Comma) do Inc(i);
|
|
Result := Copy(s, Pos, i - Pos);
|
|
if (i <= Length(s)) and (s[i] = Comma) then Inc(i);
|
|
Pos := i;
|
|
end;
|
|
|
|
begin
|
|
i := 1;
|
|
sl.Clear;
|
|
while i <= Length(Text) do
|
|
sl.Add(ExtractCommaName(Text, i));
|
|
end;
|
|
|
|
function NormalDir(const DirName: string): string;
|
|
begin
|
|
{$IFNDEF Linux}
|
|
Result := DirName;
|
|
if (Result <> '') and
|
|
{$IFDEF Delphi12}
|
|
not (CharInSet(Result[Length(Result)], [WideChar(':'), WideChar(PathDelim)])) then
|
|
{$ELSE}
|
|
not (Result[Length(Result)] in [':', PathDelim]) then
|
|
{$ENDIF}
|
|
begin
|
|
{$IFDEF Delphi12}
|
|
if (Length(Result) = 1) and (CharInSet(UpCase(Result[1]), [WideChar('A') .. WideChar('Z')])) then
|
|
{$ELSE}
|
|
if (Length(Result) = 1) and (UpCase(Result[1]) in ['A'..'Z']) then
|
|
{$ENDIF}
|
|
Result := Result + ':' + PathDelim
|
|
else Result := Result + PathDelim;
|
|
end;
|
|
{$ELSE}
|
|
Result := DirName;
|
|
if (Result <> '') and (Result[Length(Result)] <> PathDelim) then
|
|
Result := Result + PathDelim;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure CopyFile(const fFrom, fTo: String);
|
|
var
|
|
fsFrom, fsTo: TFileStream;
|
|
begin
|
|
try
|
|
fsFrom := TFileStream.Create(fFrom, fmOpenRead);
|
|
fsTo := TFileStream.Create(fTo, fmCreate);
|
|
fsTo.CopyFrom(fsFrom, 0);
|
|
fsTo.Free;
|
|
fsFrom.Free;
|
|
except
|
|
end;
|
|
end;
|
|
|
|
procedure CopyFiles(const sFrom, sTo, sNames, sExcept: String; const Recursive: Boolean);
|
|
var
|
|
SRec: TSearchRec;
|
|
i: Integer;
|
|
dirName: String;
|
|
begin
|
|
CopyFilesF(sFrom, sTo, sNames, sExcept);
|
|
if Recursive then
|
|
begin
|
|
i := FindFirst(NormalDir(sFrom) + '*.*', faArchive + faDirectory, SRec);
|
|
while i = 0 do
|
|
begin
|
|
if (SRec.Name <> '.') and (SRec.Name <> '..') then
|
|
begin
|
|
if (SRec.Attr and faDirectory) > 0 then
|
|
begin
|
|
try
|
|
dirName := NormalDir(sTo) + SRec.Name;
|
|
if not DirectoryExists(dirName) then
|
|
MkDir(dirName);
|
|
except
|
|
end;
|
|
CopyFiles(NormalDir(sFrom) + SRec.Name, NormalDir(sTo) + SRec.Name, sNames, sExcept, Recursive);
|
|
end;
|
|
end;
|
|
i := FindNext(SRec);
|
|
end;
|
|
FindClose(SRec);
|
|
end;
|
|
end;
|
|
|
|
procedure CopyFilesF(const sFrom, sTo, sNames, sExcept: String);
|
|
var
|
|
i: Integer;
|
|
lNames, lExcept, ExceptList: TStringList;
|
|
|
|
procedure MakeExceptList(const ext: String);
|
|
var
|
|
sr: TSearchRec;
|
|
begin
|
|
if FindFirst(NormalDir(sFrom) + ext, faReadOnly + faArchive, sr) = 0 then
|
|
begin
|
|
repeat
|
|
ExceptList.Add(sr.Name);
|
|
until FindNext(sr) <> 0;
|
|
FindClose(sr);
|
|
end;
|
|
end;
|
|
|
|
procedure CopyOneExt(const ext: String);
|
|
var
|
|
sr: TSearchRec;
|
|
begin
|
|
if FindFirst(NormalDir(sFrom) + ext, faReadOnly + faArchive, sr) = 0 then
|
|
begin
|
|
repeat
|
|
if ExceptList.IndexOf(sr.Name) = -1 then
|
|
CopyFile(NormalDir(sFrom) + sr.Name, NormalDir(sTo) + sr.Name);
|
|
until FindNext(sr) <> 0;
|
|
FindClose(sr);
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
lNames := TStringList.Create;
|
|
lExcept := TStringList.Create;
|
|
ExceptList := TStringList.Create;
|
|
SetCommaText(Trim(sNames), lNames, ' ');
|
|
SetCommaText(Trim(sExcept), lExcept, ' ');
|
|
|
|
for i := 0 to lExcept.Count - 1 do
|
|
MakeExceptList(lExcept[i]);
|
|
for i := 0 to lNames.Count - 1 do
|
|
CopyOneExt(lNames[i]);
|
|
|
|
lNames.Free;
|
|
lExcept.Free;
|
|
ExceptList.Free;
|
|
end;
|
|
|
|
{$IFDEF Linux}
|
|
initialization
|
|
Randomize;
|
|
{$ENDIF}
|
|
|
|
end.
|