program test;
{$mode objfpc}
{$H+}
uses
sysutils;
const
Filter = 'YAML|*.yml;*.yaml|All files|*';
var
FilterIndex: Integer;
DefaultExt: String = 'yml';
procedure SetDefaultExt(var AValue: string);
begin
if (AVAlue<>'') and (AValue[1]<>'.') then
AValue:='.'+AValue;
end;
function ExtractFilterValues(const Filter: String): TStringArray;
var
Arr: TStringArray;
i: Integer;
begin
Result := nil;
Arr := Filter.Split('|'{$if fpc_fullversion >= 30202}, TStringSplitOptions.ExcludeLastEmpty{$endif});
SetLength(Result, Length(Arr) div 2);
for i := Low(Arr) to High(Arr) do
begin
if Odd(i) then Result[i div 2] := Arr[i];
end;
end;
function GetExtensionFromFilterAtIndex(const Filter: String; Index: Integer): String;
{
Returns a file extension from a filter as used in TOpen/TSaveDialog
- it will return the extension (including the leading period) that matches the index (index starts at 1)
- it will return an empty string if the extension contains a wildcard, or on any failure
- filters have the format of:
'Text files (*.txt)|*.txt|'+
'Pascal files (*.pp;*.pas)|*.pp;*.pas|'+
'All files (*.*)|*.*'
- if a given extension is a composite (like '*.pp;*.pas') it will return the first one from the list
}
var
i: Integer;
FilterArr, CurrFilterArr: TStringArray;
CurrFilter, S: String;
begin
Result := '';
if Index < 1 then
Exit;
FilterArr := ExtractFilterValues(Filter);
Dec(Index); //adjust for zero-base FilterArr;
if Index > High(FilterArr) then
Exit;
CurrFilter := FilterArr[Index];
CurrFilterArr := CurrFilter.Split(';'{$if fpc_fullversion >= 30202}, TStringSplitOptions.ExcludeLastEmpty{$endif});
for i := Low(CurrFilterArr) to High(CurrFilterArr) do
begin
S := ExtractFileExt(CurrFilterArr[i]);
//if S is something like '*.p?;*.pas;' return the first one without a wildcard in the extension: e.g. '.pas'
if (Pos('?',S) = 0) and (Pos('*',S) = 0) then
Exit(S);
end;
end;
function FileExists(S: String): Boolean; begin result:=false;end;
function CheckFile(var AFilename: string): boolean;
var
Dir, Ext: string;
begin
Result:=true;
if (DefaultExt<>'') and (ExtractFileExt(AFilename)='')
and (not FileExists(AFilename)) then begin
Ext := GetExtensionFromFilterAtIndex(Filter, FilterIndex);
if (Length(Ext) > 0) then
AFileName := AFileName + Ext
else
AFilename:=AFilename+DefaultExt;
end;
//ofOverwritePrompt -> is done in the interface
{
if (ofPathMustExist in Options)
and (not DirPathExists(ExtractFileDir(AFilename))) then begin
Result:=false;
MessageDlg(rsfdPathMustExist,
Format(rsfdPathNoExist,[ExtractFileDir(AFilename)]),
mtError,[mbCancel],0);
exit;
end;
if (ofFileMustExist in Options)
and (not CheckFileMustExist(AFileName)) then begin
// CheckFileMustExists shows message dialog
Result:=false;
exit;
end;
if ofNoReadOnlyReturn in Options then begin
if FileExistsUTF8(AFilename) then
Result := FileIsWritable(AFilename)
else begin { File does not exist - check directory }
Dir := ExtractFileDir(AFilename);
if Dir = '' then
Dir := '.';
Result := DirectoryIsWritable(Dir);
end;
if not Result then begin
MessageDlg(rsfdFileReadOnlyTitle,
Format(rsfdFileReadOnly,[AFileName]),
mtError,[mbCancel],0);
exit;
end;
end;
}
end;
procedure CheckResult(Orig, Exp, Found: String; AFilterIndex: Integer);
begin
write(format('Fn as input: %-8s, FilterIndex: %d. Result: Fn = %s',[Orig, AFilterIndex, Found]));
if (Exp = Found) then
writeln(' -> OK')
else
writeln(' -> FAIL: expected ',Exp);
end;
var
Fn: String;
begin
SetDefaultExt(DefaultExt);
writeln('DefaultExt = "',DefaultExt,'"');
writeln('Filter = "',Filter,'"');
Fn := 'foo';
FilterIndex := 1;
CheckFile(Fn);
CheckResult('foo','foo.yml', Fn, 1);
Fn := 'foo.lua';
FilterIndex := 1;
CheckFile(Fn);
CheckResult('foo.lua','foo.lua', Fn, 1);
Fn := 'foo';
FilterIndex := 2;
CheckFile(Fn);
CheckResult('foo','foo.yml', Fn, 2);
Fn := 'foo.lua';
FilterIndex := 2;
CheckFile(Fn);
CheckResult('foo.lua','foo.lua', Fn, 2);
end.
Recent
