paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-17 03:39:28 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Add LoadKnownTypes to load default set from OS (including registry on windows)

Browse Source 
git-svn-id: trunk@42820 -
This commit is contained in:
michael 2019-08-26 06:36:01 +00:00
parent 2a394402aa
commit b81b4a3aa6
1 changed files with 101 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

104
packages/fcl-base/src/fpmimetypes.pp
View File

@ -46,9 +46,18 @@ Type
Protected
Function FindMimeByType(Const AMime : String) : TMimeType;
Function FindMimeByExt(Const AExt : String) : TMimeType;
Function DefaultMimeTypesLocation : String; virtual;
{$IFDEF WINDOWS}
Procedure LoadFromRegistry;
{$ENDIF}
Public
Constructor Create(AOwner : TComponent); override;
Destructor Destroy; override;
// clear list
Procedure Clear;
// Load known types from OS.
// On unixy types, this reads from /etc/mime.types, on windows this reads from registry and from mime.types located next to binary
Procedure LoadKnownTypes; virtual;
// Extract an extension from an extension list as returned by GetMimeExtensions
class function GetNextExtension(var E: String): string;
// Load from stream
@ -72,6 +81,10 @@ Function MimeTypes : TFPMimeTypes;
implementation
{$IFDEF WINDOWS}
uses registry;
{$ENDIF}
{ TFPMimeTypes }
var
FTypes : TFPMimeTypes;
@ -117,6 +130,7 @@ Var
S : String;
begin
Extensions:='';
P:=1;
Mime:=GetNextWord(ALine,p);
Repeat
@ -161,6 +175,20 @@ begin
end
end;
function TFPMimeTypes.DefaultMimeTypesLocation: String;
begin
{$IFDEF windows}
Result:=ExtractFilePath(ParamStr(0));
{$ELSE}
{$IFDEF DARWIN}
Result:='/private/etc/apache2/';
{$ELSE}
Result:='/etc/';
{$ENDIF}
{$ENDIF}
end;
constructor TFPMimeTypes.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
@ -170,6 +198,15 @@ end;
destructor TFPMimeTypes.Destroy;
begin
Clear;
FreeAndNil(FTypes);
FreeAndNil(FExtensions);
inherited Destroy;
end;
procedure TFPMimeTypes.Clear;
Var
T : TMimeType;
I : integer;
@ -180,11 +217,67 @@ begin
T:=TMimeType(FTypes.Items[i]);
FreeAndNil(T);
end;
FreeAndNil(FTypes);
FreeAndNil(FExtensions);
inherited Destroy;
FTypes.Clear;
FExtensions.Clear;
end;
procedure TFPMimeTypes.LoadKnownTypes;
Var
S : String;
begin
{$IFDEF WINDOWS}
LoadFromRegistry;
{$ENDIF}
S:=DefaultMimeTypesLocation;
if (S<>'') then
begin
S:=S+'mime.types';
if FileExists(S) then
LoadFromFile(S);
end;
end;
{$IFDEF WINDOWS}
procedure TFPMimeTypes.LoadFromRegistry;
Var
Reg : TRegistry;
aType,Ext : string;
L : TStringList;
I : Integer;
begin
L:=Nil;
Reg := TRegistry.Create;
try
L:=TStringList.Create;
Reg.RootKey := HKEY_CLASSES_ROOT;
if Reg.OpenKeyReadOnly('') then
begin
Reg.GetKeyNames(L);
Reg.CloseKey;
For I:=0 to L.Count-1 do
begin
Ext:=L[i];
if (Ext<>'') and (Ext[1]='.') and Reg.OpenKeyReadOnly(Ext) then
begin
aType:= Reg.ReadString('Content Type');
Reg.CloseKey;
if aType<>'' then
AddType(aType,Ext);
end;
end;
Reg.CloseKey;
end;
finally
L.Free;
Reg.Free;
end;
end;
{$ENDIF WINDOWS}
procedure TFPMimeTypes.LoadFromStream(const Stream: TStream);
Var
@ -293,6 +386,7 @@ begin
AList.Clear;
For I:=0 to FTypes.Count-1 do
Alist.Add(FTypes.NameOfIndex(i));
Result:=AList.Count;
finally
AList.EndUpdate;
end;
@ -308,6 +402,7 @@ begin
AList.Clear;
For I:=0 to FExtensions.Count-1 do
Alist.Add(FExtensions.NameOfIndex(i));
Result:=AList.Count;
finally
AList.EndUpdate;
end;
@ -334,6 +429,9 @@ begin
If (E<>'') then
begin
E:=E+';';
if (Fextensions<>'') then
If Fextensions[Length(FExtensions)]<>';' then
FExtensions:=FExtensions+';';
If (Copy(Fextensions,1,Length(E))<>E) and (Pos(E,FExtensions)=0) then
FExtensions:=Extensions+E;
end;