diff --git a/app/CastleEngineManifest.xml b/app/CastleEngineManifest.xml index 137bc59..d84c579 100644 --- a/app/CastleEngineManifest.xml +++ b/app/CastleEngineManifest.xml @@ -7,4 +7,9 @@ + + + + + diff --git a/app/android_services/diagnostic_report_export/app/src/main/java/io/castleengine/MainActivity.java b/app/android_services/diagnostic_report_export/app/src/main/java/io/castleengine/MainActivity.java new file mode 100644 index 0000000..f13f0e0 --- /dev/null +++ b/app/android_services/diagnostic_report_export/app/src/main/java/io/castleengine/MainActivity.java @@ -0,0 +1 @@ +services.add(new ServiceDiagnosticReportExport(this)); diff --git a/app/android_services/diagnostic_report_export/app/src/main/java/io/castleengine/ServiceDiagnosticReportExport.java b/app/android_services/diagnostic_report_export/app/src/main/java/io/castleengine/ServiceDiagnosticReportExport.java new file mode 100644 index 0000000..5ad8dcb --- /dev/null +++ b/app/android_services/diagnostic_report_export/app/src/main/java/io/castleengine/ServiceDiagnosticReportExport.java @@ -0,0 +1,100 @@ +package io.castleengine; + +import android.app.Activity; +import android.content.Intent; +import android.net.Uri; +import java.io.OutputStream; +import java.nio.charset.StandardCharsets; + +public class ServiceDiagnosticReportExport extends ServiceAbstract +{ + private static final int REQUEST_CREATE_DOCUMENT = 40127; + private static String pendingJson; + + public ServiceDiagnosticReportExport(MainActivity activity) + { + super(activity); + } + + @Override + public String getName() + { + return "diagnostic_report_export"; + } + + @Override + public boolean messageReceived(String[] parts) + { + if (parts.length != 2 || !parts[0].equals("diagnostic-report-export")) { + return false; + } + if (pendingJson != null) { + sendError("Export already pending"); + return true; + } + + pendingJson = parts[1]; + try { + Intent intent = new Intent(Intent.ACTION_CREATE_DOCUMENT); + intent.addCategory(Intent.CATEGORY_OPENABLE); + intent.setType("application/json"); + intent.putExtra(Intent.EXTRA_TITLE, "kam-mobile-diagnostics.json"); + getActivity().startActivityForResult(intent, REQUEST_CREATE_DOCUMENT); + } catch (Exception error) { + finishError(error); + } + return true; + } + + @Override + public void onActivityResult(int requestCode, int resultCode, Intent intent) + { + if (requestCode != REQUEST_CREATE_DOCUMENT) { + return; + } + if (resultCode == Activity.RESULT_CANCELED) { + pendingJson = null; + messageSend(new String[] { "diagnostic-report-export-result", "cancel" }); + return; + } + if (resultCode != Activity.RESULT_OK || intent == null || intent.getData() == null || pendingJson == null) { + finishError("Invalid export result"); + return; + } + + Uri uri = intent.getData(); + String json = pendingJson; + try (OutputStream stream = getActivity().getContentResolver().openOutputStream(uri)) { + if (stream == null) { + throw new IllegalStateException("Document provider returned no output stream"); + } + stream.write(json.getBytes(StandardCharsets.UTF_8)); + stream.flush(); + } catch (Exception error) { + finishError(error); + return; + } + pendingJson = null; + messageSend(new String[] { "diagnostic-report-export-result", "success" }); + } + + private void finishError(Exception error) + { + String message = error.getClass().getSimpleName(); + if (error.getMessage() != null) { + message += ": " + error.getMessage(); + } + finishError(message); + } + + private void finishError(String message) + { + pendingJson = null; + sendError(message); + } + + private void sendError(String message) + { + messageSend(new String[] { "diagnostic-report-export-result", "error", message }); + } +} diff --git a/code/GameDiagnosticsExport.pas b/code/GameDiagnosticsExport.pas new file mode 100644 index 0000000..1c87745 --- /dev/null +++ b/code/GameDiagnosticsExport.pas @@ -0,0 +1,116 @@ +unit GameDiagnosticsExport; + +{$mode objfpc}{$H+} + +interface + +type + TDiagnosticExportOutcomeKind = (deokSuccess, deokCancel, deokError); + + TDiagnosticExportOutcome = record + Kind: TDiagnosticExportOutcomeKind; + ErrorMessage: string; + end; + + TDiagnosticExportCallback = procedure(const AOutcome: TDiagnosticExportOutcome) of object; + +procedure ExportDiagnosticReport( + const AJsonSnapshot: string; + const ACallback: TDiagnosticExportCallback +); + +implementation + +uses + Classes, CastleMessaging, CastleStringUtils, SysUtils; + +const + ExportResultToken = 'diagnostic-report-export-result'; + +type + TDiagnosticExportListener = class + private + FPending: Boolean; + FCallback: TDiagnosticExportCallback; + procedure Complete(const AKind: TDiagnosticExportOutcomeKind; + const AErrorMessage: string); + function MessageReceived(const Received: TCastleStringList; + const ReceivedStream: TMemoryStream): Boolean; + public + constructor Create; + destructor Destroy; override; + procedure Export(const AJsonSnapshot: string; + const ACallback: TDiagnosticExportCallback); + end; + +constructor TDiagnosticExportListener.Create; +begin + inherited; + Messaging.OnReceive.Add(@MessageReceived); +end; + +destructor TDiagnosticExportListener.Destroy; +begin + Messaging.OnReceive.Remove(@MessageReceived); + inherited; +end; + +procedure TDiagnosticExportListener.Complete(const AKind: TDiagnosticExportOutcomeKind; + const AErrorMessage: string); +var + Outcome: TDiagnosticExportOutcome; + Callback: TDiagnosticExportCallback; +begin + Callback := FCallback; + FCallback := nil; + FPending := False; + Outcome.Kind := AKind; + Outcome.ErrorMessage := AErrorMessage; + if Assigned(Callback) then + Callback(Outcome); +end; + +function TDiagnosticExportListener.MessageReceived( + const Received: TCastleStringList; + const ReceivedStream: TMemoryStream): Boolean; +begin + Result := (Received.Count > 0) and (Received[0] = ExportResultToken); + if not Result or not FPending then + Exit; + + if (Received.Count = 2) and (Received[1] = 'success') then + Complete(deokSuccess, '') + else + if (Received.Count = 2) and (Received[1] = 'cancel') then + Complete(deokCancel, '') + else + if (Received.Count = 3) and (Received[1] = 'error') then + Complete(deokError, Received[2]) + else + Complete(deokError, 'Malformed export-service response'); +end; + +procedure TDiagnosticExportListener.Export(const AJsonSnapshot: string; + const ACallback: TDiagnosticExportCallback); +begin + if FPending then + raise Exception.Create('Diagnostic report export is already pending'); + FPending := True; + FCallback := ACallback; + Messaging.Send(['diagnostic-report-export', AJsonSnapshot]); +end; + +var + ExportListener: TDiagnosticExportListener; + +procedure ExportDiagnosticReport(const AJsonSnapshot: string; + const ACallback: TDiagnosticExportCallback); +begin + ExportListener.Export(AJsonSnapshot, ACallback); +end; + +initialization + ExportListener := TDiagnosticExportListener.Create; +finalization + FreeAndNil(ExportListener); +end. diff --git a/code/GameDiagnosticsFileIO.pas b/code/GameDiagnosticsFileIO.pas new file mode 100644 index 0000000..9bea431 --- /dev/null +++ b/code/GameDiagnosticsFileIO.pas @@ -0,0 +1,265 @@ +unit GameDiagnosticsFileIO; + +{$mode objfpc}{$H+} + +interface + +procedure RunFileIODiagnostic; + +implementation + +uses + Classes, SysUtils, GameSelectedMap, GameDiagnosticsReport, KaMResourceInput, + KM_CommonClasses; + +procedure InitializeResult(out AResult: TFileIODiagnosticResult); +var + Stage: TDiagnosticStageId; +begin + FillChar(AResult, SizeOf(AResult), 0); + AResult.Status := dsNotRun; + for Stage := Low(TDiagnosticStageId) to High(TDiagnosticStageId) do + AResult.Stages[Stage] := dsNotRun; +end; + +procedure FailStage(var AResult: TFileIODiagnosticResult; + const AStage: TDiagnosticStageId; const AMessage: string; + const AException: Exception = nil); +begin + AResult.Stages[AStage] := dsFail; + AResult.Status := dsFail; + AResult.FailureStage.HasValue := True; + AResult.FailureStage.Value := AStage; + AResult.Error.Present := True; + AResult.Error.MessageText.HasValue := True; + AResult.Error.MessageText.Value := AMessage; + if AException <> nil then + begin + AResult.Error.ClassName.HasValue := True; + AResult.Error.ClassName.Value := AException.ClassName; + end; +end; + +procedure FailException(var AResult: TFileIODiagnosticResult; + const AStage: TDiagnosticStageId; const AException: Exception); +begin + FailStage(AResult, AStage, AException.Message, AException); +end; + +function RunResourceExists(const AMapUrl: string; + var AResult: TFileIODiagnosticResult): Boolean; +begin + try + Result := KaMResourceExists(AMapUrl); + if Result then + AResult.Stages[dsiResourceExists] := dsPass + else + FailStage(AResult, dsiResourceExists, + 'Selected resource is not present'); + except + on E: Exception do + begin + FailException(AResult, dsiResourceExists, E); + Result := False; + end; + end; +end; + +function RunResourceOpen(const AMapUrl: string; + var AResult: TFileIODiagnosticResult): Boolean; +var + Source: TStream; +begin + Result := False; + Source := nil; + try + try + Source := KaMOpenResourceStream(AMapUrl); + if Source = nil then + begin + FailStage(AResult, dsiResourceOpen, 'Resource open returned no stream'); + Exit; + end; + Source.Free; + Source := nil; + AResult.Stages[dsiResourceOpen] := dsPass; + Result := True; + except + on E: Exception do + FailException(AResult, dsiResourceOpen, E); + end; + finally + if Source <> nil then + try + Source.Free; + except + on E: Exception do + if AResult.Status <> dsFail then + FailException(AResult, dsiResourceOpen, E); + end; + end; +end; + +function RunCallerStreamLoad(const AMapUrl: string; + var AStream: TKMemoryStreamBinary; var AResult: TFileIODiagnosticResult): Boolean; +begin + Result := False; + try + AStream := TKMemoryStreamBinary.Create; + AStream.LoadFromFile(AMapUrl); + AResult.Stages[dsiCallerStreamLoad] := dsPass; + Result := True; + except + on E: Exception do + FailException(AResult, dsiCallerStreamLoad, E); + end; +end; + +function RunStreamState(const AStream: TKMemoryStreamBinary; + var AResult: TFileIODiagnosticResult): Boolean; +begin + Result := False; + try + AResult.Stream.Size.Value := AStream.Size; + AResult.Stream.Size.HasValue := True; + AResult.Stream.PositionAfterLoad.Value := AStream.Position; + AResult.Stream.PositionAfterLoad.HasValue := True; + if AStream.Size <= 0 then + FailStage(AResult, dsiStreamState, 'Loaded stream is empty') + else if AStream.Position <> 0 then + FailStage(AResult, dsiStreamState, 'Loaded stream position is not zero') + else + begin + AResult.Stages[dsiStreamState] := dsPass; + Result := True; + end; + except + on E: Exception do + FailException(AResult, dsiStreamState, E); + end; +end; + +function RunSeekReadConsistency(const AStream: TKMemoryStreamBinary; + var AResult: TFileIODiagnosticResult): Boolean; +var + Requested, FirstCount, SecondCount, ExpectedPosition, RestoredPosition: LongInt; + FirstBytes, SecondBytes: array of Byte; + I: Integer; +begin + Result := False; + try + try + AResult.Stream.ReadOffset.Value := 0; + AResult.Stream.ReadOffset.HasValue := True; + Requested := 32; + if AStream.Size < Requested then Requested := LongInt(AStream.Size); + AResult.Stream.RequestedReadCount.Value := Requested; + AResult.Stream.RequestedReadCount.HasValue := True; + SetLength(FirstBytes, Requested); + SetLength(SecondBytes, Requested); + + FirstCount := AStream.Read(FirstBytes[0], Requested); + AResult.Stream.FirstReadCount.Value := FirstCount; + AResult.Stream.FirstReadCount.HasValue := True; + AResult.Stream.PositionAfterFirstRead.Value := AStream.Position; + AResult.Stream.PositionAfterFirstRead.HasValue := True; + ExpectedPosition := FirstCount; + if (FirstCount <> Requested) or (AStream.Position <> ExpectedPosition) then + begin + FailStage(AResult, dsiSeekReadConsistency, 'First read did not advance as required'); + Exit; + end; + + AResult.Stream.SeekBackPosition.Value := AStream.Seek(0, soBeginning); + AResult.Stream.SeekBackPosition.HasValue := True; + if (AResult.Stream.SeekBackPosition.Value <> 0) or (AStream.Position <> 0) then + begin + FailStage(AResult, dsiSeekReadConsistency, 'Seek back did not return to zero'); + Exit; + end; + + SecondCount := AStream.Read(SecondBytes[0], Requested); + AResult.Stream.SecondReadCount.Value := SecondCount; + AResult.Stream.SecondReadCount.HasValue := True; + AResult.Stream.PositionAfterSecondRead.Value := AStream.Position; + AResult.Stream.PositionAfterSecondRead.HasValue := True; + ExpectedPosition := SecondCount; + if (SecondCount <> Requested) or (AStream.Position <> ExpectedPosition) then + begin + FailStage(AResult, dsiSeekReadConsistency, 'Second read did not advance as required'); + Exit; + end; + + AResult.Stream.RepeatEqual.Value := True; + AResult.Stream.RepeatEqual.HasValue := True; + for I := 0 to Requested - 1 do + if FirstBytes[I] <> SecondBytes[I] then + begin + AResult.Stream.RepeatEqual.Value := False; + Break; + end; + if not AResult.Stream.RepeatEqual.Value then + begin + FailStage(AResult, dsiSeekReadConsistency, 'Repeated reads differ'); + Exit; + end; + + except + on E: Exception do + FailException(AResult, dsiSeekReadConsistency, E); + end; + finally + try + RestoredPosition := AStream.Seek(AResult.Stream.PositionAfterLoad.Value, soBeginning); + if ((RestoredPosition <> AResult.Stream.PositionAfterLoad.Value) or + (AStream.Position <> AResult.Stream.PositionAfterLoad.Value)) and + (AResult.Status <> dsFail) then + begin + FailStage(AResult, dsiSeekReadConsistency, 'Could not restore stream position'); + Result := False; + end; + except + on E: Exception do + if AResult.Status <> dsFail then + begin + FailException(AResult, dsiSeekReadConsistency, E); + Result := False; + end; + end; + end; + if AResult.Status <> dsFail then + begin + AResult.Stages[dsiSeekReadConsistency] := dsPass; + AResult.Status := dsPass; + Result := True; + end; +end; + +procedure RunFileIODiagnostic; +var + ResultData: TFileIODiagnosticResult; + MapUrl: string; + Stream: TKMemoryStreamBinary; +begin + InitializeResult(ResultData); + Stream := nil; + MapUrl := SelectedMapUrl; + try + if RunResourceExists(MapUrl, ResultData) and + RunResourceOpen(MapUrl, ResultData) and + RunCallerStreamLoad(MapUrl, Stream, ResultData) and + RunStreamState(Stream, ResultData) then + RunSeekReadConsistency(Stream, ResultData); + finally + try + Stream.Free; + except + on E: Exception do + if ResultData.Status <> dsFail then + FailException(ResultData, dsiSeekReadConsistency, E); + end; + end; + ReplaceFileIODiagnosticResult(ResultData); +end; + +end. diff --git a/code/GameDiagnosticsReport.pas b/code/GameDiagnosticsReport.pas new file mode 100644 index 0000000..5804afc --- /dev/null +++ b/code/GameDiagnosticsReport.pas @@ -0,0 +1,247 @@ +unit GameDiagnosticsReport; + +{$mode objfpc}{$H+}{$codepage utf8} + +interface + +type + TDiagnosticStatus = (dsNotRun, dsPass, dsFail); + + TDiagnosticStageId = ( + dsiResourceExists, + dsiResourceOpen, + dsiCallerStreamLoad, + dsiStreamState, + dsiSeekReadConsistency + ); + + TOptionalString = record + HasValue: Boolean; + Value: string; + end; + + TOptionalInt64 = record + HasValue: Boolean; + Value: Int64; + end; + + TOptionalBoolean = record + HasValue: Boolean; + Value: Boolean; + end; + + TOptionalDiagnosticStageId = record + HasValue: Boolean; + Value: TDiagnosticStageId; + end; + + TDiagnosticError = record + Present: Boolean; + ClassName: TOptionalString; + MessageText: TOptionalString; + end; + + TFileIODiagnosticStreamResult = record + Size: TOptionalInt64; + PositionAfterLoad: TOptionalInt64; + ReadOffset: TOptionalInt64; + RequestedReadCount: TOptionalInt64; + FirstReadCount: TOptionalInt64; + PositionAfterFirstRead: TOptionalInt64; + SeekBackPosition: TOptionalInt64; + SecondReadCount: TOptionalInt64; + PositionAfterSecondRead: TOptionalInt64; + RepeatEqual: TOptionalBoolean; + end; + + TFileIODiagnosticResult = record + Status: TDiagnosticStatus; + FailureStage: TOptionalDiagnosticStageId; + Error: TDiagnosticError; + Stages: array[TDiagnosticStageId] of TDiagnosticStatus; + Stream: TFileIODiagnosticStreamResult; + end; + + TDiagnosticApplicationMetadata = record + Name: string; + PackageName: string; + Version: string; + VersionCode: Int64; + BuildId: TOptionalString; + end; + + TDiagnosticRuntimeMetadata = record + Platform: string; + OsVersion: TOptionalString; + DeviceModel: TOptionalString; + CpuArch: TOptionalString; + end; + + TDiagnosticSelectedMapMetadata = record + RelativePath: string; + Url: string; + end; + + TDiagnosticReportState = record + ApplicationInfo: TDiagnosticApplicationMetadata; + RuntimeInfo: TDiagnosticRuntimeMetadata; + SelectedMap: TDiagnosticSelectedMapMetadata; + OverallStatus: TDiagnosticStatus; + FileIO: TFileIODiagnosticResult; + end; + +function CurrentDiagnosticReport: TDiagnosticReportState; +procedure ReplaceFileIODiagnosticResult(const AResult: TFileIODiagnosticResult); +function DiagnosticStatusToken(const AStatus: TDiagnosticStatus): string; +function DiagnosticStageIdToken(const AStage: TDiagnosticStageId): string; +function DiagnosticReportJsonSnapshot: string; + +implementation + +uses + fpjson, GameSelectedMap; + +var + CurrentFileIO: TFileIODiagnosticResult; + +function DiagnosticStatusToken(const AStatus: TDiagnosticStatus): string; +begin + case AStatus of + dsNotRun: Result := 'NOT_RUN'; + dsPass: Result := 'PASS'; + dsFail: Result := 'FAIL'; + end; +end; + +function DiagnosticStageIdToken(const AStage: TDiagnosticStageId): string; +begin + case AStage of + dsiResourceExists: Result := 'resource_exists'; + dsiResourceOpen: Result := 'resource_open'; + dsiCallerStreamLoad: Result := 'caller_stream_load'; + dsiStreamState: Result := 'stream_state'; + dsiSeekReadConsistency: Result := 'seek_read_consistency'; + end; +end; + +function CurrentDiagnosticReport: TDiagnosticReportState; +begin + Result.ApplicationInfo.Name := 'kam_mobile'; + Result.ApplicationInfo.PackageName := 'org.kammobile.kamremake'; + Result.ApplicationInfo.Version := '0.4.0'; + Result.ApplicationInfo.VersionCode := 30; + Result.ApplicationInfo.BuildId.HasValue := False; + Result.RuntimeInfo.Platform := 'android'; + Result.RuntimeInfo.OsVersion.HasValue := False; + Result.RuntimeInfo.DeviceModel.HasValue := False; + Result.RuntimeInfo.CpuArch.HasValue := False; + Result.SelectedMap.RelativePath := SelectedMapRelativePath; + Result.SelectedMap.Url := SelectedMapUrl; + Result.FileIO := CurrentFileIO; + Result.OverallStatus := Result.FileIO.Status; +end; + +procedure ReplaceFileIODiagnosticResult(const AResult: TFileIODiagnosticResult); +begin + CurrentFileIO := AResult; +end; + +function OptionalStringJson(const AValue: TOptionalString): TJSONData; +begin + if AValue.HasValue then + Result := TJSONString.Create(AValue.Value) + else + Result := TJSONNull.Create; +end; + +function OptionalInt64Json(const AValue: TOptionalInt64): TJSONData; +begin + if AValue.HasValue then + Result := TJSONIntegerNumber.Create(AValue.Value) + else + Result := TJSONNull.Create; +end; + +function OptionalBooleanJson(const AValue: TOptionalBoolean): TJSONData; +begin + if AValue.HasValue then + Result := TJSONBoolean.Create(AValue.Value) + else + Result := TJSONNull.Create; +end; + +function DiagnosticReportJsonSnapshot: string; +var + State: TDiagnosticReportState; + Root, ObjectValue, Action, Stage, Stream: TJSONObject; + Actions, Stages: TJSONArray; + StageId: TDiagnosticStageId; +begin + State := CurrentDiagnosticReport; + Root := TJSONObject.Create; + try + Root.Add('schema', 'kam-mobile-diagnostics/1'); + ObjectValue := TJSONObject.Create; + ObjectValue.Add('name', State.ApplicationInfo.Name); + ObjectValue.Add('package', State.ApplicationInfo.PackageName); + ObjectValue.Add('version', State.ApplicationInfo.Version); + ObjectValue.Add('version_code', State.ApplicationInfo.VersionCode); + ObjectValue.Add('build_id', OptionalStringJson(State.ApplicationInfo.BuildId)); + Root.Add('application', ObjectValue); + ObjectValue := TJSONObject.Create; + ObjectValue.Add('platform', State.RuntimeInfo.Platform); + ObjectValue.Add('os_version', OptionalStringJson(State.RuntimeInfo.OsVersion)); + ObjectValue.Add('device_model', OptionalStringJson(State.RuntimeInfo.DeviceModel)); + ObjectValue.Add('cpu_arch', OptionalStringJson(State.RuntimeInfo.CpuArch)); + Root.Add('runtime', ObjectValue); + ObjectValue := TJSONObject.Create; + ObjectValue.Add('relative_path', State.SelectedMap.RelativePath); + ObjectValue.Add('url', State.SelectedMap.Url); + Root.Add('selected_map', ObjectValue); + Root.Add('overall_status', DiagnosticStatusToken(State.OverallStatus)); + Actions := TJSONArray.Create; + Action := TJSONObject.Create; + Action.Add('id', 'file_io'); + Action.Add('status', DiagnosticStatusToken(State.FileIO.Status)); + if State.FileIO.FailureStage.HasValue then + Action.Add('failure_stage', DiagnosticStageIdToken(State.FileIO.FailureStage.Value)) + else + Action.Add('failure_stage', TJSONNull.Create); + if State.FileIO.Error.Present then + begin + ObjectValue := TJSONObject.Create; + ObjectValue.Add('class', OptionalStringJson(State.FileIO.Error.ClassName)); + ObjectValue.Add('message', OptionalStringJson(State.FileIO.Error.MessageText)); + Action.Add('error', ObjectValue); + end else + Action.Add('error', TJSONNull.Create); + Stages := TJSONArray.Create; + for StageId := Low(TDiagnosticStageId) to High(TDiagnosticStageId) do + begin + Stage := TJSONObject.Create; + Stage.Add('id', DiagnosticStageIdToken(StageId)); + Stage.Add('status', DiagnosticStatusToken(State.FileIO.Stages[StageId])); + Stages.Add(Stage); + end; + Action.Add('stages', Stages); + Stream := TJSONObject.Create; + Stream.Add('size', OptionalInt64Json(State.FileIO.Stream.Size)); + Stream.Add('position_after_load', OptionalInt64Json(State.FileIO.Stream.PositionAfterLoad)); + Stream.Add('read_offset', OptionalInt64Json(State.FileIO.Stream.ReadOffset)); + Stream.Add('requested_read_count', OptionalInt64Json(State.FileIO.Stream.RequestedReadCount)); + Stream.Add('first_read_count', OptionalInt64Json(State.FileIO.Stream.FirstReadCount)); + Stream.Add('position_after_first_read', OptionalInt64Json(State.FileIO.Stream.PositionAfterFirstRead)); + Stream.Add('seek_back_position', OptionalInt64Json(State.FileIO.Stream.SeekBackPosition)); + Stream.Add('second_read_count', OptionalInt64Json(State.FileIO.Stream.SecondReadCount)); + Stream.Add('position_after_second_read', OptionalInt64Json(State.FileIO.Stream.PositionAfterSecondRead)); + Stream.Add('repeat_equal', OptionalBooleanJson(State.FileIO.Stream.RepeatEqual)); + Action.Add('stream', Stream); + Actions.Add(Action); + Root.Add('actions', Actions); + Result := Root.AsJSON; + finally + Root.Free; + end; +end; + +end. diff --git a/code/GameDiagnosticsView.pas b/code/GameDiagnosticsView.pas new file mode 100644 index 0000000..fa1d3c7 --- /dev/null +++ b/code/GameDiagnosticsView.pas @@ -0,0 +1,182 @@ +unit GameDiagnosticsView; + +{$mode objfpc}{$H+}{$codepage utf8} + +interface + +uses + Classes, + CastleUIControls, CastleControls, GameDiagnosticsExport; + +type + TDiagnosticsView = class(TCastleView) + private + FScroll: TCastleScrollView; + FContent: TCastleVerticalGroup; + FFileIOButton: TCastleButton; + FStatusLabel, FDetailsLabel, FExportFeedbackLabel: TCastleLabel; + FExportButton: TCastleButton; + FFileIOInProgress, FExportInProgress: Boolean; + procedure RefreshReport; + procedure UpdateWrapWidth; + procedure FileIOClick(Sender: TObject); + procedure ExportClick(Sender: TObject); + procedure ExportComplete(const AOutcome: TDiagnosticExportOutcome); + public + constructor Create(AOwner: TComponent); override; + procedure Start; override; + procedure Resize; override; + end; + +implementation + +uses + SysUtils, GameDiagnosticsFileIO, GameDiagnosticsReport; + +const + LayoutMargin = 16; + UnavailableValue = '—'; + +function OptionalStringText(const AValue: TOptionalString): string; +begin + if AValue.HasValue then Result := AValue.Value else Result := UnavailableValue; +end; + +function OptionalInt64Text(const AValue: TOptionalInt64): string; +begin + if AValue.HasValue then Result := IntToStr(AValue.Value) else Result := UnavailableValue; +end; + +function OptionalBooleanText(const AValue: TOptionalBoolean): string; +begin + if AValue.HasValue then Result := BoolToStr(AValue.Value, True) else Result := UnavailableValue; +end; + +constructor TDiagnosticsView.Create(AOwner: TComponent); +begin + inherited; + FScroll := TCastleScrollView.Create(Self); + FScroll.FullSize := True; + FScroll.EnableDragging := True; + Controls.InsertFront(FScroll); + + FContent := TCastleVerticalGroup.Create(Self); + FContent.Padding := LayoutMargin; + FContent.Spacing := 8; + FScroll.ScrollArea.Controls.InsertFront(FContent); + + FStatusLabel := TCastleLabel.Create(Self); + FDetailsLabel := TCastleLabel.Create(Self); + FExportFeedbackLabel := TCastleLabel.Create(Self); + FFileIOButton := TCastleButton.Create(Self); + FExportButton := TCastleButton.Create(Self); + + FContent.Controls.InsertFront(FExportFeedbackLabel); + FExportButton.Caption := 'Export Report'; + FExportButton.OnClick := @ExportClick; + FContent.Controls.InsertFront(FExportButton); + FContent.Controls.InsertFront(FDetailsLabel); + FContent.Controls.InsertFront(FStatusLabel); + FFileIOButton.Caption := 'Test File I/O'; + FFileIOButton.OnClick := @FileIOClick; + FContent.Controls.InsertFront(FFileIOButton); + with TCastleLabel.Create(Self) do begin Caption := 'Tests / Diagnostics'; FContent.Controls.InsertFront(Self); end; +end; + +procedure TDiagnosticsView.UpdateWrapWidth; +var + WrapWidth: Single; +begin + WrapWidth := Width - 2 * LayoutMargin; + if WrapWidth < 1 then WrapWidth := 1; + FDetailsLabel.MaxWidth := WrapWidth; + FExportFeedbackLabel.MaxWidth := WrapWidth; +end; + +procedure TDiagnosticsView.RefreshReport; +var + State: TDiagnosticReportState; + Stage: TDiagnosticStageId; + Details: string; +begin + State := CurrentDiagnosticReport; + FStatusLabel.Caption := 'File I/O: ' + DiagnosticStatusToken(State.FileIO.Status); + Details := 'selected map relative_path: ' + State.SelectedMap.RelativePath + LineEnding + + 'selected map url: ' + State.SelectedMap.Url; + for Stage := Low(TDiagnosticStageId) to High(TDiagnosticStageId) do + Details := Details + LineEnding + DiagnosticStageIdToken(Stage) + ': ' + + DiagnosticStatusToken(State.FileIO.Stages[Stage]); + if State.FileIO.FailureStage.HasValue then + Details := Details + LineEnding + 'failure_stage: ' + + DiagnosticStageIdToken(State.FileIO.FailureStage.Value); + if State.FileIO.Error.Present then + begin + Details := Details + LineEnding + 'error class: ' + OptionalStringText(State.FileIO.Error.ClassName); + Details := Details + LineEnding + 'error message: ' + OptionalStringText(State.FileIO.Error.MessageText); + end; + with State.FileIO.Stream do + begin + if Size.HasValue then Details := Details + LineEnding + 'size: ' + OptionalInt64Text(Size); + if PositionAfterLoad.HasValue then Details := Details + LineEnding + 'position_after_load: ' + OptionalInt64Text(PositionAfterLoad); + if ReadOffset.HasValue then Details := Details + LineEnding + 'read_offset: ' + OptionalInt64Text(ReadOffset); + if RequestedReadCount.HasValue then Details := Details + LineEnding + 'requested_read_count: ' + OptionalInt64Text(RequestedReadCount); + if FirstReadCount.HasValue then Details := Details + LineEnding + 'first_read_count: ' + OptionalInt64Text(FirstReadCount); + if PositionAfterFirstRead.HasValue then Details := Details + LineEnding + 'position_after_first_read: ' + OptionalInt64Text(PositionAfterFirstRead); + if SeekBackPosition.HasValue then Details := Details + LineEnding + 'seek_back_position: ' + OptionalInt64Text(SeekBackPosition); + if SecondReadCount.HasValue then Details := Details + LineEnding + 'second_read_count: ' + OptionalInt64Text(SecondReadCount); + if PositionAfterSecondRead.HasValue then Details := Details + LineEnding + 'position_after_second_read: ' + OptionalInt64Text(PositionAfterSecondRead); + if RepeatEqual.HasValue then Details := Details + LineEnding + 'repeat_equal: ' + OptionalBooleanText(RepeatEqual); + end; + FDetailsLabel.Caption := Details; +end; + +procedure TDiagnosticsView.Start; +begin + inherited; + RefreshReport; +end; + +procedure TDiagnosticsView.Resize; +begin + inherited; + UpdateWrapWidth; +end; + +procedure TDiagnosticsView.FileIOClick(Sender: TObject); +begin + if FFileIOInProgress then Exit; + FFileIOInProgress := True; + FFileIOButton.Enabled := False; + try + RunFileIODiagnostic; + RefreshReport; + finally + FFileIOButton.Enabled := True; + FFileIOInProgress := False; + end; +end; + +procedure TDiagnosticsView.ExportClick(Sender: TObject); +begin + if FExportInProgress then Exit; + FExportInProgress := True; + FExportButton.Enabled := False; + FExportFeedbackLabel.Caption := 'Exporting report…'; + ExportDiagnosticReport(DiagnosticReportJsonSnapshot, @ExportComplete); +end; + +procedure TDiagnosticsView.ExportComplete(const AOutcome: TDiagnosticExportOutcome); +begin + FExportInProgress := False; + FExportButton.Enabled := True; + case AOutcome.Kind of + deokSuccess: FExportFeedbackLabel.Caption := 'Report exported.'; + deokCancel: FExportFeedbackLabel.Caption := 'Export canceled.'; + deokError: if AOutcome.ErrorMessage <> '' then + FExportFeedbackLabel.Caption := 'Export error: ' + AOutcome.ErrorMessage + else + FExportFeedbackLabel.Caption := 'Export error.'; + end; +end; + +end. diff --git a/code/GameInitialize.pas b/code/GameInitialize.pas index 8da6fc5..3ebf9d2 100755 --- a/code/GameInitialize.pas +++ b/code/GameInitialize.pas @@ -3,10 +3,14 @@ unit GameInitialize; {$ifndef ANDROID}{$fatal Android-only KaM Remake Mobile application; there is no desktop target}{$endif} interface implementation -uses CastleWindow; -var Window: TCastleWindow; +uses CastleWindow, GameDiagnosticsView; +var + Window: TCastleWindow; + DiagnosticsView: TDiagnosticsView; procedure Initialize; begin + DiagnosticsView := TDiagnosticsView.Create(Application); + Window.Container.View := DiagnosticsView; end; initialization Application.OnInitialize := @Initialize; diff --git a/code/GameSelectedMap.pas b/code/GameSelectedMap.pas new file mode 100644 index 0000000..e53160b --- /dev/null +++ b/code/GameSelectedMap.pas @@ -0,0 +1,22 @@ +unit GameSelectedMap; + +{$mode objfpc}{$H+}{$codepage utf8} + +interface + +const + SelectedMapRelativePath = 'Maps/CatchTheSnake/CatchTheSnake.map'; + +function SelectedMapUrl: string; + +implementation + +uses + CastleUriUtils; + +function SelectedMapUrl: string; +begin + Result := 'castle-data:/game/' + UrlEncode(SelectedMapRelativePath); +end; + +end. diff --git a/code/resource/KaMResourceInput.pas b/code/resource/KaMResourceInput.pas new file mode 100644 index 0000000..6cbafec --- /dev/null +++ b/code/resource/KaMResourceInput.pas @@ -0,0 +1,45 @@ +unit KaMResourceInput; + +interface + +uses + Classes; + +function KaMResourceExists(const aReference: string): Boolean; +function KaMOpenResourceStream(const aReference: string): TStream; + +implementation + +uses + CastleUriUtils, CastleDownload; + +function ResourceProtocol(const aReference: string): string; +begin + if aReference = '' then + raise EDownloadError.Create('KaMResourceInput: empty resource reference'); + + Result := UriProtocol(aReference); + if (Result <> '') and (Result <> 'file') and (Result <> 'castle-data') then + raise EDownloadError.Create('KaMResourceInput: unsupported resource protocol: ' + Result); +end; + +function KaMResourceExists(const aReference: string): Boolean; +begin + ResourceProtocol(aReference); + case UriExists(aReference) of + ueFile: Result := True; + ueNotExists, ueDirectory: Result := False; + ueUnknown: + raise EDownloadError.Create('KaMResourceInput: resource existence is unknown: ' + aReference); + end; +end; + +function KaMOpenResourceStream(const aReference: string): TStream; +begin + if ResourceProtocol(aReference) = '' then + Result := TFileStream.Create(aReference, fmOpenRead) + else + Result := Download(aReference, [soForceMemoryStream]); +end; + +end. diff --git a/config/extra-paths.json b/config/extra-paths.json index ba891be..e73da86 100755 --- a/config/extra-paths.json +++ b/config/extra-paths.json @@ -1,6 +1,11 @@ { "schema": "kam-source-resolution/1", - "adaptations": [], - "source_paths": [], + "adaptations": [ + "src/utils/io/KM_FileIO.pas", + "src/common/KM_CommonClasses.pas" + ], + "source_paths": [ + "code/resource" + ], "library_paths": [] } diff --git a/config/runtime-resources.json b/config/runtime-resources.json index 67bd0c9..120c15b 100644 --- a/config/runtime-resources.json +++ b/config/runtime-resources.json @@ -1,4 +1,6 @@ { "schema": "kam-runtime-resources/1", - "entries": [] + "entries": [ + {"kind": "file", "path": "Maps/CatchTheSnake/CatchTheSnake.map"} + ] } diff --git a/port-source/kam_remake/src/common/KM_CommonClasses.pas b/port-source/kam_remake/src/common/KM_CommonClasses.pas new file mode 100644 index 0000000..2e493bc --- /dev/null +++ b/port-source/kam_remake/src/common/KM_CommonClasses.pas @@ -0,0 +1,1909 @@ +unit KM_CommonClasses; +{$I KaM_Remake.inc} +interface +uses + Classes, SysUtils, KM_Points, KM_CommonTypes; + + // Delphi 11.0 Alexandria had a bug with Stream.CopyFrom for TCompressionStream + // Bug occurs only during debugging, but its quite annoying + // It was fixed in Delphi 11.1 and up + // RTLVersion111 define is used to determine Delphi 11.1. Delphi 11.1, 11.2, 11.3 all include this define, only Delphi 11.0 does not + // + // https://quality.embarcadero.com/projects/RSP/issues/RSP-35516?filter=allopenissues + // https://forum.fast-report.com/en/discussion/17186/tfrxpdfexport-ezcompressionerror-with-message-invalid-zstream-operation-in-delphi-11-2021-3 + // https://stackoverflow.com/questions/70242669/error-invalid-zstream-operation-delphi-11-0 + {$IFDEF VER350} + {$IF NOT RTLVersion111} + {$IFDEF DEBUG} + {$DEFINE NO_COMPRESSION} + {$ENDIF} + {$ENDIF} + {$ENDIF} + +type + TKMSaveStreamFormat = (ssfBinary, ssfText); + + TKMemoryStream = class(TMemoryStream) + private + fShouldBeCompressed: Boolean; // Flag to show if current stream should be compressed (either while save or load operations) + + procedure AppendNotCompressedStream(aStream: TKMemoryStream; const aMarker: string); + procedure CompressAndAppendStream(aStream: TKMemoryStream; const aMarker: string); + public + constructor Create(aShouldBeCompressed: Boolean = False); + procedure LoadFromFile(const aFileName: string); reintroduce; + + // Assert savegame sections + procedure CheckMarker(const aTitle: string); virtual; abstract; + procedure PlaceMarker(const aTitle: string); virtual; abstract; + + procedure ReadANSI(out aValue: string); virtual; abstract; + procedure WriteANSI(const aValue: string); virtual; abstract; + + //Ansistrings saved by PascalScript into savegame + procedure ReadHugeString(out Value: AnsiString); overload; + procedure WriteHugeString(const Value: AnsiString); overload; + + procedure ReadHugeStringW(out Value: UnicodeString); overload; + procedure WriteHugeStringW(const Value: UnicodeString); overload; + +// {$IFDEF DESKTOP} + //Legacy format for campaigns info, maxlength 65k ansichars + procedure ReadA(out Value: AnsiString); reintroduce; overload; virtual; abstract; + procedure WriteA(const Value: AnsiString); reintroduce; overload; virtual; abstract; +// {$ENDIF} +// {$IFDEF TABLET} +// //Legacy format for campaigns info, maxlength 65k ansichars +// procedure ReadA(out Value: string); reintroduce; overload; virtual; abstract; +// procedure WriteA(const Value: string); reintroduce; overload; virtual; abstract; +// {$ENDIF} + + // Unicode strings + procedure ReadW(out Value: UnicodeString); reintroduce; overload; virtual; abstract; + procedure WriteW(const Value: UnicodeString); reintroduce; overload; virtual; abstract; + + function Write(const Buffer; Count: Longint): Longint; overload; override; + + procedure Write(const Value: TKMDirection ); reintroduce; overload; virtual; abstract; + procedure Write(const Value: TKMPoint ); reintroduce; overload; virtual; abstract; + procedure Write(const Value: TKMPointW ); reintroduce; overload; virtual; abstract; + procedure Write(const Value: TKMPointF ); reintroduce; overload; virtual; abstract; + procedure Write(const Value: TKMPointDir ); reintroduce; overload; virtual; abstract; + procedure Write(const Value: TKMRangeInt ); reintroduce; overload; virtual; abstract; + procedure Write(const Value: TKMRangeSingle); reintroduce; overload; virtual; abstract; + procedure Write(const Value: TKMRect ); reintroduce; overload; virtual; abstract; + procedure Write(const Value: Single ); reintroduce; overload; virtual; abstract; + procedure Write(const Value: Extended ); reintroduce; overload; virtual; abstract; + procedure Write(const Value: Integer ); reintroduce; overload; virtual; abstract; + procedure Write(const Value: Cardinal ); reintroduce; overload; virtual; abstract; + procedure Write(const Value: Int64 ); reintroduce; overload; virtual; abstract; + procedure Write(const Value: Byte ); reintroduce; overload; virtual; abstract; + procedure Write(const Value: Boolean ); reintroduce; overload; virtual; abstract; + procedure Write(const Value: Word ); reintroduce; overload; virtual; abstract; + procedure Write(const Value: ShortInt ); reintroduce; overload; virtual; abstract; + procedure Write(const Value: SmallInt ); reintroduce; overload; virtual; abstract; + procedure Write(const Value: TDateTime ); reintroduce; overload; virtual; abstract; + + procedure Read(out Value: TKMDirection ); reintroduce; overload; virtual; abstract; + procedure Read(out Value: TKMPoint ); reintroduce; overload; virtual; abstract; + procedure Read(out Value: TKMPointW ); reintroduce; overload; virtual; abstract; + procedure Read(out Value: TKMPointF ); reintroduce; overload; virtual; abstract; + procedure Read(out Value: TKMPointDir ); reintroduce; overload; virtual; abstract; + procedure Read(out Value: TKMRangeInt ); reintroduce; overload; virtual; abstract; + procedure Read(out Value: TKMRangeSingle); reintroduce; overload; virtual; abstract; + procedure Read(out Value: TKMRect ); reintroduce; overload; virtual; abstract; + procedure Read(out Value: Single ); reintroduce; overload; virtual; abstract; + procedure Read(out Value: Extended ); reintroduce; overload; virtual; abstract; + procedure Read(out Value: Integer ); reintroduce; overload; virtual; abstract; + procedure Read(out Value: Cardinal ); reintroduce; overload; virtual; abstract; + procedure Read(out Value: Int64 ); reintroduce; overload; virtual; abstract; + procedure Read(out Value: Byte ); reintroduce; overload; virtual; abstract; + procedure Read(out Value: Boolean ); reintroduce; overload; virtual; abstract; + procedure Read(out Value: Word ); reintroduce; overload; virtual; abstract; + procedure Read(out Value: ShortInt ); reintroduce; overload; virtual; abstract; + procedure Read(out Value: SmallInt ); reintroduce; overload; virtual; abstract; + procedure Read(out Value: TDateTime ); reintroduce; overload; virtual; abstract; + + procedure ReadBytes(out Value: TBytes); + procedure WriteBytes(const Value: TBytes); + + //ZLib's decompression streams don't work with the normal TStreams.CopyFrom since + //it uses ReadBuffer. This procedure will work when Source is a TDecompressionStream + procedure CopyFromDecompression(Source: TStream); + + procedure SaveToFileCompressed(const aFileName: string; const aMarker: string); + procedure LoadFromFileCompressed(const aFileName: string; const aMarker: string); + + procedure SaveToStreamCompressed(aStream: TKMemoryStream; const aMarker: string = ''); + procedure LoadFromStreamCompressed(aStream: TKMemoryStream; const aMarker: string = ''); + + procedure AppendStream(aStream: TKMemoryStream; const aMarker: string); + procedure TrimToPosition; + + procedure LoadToStream(aStream: TKMemoryStream; const aMarker: string); + procedure LoadToStreams(aStream1, aStream2: TKMemoryStream; const aMarker1, aMarker2: string); + + function ToBase64: String; + procedure LoadFromBase64(aBase64: string); + + function ToBase64Compressed: String; + procedure LoadFromBase64Compressed(aBase64: string); + end; + + // Extended with custom Read/Write commands which accept various types without asking for their length + TKMemoryStreamBinary = class(TKMemoryStream) + public + // Assert savegame sections + procedure CheckMarker(const aTitle: string); override; + procedure PlaceMarker(const aTitle: string); override; + + procedure ReadANSI(out aValue: string); override; + procedure WriteANSI(const aValue: string); override; + +// {$IFDEF DESKTOP} + //Legacy format for campaigns info, maxlength 65k ansichars + procedure ReadA(out Value: AnsiString); override; + procedure WriteA(const Value: AnsiString); override; +// {$ENDIF} +// {$IFDEF TABLET} +// //Legacy format for campaigns info, maxlength 65k ansichars +// procedure ReadA(out Value: string); override; +// procedure WriteA(const Value: string); override; +// {$ENDIF} + + // Unicode strings + procedure ReadW(out Value: UnicodeString); override; + procedure WriteW(const Value: UnicodeString); override; + + function Write(const Buffer; Count: Longint): Longint; override; + + procedure Write(const Value: TKMDirection ); override; + procedure Write(const Value: TKMPoint ); override; + procedure Write(const Value: TKMPointW ); override; + procedure Write(const Value: TKMPointF ); override; + procedure Write(const Value: TKMPointDir ); override; + procedure Write(const Value: TKMRangeInt ); override; + procedure Write(const Value: TKMRangeSingle); override; + procedure Write(const Value: TKMRect ); override; + procedure Write(const Value: Single ); override; + procedure Write(const Value: Extended ); override; + procedure Write(const Value: Integer ); override; + procedure Write(const Value: Cardinal ); override; + procedure Write(const Value: Int64 ); override; + procedure Write(const Value: Byte ); override; + procedure Write(const Value: Boolean ); override; + procedure Write(const Value: Word ); override; + procedure Write(const Value: ShortInt ); override; + procedure Write(const Value: SmallInt ); override; + procedure Write(const Value: TDateTime ); override; + + procedure Read(out Value: TKMDirection ); override; + procedure Read(out Value: TKMPoint ); override; + procedure Read(out Value: TKMPointW ); override; + procedure Read(out Value: TKMPointF ); override; + procedure Read(out Value: TKMPointDir ); override; + procedure Read(out Value: TKMRangeInt ); override; + procedure Read(out Value: TKMRangeSingle); override; + procedure Read(out Value: TKMRect ); override; + procedure Read(out Value: Single ); override; + procedure Read(out Value: Extended ); override; + procedure Read(out Value: Integer ); override; + procedure Read(out Value: Cardinal ); override; + procedure Read(out Value: Int64 ); override; + procedure Read(out Value: Byte ); override; + procedure Read(out Value: Boolean ); override; + procedure Read(out Value: Word ); override; + procedure Read(out Value: ShortInt ); override; + procedure Read(out Value: SmallInt ); override; + procedure Read(out Value: TDateTime ); override; + end; + + // Text writer + TKMemoryStreamText = class(TKMemoryStream) + private + fLastSection: string; + procedure WriteText(const aString: string); + public + procedure PlaceMarker(const aTitle: string); override; + + procedure WriteANSI(const aValue: string); override; + procedure WriteA(const Value: AnsiString); override; + procedure WriteW(const Value: UnicodeString); override; + + function Write(const Buffer; Count: Longint): Longint; override; + + procedure Write(const Value: TKMDirection ); override; + procedure Write(const Value: TKMPoint ); override; + procedure Write(const Value: TKMPointW ); override; + procedure Write(const Value: TKMPointF ); override; + procedure Write(const Value: TKMPointDir ); override; + procedure Write(const Value: TKMRangeInt ); override; + procedure Write(const Value: TKMRangeSingle); override; + procedure Write(const Value: TKMRect ); override; + procedure Write(const Value: Single ); override; + procedure Write(const Value: Extended ); override; + procedure Write(const Value: Integer ); override; + procedure Write(const Value: Cardinal ); override; + procedure Write(const Value: Int64 ); override; + procedure Write(const Value: Byte ); override; + procedure Write(const Value: Boolean ); override; + procedure Write(const Value: Word ); override; + procedure Write(const Value: ShortInt ); override; + procedure Write(const Value: SmallInt ); override; + procedure Write(const Value: TDateTime ); override; + + //Not implemented methods yet + procedure CheckMarker(const aTitle: string); override; + + procedure ReadANSI(out aValue: string); override; + procedure ReadA(out Value: AnsiString); override; + procedure ReadW(out Value: UnicodeString); override; + + procedure Read(out Value: TKMDirection ); override; + procedure Read(out Value: TKMPoint ); override; + procedure Read(out Value: TKMPointW ); override; + procedure Read(out Value: TKMPointF ); override; + procedure Read(out Value: TKMPointDir ); override; + procedure Read(out Value: TKMRangeInt ); override; + procedure Read(out Value: TKMRangeSingle); override; + procedure Read(out Value: TKMRect ); override; + procedure Read(out Value: Single ); override; + procedure Read(out Value: Extended ); override; + procedure Read(out Value: Integer ); override; + procedure Read(out Value: Cardinal ); override; + procedure Read(out Value: Int64 ); override; + procedure Read(out Value: Byte ); override; + procedure Read(out Value: Boolean ); override; + procedure Read(out Value: Word ); override; + procedure Read(out Value: ShortInt ); override; + procedure Read(out Value: SmallInt ); override; + procedure Read(out Value: TDateTime ); override; + end; + + + TStreamEvent = procedure (aData: TKMemoryStream) of object; + TStreamIntEvent = procedure (aData: TKMemoryStream; aSenderIndex: ShortInt) of object; + + + //todo -cPractical: Replace usages with TList + //TXStringList using integer values, instead of its String represantation, when sorted + TXStringList = class(TStringList) + protected + function CompareStrings(const S1, S2: string): Integer; override; + end; + + + //TKMList owns items and frees them when they are deleted from the list + TKMList = class(TList) + protected + //This one function is enough to free all deleted/cleared/rewritten objects + procedure Notify(Ptr: Pointer; Action: TListNotification); override; + end; + + TKMPointList = class + private + fCount: Integer; + fItems: array of TKMPoint; //0..Count-1 + function GetPoint(aIndex: Integer): TKMPoint; inline; + procedure SetPoint(aIndex: Integer; const aValue: TKMPoint); inline; //1..Count + function GetLast: TKMPoint; + function GetLen: Single; + public + constructor Create; + + property Count: Integer read fCount write fCount; + property Items[aIndex: Integer]: TKMPoint read GetPoint write SetPoint; default; + property Last: TKMPoint read GetLast; + function IsEmpty: Boolean; + property Len: Single read GetLen; + + procedure Clear; virtual; + procedure Copy(aSrc: TKMPointList); + procedure Add(const aLoc: TKMPoint); overload; virtual; + procedure Add(X, Y: Integer); overload; + procedure AddList(aList: TKMPointList); + procedure AddUnique(const aLoc: TKMPoint); + procedure AddListUnique(aList: TKMPointList); + function Remove(const aLoc: TKMPoint): Integer; virtual; + procedure Delete(aIndex: Integer); virtual; + procedure Insert(ID: Integer; const aLoc: TKMPoint); + function GetRandom(out Point: TKMPoint): Boolean; + function GetClosest(const aLoc: TKMPoint; out Point: TKMPoint): Boolean; + function Contains(const aLoc: TKMPoint): Boolean; + function IndexOf(const aLoc: TKMPoint): Integer; + procedure Inverse; + procedure SparseToDense; + function GetBounds(out Bounds: TKMRect): Boolean; + procedure SaveToStream(SaveStream: TKMemoryStream); virtual; + procedure LoadFromStream(LoadStream: TKMemoryStream); virtual; + end; + + TKMPointListArray = array of TKMPointList; + + TKMWeightedPointList = class(TKMPointList) + fWeight: array of Single; + public + procedure Add(const aLoc: TKMPoint; aWeight: Single); reintroduce; + function GetWeightedRandom(out Point: TKMPoint): Boolean; + end; + + TKMPointCenteredList = class(TKMWeightedPointList) + private + fCenter: TKMPoint; + public + constructor Create(const aCenter: TKMPoint); + procedure Add(const aLoc: TKMPoint); reintroduce; + end; + + TKMPointTagList = class(TKMPointList) + public + Tag, Tag2: array of Cardinal; //0..Count-1 + procedure Clear; override; + procedure Add(const aLoc: TKMPoint; aTag: Cardinal; aTag2: Cardinal = 0); reintroduce; virtual; + function IndexOf(const aLoc: TKMPoint; aTag: Cardinal; aTag2: Cardinal): Integer; overload; + procedure SortByTag; + function Remove(const aLoc: TKMPoint): Integer; override; + procedure Delete(aIndex: Integer); override; + procedure SaveToStream(SaveStream: TKMemoryStream); override; + procedure LoadFromStream(LoadStream: TKMemoryStream); override; + end; + + + TKMPointDirList = class //Used for finding fishing places, fighting positions, etc. + private + fItems: array of TKMPointDir; //0..Count-1 + fCount: Integer; + function GetItem(aIndex: Integer): TKMPointDir; + public + procedure Clear; + procedure Add(const aLoc: TKMPointDir); virtual; + property Count: Integer read fCount; + property Items[aIndex: Integer]: TKMPointDir read GetItem; default; + function GetRandom(out Point: TKMPointDir): Boolean; //overload; + +// function GetRandom(aCloseToLoc: TKMPoint; out Point: TKMPointDir): Boolean; overload; + procedure ToPointList(aList: TKMPointList; aUnique: Boolean); + procedure LoadFromStream(LoadStream: TKMemoryStream); virtual; + procedure SaveToStream(SaveStream: TKMemoryStream); virtual; + end; + + + TKMPointDirCenteredList = class(TKMPointDirList) + private + fCenter: TKMPoint; + fWeight: array of Single; + public + constructor Create(aCenter: TKMPoint); + procedure Add(const aLoc: TKMPointDir); override; + function GetWeightedRandom(out Point: TKMPointDir): Boolean; + end; + + + TKMPointDirTagList = class(TKMPointDirList) + public + Tag: array of Cardinal; //0..Count-1 + procedure Add(const aLoc: TKMPointDir; aTag: Cardinal); reintroduce; + procedure SortByTag; + procedure SaveToStream(SaveStream: TKMemoryStream); override; + procedure LoadFromStream(LoadStream: TKMemoryStream); override; + end; + + + TKMPointCounterList = class(TKMPointTagList) + private +// fAppearences: array of Word; + public + procedure Add(const aLoc: TKMPoint; aTag2: Cardinal = 0); reintroduce; + procedure AddNew(const aLoc: TKMPoint; aTag2: Cardinal = 0); + function GetPointsCnt(aIndex: Integer): Word; overload; + function GetPointsCnt(const aLoc: TKMPoint): Word; overload; + end; + + +implementation +uses + Math, + System.NetEncoding, + {$IFDEF FPC} zstream, {$ENDIF} + {$IFDEF WDC} ZLib, {$ENDIF} + KM_CommonUtils, KM_Defaults, KaMResourceInput; + +const + // Compression level + //------------------------------------ + // Test results: + // Time Size + // clNone 110ms 26503Kb + // clFastest 227ms 3130Kb + // clDefault 803ms 2424Kb + // clMax 9995ms 2304Kb + //------------------------------------ + // clDefault is optimal by time / compression ratio factor + STREAM_COMPRESSION_LEVEL: TCompressionLevel = clDefault; + + +function GetCompressionLvl: TCompressionLevel; +begin + if FEAT_SAVE_COMPRESSION then + Result := STREAM_COMPRESSION_LEVEL + else + Result := clNone; +end; + + +{TXStringList} +//List custom comparation, using Integer value, instead of its String represantation +function TXStringList.CompareStrings(const S1, S2: string): Integer; +var + i1, i2, e1, e2: Integer; +begin + Val(S1, i1, e1); + Assert((e1 = 0) or (S1[e1] = NameValueSeparator)); + Val(S2, i2, e2); + Assert((e2 = 0) or (S2[e2] = NameValueSeparator)); + Result := CompareValue(i1, i2); +end; + + +{ TKMList } +// We were notified that the item is deleted from the list +procedure TKMList.Notify(Ptr: Pointer; Action: TListNotification); +begin + inherited; + if (Action = lnDeleted) then + TObject(Ptr).Free; +end; + + +{ TKMemoryStream } +constructor TKMemoryStream.Create(aShouldBeCompressed: Boolean = False); +begin + inherited Create; + fShouldBeCompressed := aShouldBeCompressed; +end; + + +procedure TKMemoryStream.LoadFromFile(const aFileName: string); +var + Source: TStream; +begin + Source := KaMOpenResourceStream(aFileName); + try + inherited LoadFromStream(Source); + Position := 0; + finally + Source.Free; + end; +end; + + +procedure TKMemoryStream.ReadBytes(out Value: TBytes); +var + I: Word; +begin + Read(I, SizeOf(I)); + SetLength(Value, I); + if I > 0 then + Read(Pointer(Value)^, I); +end; + + +procedure TKMemoryStream.WriteBytes(const Value: TBytes); +var + I: Word; +begin + I := Length(Value); + inherited Write(I, SizeOf(I)); + if I = 0 then Exit; + inherited Write(Pointer(Value)^, I); +end; + + +procedure TKMemoryStream.AppendStream(aStream: TKMemoryStream; const aMarker: string); +begin + if aStream.fShouldBeCompressed then + CompressAndAppendStream(aStream, aMarker) + else + AppendNotCompressedStream(aStream, aMarker); +end; + + +procedure TKMemoryStream.AppendNotCompressedStream(aStream: TKMemoryStream; const aMarker: string); +begin + PlaceMarker(aMarker); + Write(aStream.fShouldBeCompressed); + Write(Cardinal(aStream.Size)); + CopyFrom(aStream, 0); +end; + + +procedure TKMemoryStream.CompressAndAppendStream(aStream: TKMemoryStream; const aMarker: string); +var + S: TKMemoryStream; + {$IFNDEF NO_COMPRESSION} + CS: TCompressionStream; + {$ENDIF} +begin + S := TKMemoryStreamBinary.Create(True); + try + {$IFDEF NO_COMPRESSION} + S.fShouldBeCompressed := False; + S.CopyFrom(aStream, 0); + {$ELSE} + CS := TCompressionStream.Create(GetCompressionLvl, S); + try + CS.CopyFrom(aStream, 0); + finally + CS.Free; + end; + {$ENDIF} + + AppendNotCompressedStream(S, aMarker); + finally + S.Free; + end; +end; + + +procedure TKMemoryStream.LoadToStream(aStream: TKMemoryStream; const aMarker: string); +var + isCompressed: Boolean; + streamSize: Cardinal; + {$IFNDEF NO_COMPRESSION} + S: TKMemoryStream; + DS: TDecompressionStream; + {$ENDIF} +begin + if Position >= Size then Exit; + + CheckMarker(aMarker); + Read(isCompressed); + Read(streamSize); + + if isCompressed then + begin + {$IFDEF NO_COMPRESSION} + raise Exception.Create('Using compression streams is not allowed! F.e. on Delphi 11 Alexandria under debug'); + {$ELSE} + S := TKMemoryStreamBinary.Create(True); + try + S.CopyFrom(Self, streamSize); + S.Position := 0; + DS := TDecompressionStream.Create(S); + try + aStream.CopyFromDecompression(DS); + aStream.Position := 0; + finally + DS.Free; + end; + finally + S.Free; + end; + {$ENDIF} + end + else + begin + aStream.CopyFrom(Self, streamSize); + aStream.Position := 0; + end; +end; + + +procedure TKMemoryStream.LoadToStreams(aStream1, aStream2: TKMemoryStream; const aMarker1, aMarker2: string); +begin + LoadToStream(aStream1, aMarker1); + LoadToStream(aStream2, aMarker2); +end; + + +function TKMemoryStream.ToBase64: String; +var + Encoding: TBase64Encoding; +begin + Result := ''; + {$IFDEF WDC} + Encoding := TBase64Encoding.Create(0); + try + Result := Encoding.EncodeBytesToString(Memory, Size); + finally + Encoding.Free; + end; + {$ENDIF} + {$IFDEF FPC} + // Not supported yet (no support was needed yet) + {$ENDIF} +end; + + +function TKMemoryStream.ToBase64Compressed: String; +var + compStream: TKMemoryStream; +begin + compStream := TKMemoryStreamBinary.Create; + try + SaveToStreamCompressed(compStream); + Result := compStream.ToBase64; + finally + compStream.Free; + end; +end; + + + +procedure TKMemoryStream.LoadFromBase64(aBase64: string); +{$IFDEF WDC} +var + Bytes: TBytes; + Encoding: TBase64Encoding; +{$ENDIF} +begin + {$IFDEF WDC} + Encoding := TBase64Encoding.Create(0); + try + Bytes := Encoding.DecodeStringToBytes(aBase64); + WriteData(Bytes, Length(Bytes)); + Position := 0; + finally + Encoding.Free; + end; + {$ENDIF} + {$IFDEF FPC} + // Not supported yet (no support was needed yet) + {$ENDIF} +end; + + +procedure TKMemoryStream.LoadFromBase64Compressed(aBase64: string); +var + compStream: TKMemoryStream; +begin + compStream := TKMemoryStreamBinary.Create; + try + compStream.LoadFromBase64(aBase64); + LoadFromStreamCompressed(compStream); + finally + compStream.Free; + end; +end; + + +// Set size to current position +procedure TKMemoryStream.TrimToPosition; +begin + SetSize(Position); +end; + + +procedure TKMemoryStream.CopyFromDecompression(Source: TStream); +const + MAX_BUF_SIZE = $F000; +var + count: Integer; + buffer: PByte; +begin + Source.Position := 0; + GetMem(buffer, MAX_BUF_SIZE); + try + count := Source.Read(buffer^, MAX_BUF_SIZE); + while count > 0 do + begin + WriteBuffer(buffer^, count); + count := Source.Read(buffer^, MAX_BUF_SIZE); + end; + finally + FreeMem(buffer, MAX_BUF_SIZE); + end; +end; + + +procedure TKMemoryStream.SaveToFileCompressed(const aFileName: string; const aMarker: string); +var + S: TKMemoryStream; +begin + S := TKMemoryStreamBinary.Create; + try + SaveToStreamCompressed(S, aMarker); + S.SaveToFile(aFileName); + finally + S.Free; + end; +end; + + +procedure TKMemoryStream.LoadFromFileCompressed(const aFileName: string; const aMarker: string); +var + S: TKMemoryStream; +begin + S := TKMemoryStreamBinary.Create; + try + S.LoadFromFile(aFileName); + LoadFromStreamCompressed(S, aMarker); + finally + S.Free; + end; +end; + + +procedure TKMemoryStream.SaveToStreamCompressed(aStream: TKMemoryStream; const aMarker: string = ''); +{$IFNDEF NO_COMPRESSION} +var + CS: TCompressionStream; +{$ENDIF} +begin + if aMarker <> '' then + aStream.PlaceMarker(aMarker); + {$IFDEF NO_COMPRESSION} + aStream.CopyFrom(Self, 0); + {$ELSE} + CS := TCompressionStream.Create(GetCompressionLvl, aStream); + try + CS.CopyFrom(Self, 0); + finally + CS.Free; + end; + {$ENDIF} +end; + + +procedure TKMemoryStream.LoadFromStreamCompressed(aStream: TKMemoryStream; const aMarker: string = ''); +{$IFNDEF NO_COMPRESSION} +var + DS: TDecompressionStream; +{$ENDIF} +begin + if aMarker <> '' then + aStream.CheckMarker(aMarker); + {$IFDEF NO_COMPRESSION} + CopyFrom(aStream, aStream.Size - aStream.Position); + {$ELSE} + DS := TDecompressionStream.Create(aStream); + try + CopyFromDecompression(DS); + finally + DS.Free; + end; + {$ENDIF} + Position := 0; +end; + + +{ TKMPointList } +constructor TKMPointList.Create; +begin + inherited; +end; + + +procedure TKMPointList.Clear; +begin + fCount := 0; +end; + + +procedure TKMPointList.Add(const aLoc: TKMPoint); +begin + if fCount >= Length(fItems) then + SetLength(fItems, fCount + 32); + fItems[fCount] := aLoc; + Inc(fCount); +end; + + +procedure TKMPointList.Add(X, Y: Integer); +begin + Add(TKMPoint.New(X, Y)); +end; + + +procedure TKMPointList.AddList(aList: TKMPointList); +var + I: Integer; +begin + for I := 0 to aList.Count - 1 do + Add(aList[I]); +end; + + +procedure TKMPointList.AddUnique(const aLoc: TKMPoint); +begin + if not Contains(aLoc) then + Add(aLoc); +end; + + +procedure TKMPointList.AddListUnique(aList: TKMPointList); +var + I: Integer; +begin + for I := 0 to aList.Count - 1 do + AddUnique(aList[I]); +end; + + +//Remove point from the list if is there. Return index of removed entry or -1 on failure +function TKMPointList.Remove(const aLoc: TKMPoint): Integer; +var + I: Integer; +begin + Result := -1; + + //Scan whole list to detect duplicate entries + for I := 0 to fCount - 1 do + if KMSamePoint(fItems[I], aLoc) then + Result := I; + + //Remove found entry + if (Result <> -1) then + Delete(Result); +end; + + +procedure TKMPointList.Delete(aIndex: Integer); +begin + if not InRange(aIndex, 0, Count-1) then Exit; + if (aIndex <> fCount - 1) then + Move(fItems[aIndex+1], fItems[aIndex], SizeOf(fItems[aIndex]) * (fCount - 1 - aIndex)); + Dec(fCount); +end; + + +//Insert an entry and check if list is still walkable +//Walkable means that every point is next to neighbour points } +procedure TKMPointList.Insert(ID: Integer; const aLoc: TKMPoint); +begin + Assert(InRange(ID, 0, fCount)); + + //Grow the list + if fCount >= Length(fItems) then + SetLength(fItems, fCount + 32); + + //Shift items towards end + if fCount <> 0 then + Move(fItems[ID], fItems[ID+1], SizeOf(fItems[ID]) * (fCount - ID)); + + fItems[ID] := aLoc; + Inc(fCount); +end; + + +function TKMPointList.GetRandom(out Point: TKMPoint): Boolean; +begin + Result := fCount <> 0; + if Result then + Point := fItems[KaMRandom(fCount{$IFDEF DBG_RNG_SPY}, 'TKMPointList.GetRandom'{$ENDIF})]; +end; + + +function TKMPointList.GetClosest(const aLoc: TKMPoint; out Point: TKMPoint): Boolean; +var + I: Integer; +begin + Result := fCount <> 0; + if Result then + begin + Point := fItems[0]; + for I := 1 to fCount - 1 do + if KMLengthSqr(fItems[I], aLoc) < KMLengthSqr(Point, aLoc) then + Point := fItems[I]; + end; +end; + + +function TKMPointList.Contains(const aLoc: TKMPoint): Boolean; +begin + Result := IndexOf(aLoc) <> -1; +end; + + +function TKMPointList.IndexOf(const aLoc: TKMPoint): Integer; +var + I: Integer; +begin + Result := -1; + for I := fCount - 1 downto 0 do + if KMSamePoint(aLoc, fItems[I]) then + begin + Result := I; + Break; + end; +end; + + +function TKMPointList.GetLast: TKMPoint; +begin + if IsEmpty then + raise Exception.Create('No points in list'); + Result := fItems[fCount - 1]; +end; + + +function TKMPointList.IsEmpty: Boolean; +begin + Result := fCount = 0; +end; + + +procedure TKMPointList.Copy(aSrc: TKMPointList); +begin + fCount := aSrc.Count; + SetLength(fItems, fCount); + + Move(aSrc.fItems[0], fItems[0], SizeOf(fItems[0]) * fCount); +end; + + +function TKMPointList.GetPoint(aIndex: Integer): TKMPoint; +begin + Result := fItems[aIndex]; +end; + + +procedure TKMPointList.SetPoint(aIndex: Integer; const aValue: TKMPoint); +begin + fItems[aIndex] := aValue; +end; + + +function TKMPointList.GetLen: Single; +var + I: Integer; +begin + Result := 0; + for I := 0 to fCount - 2 do + Result := Result + KMLengthDiag(fItems[I], fItems[I + 1]); +end; + + +//Reverse the list +procedure TKMPointList.Inverse; +var + I: Integer; +begin + for I := 0 to fCount div 2 - 1 do + KMSwapPoints(fItems[I], fItems[fCount-1-I]); +end; + + +//Used in JPS pathfinding +//Take the sparse walk route with nodes in corners (A------B) +//and add all the missing nodes inbetween like so: (A123456B) +procedure TKMPointList.SparseToDense; +var + I, K, J: Integer; + tmp: array of TKMPoint; + span: Word; + C, N: ^TKMPoint; +begin + K := 0; + SetLength(tmp, 8192); + for I := 0 to fCount - 1 do + begin + tmp[K] := fItems[I]; + Inc(K); + + if (I <> fCount - 1) then + begin + C := @fItems[I]; + N := @fItems[I+1]; + span := Max(Abs(N.X - C.X), Abs(N.Y - C.Y)); + for J := 1 to span - 1 do + begin + tmp[K].X := C.X + Round((N.X - C.X) / span * J); + tmp[K].Y := C.Y + Round((N.Y - C.Y) / span * J); + Inc(K); + end; + end; + end; + + fCount := K; + SetLength(fItems, fCount); + Move(tmp[0], fItems[0], SizeOf(fItems[0]) * fCount); +end; + + +function TKMPointList.GetBounds(out Bounds: TKMRect): Boolean; +var + I: Integer; +begin + Result := fCount <> 0; + + if Result then + begin + //Something to start with + Bounds.Left := fItems[0].X; + Bounds.Top := fItems[0].Y; + Bounds.Right := fItems[0].X; + Bounds.Bottom := fItems[0].Y; + for I := 1 to fCount - 1 do + begin + if fItems[I].X < Bounds.Left then Bounds.Left := fItems[I].X; + if fItems[I].Y < Bounds.Top then Bounds.Top := fItems[I].Y; + if fItems[I].X > Bounds.Right then Bounds.Right := fItems[I].X; + if fItems[I].Y > Bounds.Bottom then Bounds.Bottom := fItems[I].Y; + end; + end; +end; + + +procedure TKMPointList.SaveToStream(SaveStream: TKMemoryStream); +begin + SaveStream.Write(fCount); + if fCount > 0 then + SaveStream.Write(fItems[0], SizeOf(fItems[0]) * fCount); +end; + + +procedure TKMPointList.LoadFromStream(LoadStream: TKMemoryStream); +begin + LoadStream.Read(fCount); + SetLength(fItems, fCount); + if fCount > 0 then + LoadStream.Read(fItems[0], SizeOf(fItems[0]) * fCount); +end; + + +{ TKMWeightedPointList } +procedure TKMWeightedPointList.Add(const aLoc: TKMPoint; aWeight: Single); +begin + inherited Add(aLoc); + + if fCount >= Length(fWeight) then + SetLength(fWeight, fCount + 32); + + fWeight[fCount - 1] := aWeight; +end; + + +function TKMWeightedPointList.GetWeightedRandom(out Point: TKMPoint): Boolean; +var + I: Integer; + weightsSum, rnd: Extended; +begin + Result := False; + + if Count = 0 then + Exit; + + weightsSum := 0; + for I := 0 to fCount - 1 do + weightsSum := weightsSum + fWeight[I]; + + rnd := KaMRandomS1(weightsSum{$IFDEF DBG_RNG_SPY}, 'TKMPointCenteredList.GetWeightedRandom'{$ENDIF}); + + for I := 0 to fCount - 1 do + begin + if rnd < fWeight[I] then + begin + Point := fItems[I]; + Exit(True); + end; + rnd := rnd - fWeight[I]; + end; + Assert(False, 'Error getting weighted random'); +end; + + +{ TKMPointCenteredList } +constructor TKMPointCenteredList.Create(const aCenter: TKMPoint); +begin + inherited Create; + fCenter := aCenter; +end; + + +procedure TKMPointCenteredList.Add(const aLoc: TKMPoint); +const + BASE_VAL = 100; +var + dist, weight: Single; +begin + dist := KMLength(fCenter, aLoc); + + if dist = 0 then + weight := BASE_VAL * 2 // High weight when aLoc is in the center + else + weight := BASE_VAL / dist; // Smaller weight for distant locs + + inherited Add(aLoc, weight); +end; + + +{ TKMPointTagList } +procedure TKMPointTagList.Clear; +begin + inherited; +end; + + +procedure TKMPointTagList.Add(const aLoc: TKMPoint; aTag: Cardinal; aTag2: Cardinal = 0); +begin + inherited Add(aLoc); + + if fCount >= Length(Tag) then SetLength(Tag, fCount + 32); //Expand the list + if fCount >= Length(Tag2) then SetLength(Tag2, fCount + 32); //+32 is just a way to avoid further expansions + Tag[fCount-1] := aTag; + Tag2[fCount-1] := aTag2; +end; + + +function TKMPointTagList.IndexOf(const aLoc: TKMPoint; aTag, aTag2: Cardinal): Integer; +var + I: Integer; +begin + Result := -1; + for I := fCount - 1 downto 0 do + if KMSamePoint(aLoc, fItems[I]) and (aTag = Tag[I]) and (aTag2 = Tag2[I]) then + begin + Result := I; + Break; + end; +end; + + +function TKMPointTagList.Remove(const aLoc: TKMPoint): Integer; +begin + Result := inherited Remove(aLoc); + //Tags are moved by Delete function. No need to move them here +end; + + +procedure TKMPointTagList.Delete(aIndex: Integer); +begin + if not InRange(aIndex, 0, Count - 1) or (Count = 0) then Exit; + + inherited Delete(aIndex); + + //Note that fCount is already decreased by 1 + if (aIndex <> fCount) then + begin + Move(Tag[aIndex+1], Tag[aIndex], SizeOf(Tag[aIndex]) * (fCount - aIndex)); + Move(Tag2[aIndex+1], Tag2[aIndex], SizeOf(Tag2[aIndex]) * (fCount - aIndex)); + end; +end; + + +procedure TKMPointTagList.SaveToStream(SaveStream: TKMemoryStream); +begin + inherited; //Writes Count + + if fCount > 0 then + begin + SaveStream.Write(Tag[0], SizeOf(Tag[0]) * fCount); + SaveStream.Write(Tag2[0], SizeOf(Tag2[0]) * fCount); + end; +end; + + +procedure TKMPointTagList.SortByTag; + // Quicksort implementation (because there is not specified count of elements buble does not give any sense) + procedure QuickSort(MinIdx,MaxIdx: Integer); + var + I, K, X: Integer; + begin + I := MinIdx; + K := MaxIdx; + X := Tag[(MinIdx+MaxIdx) div 2]; + repeat + while (Tag[I] < X) do + I := I + 1; + while (X < Tag[K]) do + K := K - 1; + if (I <= K) then + begin + KMSwapPoints(fItems[I], fItems[K]); + KMSwapInt(Tag[I], Tag[K]); + KMSwapInt(Tag2[I], Tag2[K]); + I := I + 1; + K := K - 1; + end; + until (I > K); + if (MinIdx < K) then + QuickSort(MinIdx,K); + if (I < MaxIdx) then + QuickSort(I,MaxIdx); + end; + +//var I,K: Integer; +begin + // Buble sort + //for I := 0 to fCount - 1 do + // for K := I + 1 to fCount - 1 do + // if Tag[K] < Tag[I] then + // begin + // KMSwapPoints(fItems[I], fItems[K]); + // KMSwapInt(Tag[I], Tag[K]); + // KMSwapInt(Tag2[I], Tag2[K]); + // end; + if (fCount > 1) then + QuickSort(0, fCount - 1); +end; + + +procedure TKMPointTagList.LoadFromStream(LoadStream: TKMemoryStream); +begin + inherited; //Reads Count + + SetLength(Tag, fCount); + SetLength(Tag2, fCount); + if fCount > 0 then + begin + LoadStream.Read(Tag[0], SizeOf(Tag[0]) * fCount); + LoadStream.Read(Tag2[0], SizeOf(Tag2[0]) * fCount); + end; +end; + + +{ TKMPointList } +procedure TKMPointDirList.Clear; +begin + fCount := 0; +end; + + +procedure TKMPointDirList.Add(const aLoc: TKMPointDir); +begin + if fCount >= Length(fItems) then + SetLength(fItems, fCount + 32); + fItems[fCount] := aLoc; + inc(fCount); +end; + + +function TKMPointDirList.GetItem(aIndex: Integer): TKMPointDir; +begin + Assert(InRange(aIndex, 0, fCount - 1)); + Result := fItems[aIndex]; +end; + + +function TKMPointDirList.GetRandom(out Point: TKMPointDir):Boolean; +begin + Result := False; + if fCount > 0 then + begin + Point := fItems[KaMRandom(fCount{$IFDEF DBG_RNG_SPY}, 'TKMPointDirList.GetRandom'{$ENDIF})]; + Result := True; + end; +end; + + +procedure TKMPointDirList.ToPointList(aList: TKMPointList; aUnique: Boolean); +var + I: Integer; +begin + for I := 0 to fCount - 1 do + if aUnique then + aList.AddUnique(fItems[I].Loc) + else + aList.Add(fItems[I].Loc) +end; + + +procedure TKMPointDirList.SaveToStream(SaveStream: TKMemoryStream); +begin + SaveStream.Write(fCount); + if fCount > 0 then + SaveStream.Write(fItems[0], SizeOf(fItems[0]) * fCount); +end; + + +procedure TKMPointDirList.LoadFromStream(LoadStream: TKMemoryStream); +begin + LoadStream.Read(fCount); + SetLength(fItems, fCount); + if fCount > 0 then + LoadStream.Read(fItems[0], SizeOf(fItems[0]) * fCount); +end; + + +{ TKMPointDirCenteredList } +constructor TKMPointDirCenteredList.Create(aCenter: TKMPoint); +begin + inherited Create; + fCenter := aCenter; +end; + + +procedure TKMPointDirCenteredList.Add(const aLoc: TKMPointDir); +const + BASE_VAL = 100; +var + len: Single; +begin + inherited; + + if fCount >= Length(fWeight) then + SetLength(fWeight, fCount + 32); + + len := KMLength(fCenter, aLoc.Loc); + //Special case when we aLoc is in the center + if len = 0 then + fWeight[fCount - 1] := BASE_VAL * 2 + else + fWeight[fCount - 1] := BASE_VAL / len; //smaller weight for distant locs +end; + + +function TKMPointDirCenteredList.GetWeightedRandom(out Point: TKMPointDir): Boolean; +var + I: Integer; + weightsSum, rnd: Single; +begin + Result := False; + + if Count = 0 then + Exit; + + weightsSum := 0; + for I := 0 to fCount - 1 do + weightsSum := weightsSum + fWeight[I]; + + rnd := KaMRandomS1(weightsSum{$IFDEF DBG_RNG_SPY}, 'TKMPointDirCenteredList.GetWeightedRandom'{$ENDIF}); + + for I := 0 to fCount - 1 do + begin + if rnd < fWeight[I] then + begin + Point := fItems[I]; + Exit(True); + end; + rnd := rnd - fWeight[I]; + end; + Assert(False, 'Error getting weighted random'); +end; + + +{ TKMPointDirTagList } +procedure TKMPointDirTagList.Add(const aLoc: TKMPointDir; aTag: Cardinal); +begin + inherited Add(aLoc); + + if fCount >= Length(Tag) then SetLength(Tag, fCount + 32); //Expand the list + Tag[fCount-1] := aTag; +end; + + +procedure TKMPointDirTagList.SortByTag; +var + I, K: Integer; +begin + for I := 0 to fCount - 1 do + for K := I + 1 to fCount - 1 do + if Tag[K] < Tag[I] then + begin + KMSwapPointDir(fItems[I], fItems[K]); + KMSwapInt(Tag[I], Tag[K]); + end; +end; + + +procedure TKMPointDirTagList.SaveToStream(SaveStream: TKMemoryStream); +begin + inherited; //Writes Count + + if fCount > 0 then + SaveStream.Write(Tag[0], SizeOf(Tag[0]) * fCount); +end; + + +procedure TKMPointDirTagList.LoadFromStream(LoadStream: TKMemoryStream); +begin + inherited; //Reads Count + + SetLength(Tag, fCount); + if fCount > 0 then + LoadStream.Read(Tag[0], SizeOf(Tag[0]) * fCount); +end; + + +{ TKMPointCounterList } +procedure TKMPointCounterList.Add(const aLoc: TKMPoint; aTag2: Cardinal = 0); +var + ind: Integer; +begin + ind := IndexOf(aLoc); + if ind <> -1 then + Tag[ind] := Tag[ind] + 1 + else + inherited Add(aLoc, 1, aTag2); +end; + + +procedure TKMPointCounterList.AddNew(const aLoc: TKMPoint; aTag2: Cardinal = 0); +begin + if Contains(aLoc) then Exit; + + inherited Add(aLoc, 1, aTag2); +end; + + +function TKMPointCounterList.GetPointsCnt(aIndex: Integer): Word; +begin + Result := Tag[aIndex]; +end; + + +function TKMPointCounterList.GetPointsCnt(const aLoc: TKMPoint): Word; +var + ind: Integer; +begin + ind := IndexOf(aLoc); + if ind = -1 then + Result := 0 + else + Result := Tag[ind]; +end; + + +{ TKMemoryStream } +procedure TKMemoryStream.ReadHugeString(out Value: AnsiString); +var + I: Cardinal; +begin + Read(I, SizeOf(I)); + SetLength(Value, I); + if I > 0 then + Read(Pointer(Value)^, I); +end; + + +procedure TKMemoryStream.WriteHugeString(const Value: AnsiString); +var + I: Cardinal; +begin + I := Length(Value); + inherited Write(I, SizeOf(I)); + if I = 0 then Exit; + inherited Write(Pointer(Value)^, I); +end; + + +procedure TKMemoryStream.ReadHugeStringW(out Value: UnicodeString); +var + I: Cardinal; +begin + Read(I, SizeOf(I)); + SetLength(Value, I); + if I > 0 then + Read(Pointer(Value)^, I * SizeOf(WideChar)); +end; + + +procedure TKMemoryStream.WriteHugeStringW(const Value: UnicodeString); +var + I: Cardinal; +begin + I := Length(Value); + inherited Write(I, SizeOf(I)); + if I = 0 then Exit; + inherited Write(Pointer(Value)^, I * SizeOf(WideChar)); +end; + + +{ TKMemoryStreamBinary } +function TKMemoryStreamBinary.Write(const Buffer; Count: Longint): Longint; +begin + Result := inherited Write(Buffer, Count); +end; + + +procedure TKMemoryStreamBinary.CheckMarker(const aTitle: string); +var + s: string; +begin + // We use only Latin for Markers, hence ANSI is fine + // But since Android does not support "AnsiString" we take "string" as input + ReadANSI(s); + Assert(s = aTitle); +end; + + +procedure TKMemoryStreamBinary.PlaceMarker(const aTitle: string); +begin + // We use only Latin for Markers, hence ANSI is fine + // But since Android does not support "AnsiString" we take "string" as input + WriteANSI(aTitle); +end; + + +procedure TKMemoryStreamBinary.ReadANSI(out aValue: string); +var + I: Word; + bytes: TBytes; +begin + aValue := ''; + inherited Read(I, SizeOf(I)); + SetLength(bytes, I); + if I = 0 then Exit; + inherited Read(bytes[0], I); + aValue := TEncoding.ANSI.GetString(bytes); +end; + + +procedure TKMemoryStreamBinary.WriteANSI(const aValue: string); +var + I: Word; + bytes: TBytes; +begin + bytes := TEncoding.ANSI.GetBytes(aValue); + I := Length(bytes); + Write(I, SizeOf(I)); + if I = 0 then Exit; + Write(bytes[0], I); +end; + + +//{$IFDEF DESKTOP} +procedure TKMemoryStreamBinary.ReadA(out Value: AnsiString); +var + I: Word; +begin + Read(I, SizeOf(I)); + SetLength(Value, I); + if I > 0 then + Read(Pointer(Value)^, I); +end; + +procedure TKMemoryStreamBinary.WriteA(const Value: AnsiString); +var + I: Word; +begin + I := Length(Value); + inherited Write(I, SizeOf(I)); + if I = 0 then Exit; + inherited Write(Pointer(Value)^, I); +end; +//{$ENDIF} + + +//{$IFDEF TABLET} +//procedure TKMemoryStream.ReadA(out Value: string); +//var I: Word; +//begin +// Read(I, SizeOf(I)); +// SetLength(Value, I); +// if I > 0 then +// Read(Pointer(Value)^, I * SizeOf(WideChar)); +//end; +// +//procedure TKMemoryStream.WriteA(const Value: string); +//var I: Word; +//begin +// I := Length(Value); +// inherited Write(I, SizeOf(I)); +// if I = 0 then Exit; +// inherited Write(Pointer(Value)^, I * SizeOf(WideChar)); +//end; +//{$ENDIF} + + +procedure TKMemoryStreamBinary.ReadW(out Value: UnicodeString); +var + I: Word; +begin + Read(I, SizeOf(I)); + SetLength(Value, I); + if I > 0 then + Read(Pointer(Value)^, I * SizeOf(WideChar)); +end; + + +procedure TKMemoryStreamBinary.WriteW(const Value: UnicodeString); +var + I: Word; +begin + I := Length(Value); + inherited Write(I, SizeOf(I)); + if I = 0 then Exit; + inherited Write(Pointer(Value)^, I * SizeOf(WideChar)); +end; + +function TKMemoryStream.Write(const Buffer; Count: Longint): Longint; +begin + Result := inherited Write(Buffer, Count); +end; + +procedure TKMemoryStreamBinary.Read(out Value: TKMDirection); begin inherited Read(Value, SizeOf(Value)); end; +procedure TKMemoryStreamBinary.Read(out Value: TKMPoint); begin inherited Read(Value, SizeOf(Value)); end; +procedure TKMemoryStreamBinary.Read(out Value: TKMPointW); begin inherited Read(Value, SizeOf(Value)); end; +procedure TKMemoryStreamBinary.Read(out Value: TKMPointF); begin inherited Read(Value, SizeOf(Value)); end; +procedure TKMemoryStreamBinary.Read(out Value: TKMPointDir); begin inherited Read(Value, SizeOf(Value)); end; +procedure TKMemoryStreamBinary.Read(out Value: TKMRangeInt); begin inherited Read(Value, SizeOf(Value)); end; +procedure TKMemoryStreamBinary.Read(out Value: TKMRangeSingle); begin inherited Read(Value, SizeOf(Value)); end; +procedure TKMemoryStreamBinary.Read(out Value: TKMRect); begin inherited Read(Value, SizeOf(Value)); end; +procedure TKMemoryStreamBinary.Read(out Value: Single); begin inherited Read(Value, SizeOf(Value)); end; +procedure TKMemoryStreamBinary.Read(out Value: Extended); begin inherited Read(Value, SizeOf(Value)); end; +procedure TKMemoryStreamBinary.Read(out Value: Integer); begin inherited Read(Value, SizeOf(Value)); end; +procedure TKMemoryStreamBinary.Read(out Value: Cardinal); begin inherited Read(Value, SizeOf(Value)); end; +procedure TKMemoryStreamBinary.Read(out Value: Int64); begin inherited Read(Value, SizeOf(Value)); end; +procedure TKMemoryStreamBinary.Read(out Value: Byte); begin inherited Read(Value, SizeOf(Value)); end; +procedure TKMemoryStreamBinary.Read(out Value: Boolean); begin inherited Read(Value, SizeOf(Value)); end; +procedure TKMemoryStreamBinary.Read(out Value: Word); begin inherited Read(Value, SizeOf(Value)); end; +procedure TKMemoryStreamBinary.Read(out Value: ShortInt); begin inherited Read(Value, SizeOf(Value)); end; +procedure TKMemoryStreamBinary.Read(out Value: SmallInt); begin inherited Read(Value, SizeOf(Value)); end; +procedure TKMemoryStreamBinary.Read(out Value: TDateTime); begin inherited Read(Value, SizeOf(Value)); end; + + +procedure TKMemoryStreamBinary.Write(const Value: TKMDirection); begin inherited Write(Value, SizeOf(Value)); end; +procedure TKMemoryStreamBinary.Write(const Value: TKMPoint); begin inherited Write(Value, SizeOf(Value)); end; +procedure TKMemoryStreamBinary.Write(const Value: TKMPointW); begin inherited Write(Value, SizeOf(Value)); end; +procedure TKMemoryStreamBinary.Write(const Value: TKMPointF); begin inherited Write(Value, SizeOf(Value)); end; +procedure TKMemoryStreamBinary.Write(const Value: TKMPointDir); begin inherited Write(Value, SizeOf(Value)); end; +procedure TKMemoryStreamBinary.Write(const Value: TKMRangeInt); begin inherited Write(Value, SizeOf(Value)); end; +procedure TKMemoryStreamBinary.Write(const Value: TKMRangeSingle); begin inherited Write(Value, SizeOf(Value)); end; +procedure TKMemoryStreamBinary.Write(const Value: TKMRect); begin inherited Write(Value, SizeOf(Value)); end; +procedure TKMemoryStreamBinary.Write(const Value: Single); begin inherited Write(Value, SizeOf(Value)); end; +procedure TKMemoryStreamBinary.Write(const Value: Extended); begin inherited Write(Value, SizeOf(Value)); end; +procedure TKMemoryStreamBinary.Write(const Value: Integer); begin inherited Write(Value, SizeOf(Value)); end; +procedure TKMemoryStreamBinary.Write(const Value: Cardinal); begin inherited Write(Value, SizeOf(Value)); end; +procedure TKMemoryStreamBinary.Write(const Value: Int64); begin inherited Write(Value, SizeOf(Value)); end; +procedure TKMemoryStreamBinary.Write(const Value: Byte); begin inherited Write(Value, SizeOf(Value)); end; +procedure TKMemoryStreamBinary.Write(const Value: Boolean); begin inherited Write(Value, SizeOf(Value)); end; +procedure TKMemoryStreamBinary.Write(const Value: Word); begin inherited Write(Value, SizeOf(Value)); end; +procedure TKMemoryStreamBinary.Write(const Value: ShortInt); begin inherited Write(Value, SizeOf(Value)); end; +procedure TKMemoryStreamBinary.Write(const Value: SmallInt); begin inherited Write(Value, SizeOf(Value)); end; +procedure TKMemoryStreamBinary.Write(const Value: TDateTime); begin inherited Write(Value, SizeOf(Value)); end; + + +{ TKMemoryStreamText } +procedure TKMemoryStreamText.WriteText(const aString: string); +var + I: Word; + bytes: TBytes; +begin + bytes := TEncoding.ANSI.GetBytes(aString + ' '); + + I := Length(bytes); + inherited Write(bytes[0], I); +end; + +function TKMemoryStreamText.Write(const Buffer; Count: Longint): Longint; +begin + if Count = 1 then + WriteText(IntToHex(PByte(@Buffer)^, 2) + 'h') + else + if Count = 2 then + WriteText(IntToHex(PWord(@Buffer)^, 4) + 'h') + else + WriteText(IntToStr(Count) + 'bytes'); + Result := -1; +end; + +procedure TKMemoryStreamText.PlaceMarker(const aTitle: string); +begin + fLastSection := aTitle; + WriteText(sLineBreak + '[' + aTitle + ']' + sLineBreak); +end; + +procedure TKMemoryStreamText.WriteA(const Value: AnsiString); +begin + WriteText(UnicodeString(Value)); +end; + +procedure TKMemoryStreamText.WriteANSI(const aValue: string); +begin + WriteText(aValue); +end; + +procedure TKMemoryStreamText.WriteW(const Value: UnicodeString); +begin + WriteText(Value); +end; + +procedure TKMemoryStreamText.Write(const Value: TKMPointDir); +begin + WriteText(Value.ToString); +end; + +procedure TKMemoryStreamText.Write(const Value: TKMRangeInt); +begin + WriteText(Value.ToString); +end; + +procedure TKMemoryStreamText.Write(const Value: TKMRangeSingle); +begin + WriteText(Value.ToString); +end; + +procedure TKMemoryStreamText.Write(const Value: TKMRect); +begin + WriteText(Value.ToString); +end; + +procedure TKMemoryStreamText.Write(const Value: TKMDirection); +begin + WriteText('Dir' + IntToStr(Ord(Value))); +end; + +procedure TKMemoryStreamText.Write(const Value: TKMPoint); +begin + WriteText(Value.ToString); +end; + +procedure TKMemoryStreamText.Write(const Value: TKMPointW); +begin + WriteText(Value.ToString); +end; + +procedure TKMemoryStreamText.Write(const Value: TKMPointF); +begin + WriteText(Value.ToString); +end; + +procedure TKMemoryStreamText.Write(const Value: Boolean); +begin + WriteText(BoolToStr(Value, True)); +end; + +procedure TKMemoryStreamText.Write(const Value: Word); +begin + WriteText(IntToStr(Value)); +end; + +procedure TKMemoryStreamText.Write(const Value: ShortInt); +begin + WriteText(IntToStr(Value)); +end; + +procedure TKMemoryStreamText.Write(const Value: SmallInt); +begin + WriteText(IntToStr(Value)); +end; + +procedure TKMemoryStreamText.Write(const Value: Byte); +begin + WriteText(IntToStr(Value)); +end; + +procedure TKMemoryStreamText.Write(const Value: Single); +begin + WriteText(Format('%.5f', [Value])); +end; + +procedure TKMemoryStreamText.Write(const Value: Extended); +begin + WriteText(Format('%.5f', [Value])); +end; + +procedure TKMemoryStreamText.Write(const Value: Integer); +begin + WriteText(IntToStr(Value)); +end; + +procedure TKMemoryStreamText.Write(const Value: Cardinal); +begin + WriteText(IntToStr(Value)); +end; + +procedure TKMemoryStreamText.Write(const Value: Int64); +begin + WriteText(IntToStr(Value)); +end; + +procedure TKMemoryStreamText.Write(const Value: TDateTime); +var + str: String; +begin + DateTimeToString(str, 'dd.mm.yyyy hh:nn:ss.zzz', Value); + WriteText(str); +end; + + +//Not implemented methods +procedure TKMemoryStreamText.CheckMarker(const aTitle: string); +begin + raise Exception.Create('MemoryStreamText.CheckMarker is not implemented yet'); +end; + +procedure TKMemoryStreamText.ReadANSI(out aValue: string); +begin + raise Exception.Create('MemoryStreamText.ReadANSI is not implemented yet'); +end; + +procedure TKMemoryStreamText.ReadA(out Value: AnsiString); +begin + raise Exception.Create('MemoryStreamText.ReadA is not implemented yet'); +end; + +procedure TKMemoryStreamText.ReadW(out Value: UnicodeString); +begin + raise Exception.Create('MemoryStreamText.ReadW is not implemented yet'); +end; + +procedure TKMemoryStreamText.Read(out Value: TKMDirection); +begin + raise Exception.Create('MemoryStreamText.Read is not implemented yet'); +end; + +procedure TKMemoryStreamText.Read(out Value: TKMPoint); +begin + raise Exception.Create('MemoryStreamText.Read is not implemented yet'); +end; + +procedure TKMemoryStreamText.Read(out Value: TKMPointW); +begin + raise Exception.Create('MemoryStreamText.Read is not implemented yet'); +end; + +procedure TKMemoryStreamText.Read(out Value: TKMPointF); +begin + raise Exception.Create('MemoryStreamText.Read is not implemented yet'); +end; + +procedure TKMemoryStreamText.Read(out Value: TKMPointDir); +begin + raise Exception.Create('MemoryStreamText.Read is not implemented yet'); +end; + +procedure TKMemoryStreamText.Read(out Value: TKMRangeInt); +begin + raise Exception.Create('MemoryStreamText.Read is not implemented yet'); +end; + +procedure TKMemoryStreamText.Read(out Value: TKMRangeSingle); +begin + raise Exception.Create('MemoryStreamText.Read is not implemented yet'); +end; + +procedure TKMemoryStreamText.Read(out Value: TKMRect); +begin + raise Exception.Create('MemoryStreamText.Read is not implemented yet'); +end; + +procedure TKMemoryStreamText.Read(out Value: Single); +begin + raise Exception.Create('MemoryStreamText.Read is not implemented yet'); +end; + +procedure TKMemoryStreamText.Read(out Value: Extended); +begin + raise Exception.Create('MemoryStreamText.Read is not implemented yet'); +end; + +procedure TKMemoryStreamText.Read(out Value: Integer); +begin + raise Exception.Create('MemoryStreamText.Read is not implemented yet'); +end; + +procedure TKMemoryStreamText.Read(out Value: Cardinal); +begin + raise Exception.Create('MemoryStreamText.Read is not implemented yet'); +end; + +procedure TKMemoryStreamText.Read(out Value: Int64); +begin + raise Exception.Create('MemoryStreamText.Read is not implemented yet'); +end; + +procedure TKMemoryStreamText.Read(out Value: Byte); +begin + raise Exception.Create('MemoryStreamText.Read is not implemented yet'); +end; + +procedure TKMemoryStreamText.Read(out Value: Boolean); +begin + raise Exception.Create('MemoryStreamText.Read is not implemented yet'); +end; + +procedure TKMemoryStreamText.Read(out Value: Word); +begin + raise Exception.Create('MemoryStreamText.Read is not implemented yet'); +end; + +procedure TKMemoryStreamText.Read(out Value: ShortInt); +begin + raise Exception.Create('MemoryStreamText.Read is not implemented yet'); +end; + +procedure TKMemoryStreamText.Read(out Value: SmallInt); +begin + raise Exception.Create('MemoryStreamText.Read is not implemented yet'); +end; + +procedure TKMemoryStreamText.Read(out Value: TDateTime); +begin + raise Exception.Create('MemoryStreamText.Read is not implemented yet'); +end; + + +end. diff --git a/port-source/kam_remake/src/utils/io/KM_FileIO.pas b/port-source/kam_remake/src/utils/io/KM_FileIO.pas new file mode 100644 index 0000000..cfc66c4 --- /dev/null +++ b/port-source/kam_remake/src/utils/io/KM_FileIO.pas @@ -0,0 +1,713 @@ +unit KM_FileIO; +{$I KaM_Remake.inc} +interface +uses + {$IF DEFINED(FPC) AND NOT DEFINED(ANDROID)} lconvencoding, FileUtil, LazUTF8, + // windirs does not work under old lazarus (1.8.0) / FPC versions, which we use to make linux dedi server + LazFileUtils,{ windirs,} {$ENDIF} + {$IFDEF WDC} System.IOUtils, {$ENDIF} + {$IFDEF MSWindows} Windows, ShellAPI, {$ENDIF} + {$IF DEFINED(Unix) AND NOT DEFINED(ANDROID)} LCLType, {$ENDIF} + Classes, SysUtils + {$IFDEF WDC}, KM_WorkerThread{$ENDIF} + , KM_CommonTypes; + + //Read text file into ANSI string (scripts, locale texts) + function ReadTextA(const afilename: UnicodeString): AnsiString; + + //Read text file into unicode string (locale texts) + function ReadTextU(const afilename: UnicodeString; aEncoding: Word): UnicodeString; + + procedure KMCreateEmptyFile(const aFilePath: UnicodeString); + + //Copy a file (CopyFile is different between Delphi and Lazarus) + procedure KMCopyFile(const aSrc, aDest: UnicodeString); overload; + procedure KMCopyFile(const aSrc, aDest: UnicodeString; aOverwrite: Boolean); overload; + + //{$IF DEFINED(WDC) OR (FPC_FULLVERSION >= 30200)} + {$IFDEF WDC} + procedure KMCopyFileAsync(const aSrc, aDest: UnicodeString; aOverwrite: Boolean; aWorkerThread: TKMWorkerThread); + {$ENDIF} + + procedure KMDeleteFileToBin(const aPath: UnicodeString); + procedure KMDeleteFile(aFilePath: string; aDeleteToBin: Boolean = False); + + //Delete a folder (DeleteFolder is different between Delphi and Lazarus) + procedure KMDeleteFolderToBin(const aPath: UnicodeString); + procedure KMDeleteFolder(const aPath: UnicodeString); overload; + procedure KMDeleteFolder(const aPath: UnicodeString; aDeleteToBin: Boolean); overload; + procedure KMDeleteFolderContent(const aPath: UnicodeString; aDeleteToBin: Boolean = False); + + + //Rename a file (RenameFile is different between Delphi and Lazarus) + procedure KMRenamePath(const aSourcePath, aDestPath: UnicodeString); + + //Move a folder and rename all the files inside it (MoveFolder is different between Delphi and Lazarus) + function KMMoveFolder(const aSourceFolder, aDestFolder: UnicodeString): Boolean; + + //Rename all the files inside folder (MoveFolder is different between Delphi and Lazarus) + procedure KMRenameFilesInFolder(const aPathToFolder, aFromName, aToName: UnicodeString); + + function KMFileSize(const aFilename: String): Int64; + + function IsFilePath(const aPath: UnicodeString): Boolean; + + procedure WriteText(const aText: string; aFilename: string; aEncoding: TEncoding); + procedure WriteTextUtf8(const aText, aFilename: string); + + function IsDirectoryWriteable(const aDir: string): Boolean; + + function CreateAndGetDocumentsSavePath: string; + + procedure CheckFolderPermission(const aPath: string; var aRead, aWrite, aExec: Boolean); + + +implementation +uses + StrUtils, KM_CommonUtils, + KM_Defaults; + + +function ReadTextA(const aFilename: UnicodeString): AnsiString; +var + MS: TMemoryStream; + Head: Cardinal; +begin + MS := TMemoryStream.Create; + try + // We can't rely on StringList because it applies default codepage encoding, + // which may differ between MP players. + // Instead we read plain ANSI text. If there's BOM - clip it + MS.LoadFromFile(aFileName); + + // Read 4 bytes but check just 3, cos reading 3 bytes is a hassle + MS.Read(Head, SizeOf(Cardinal)); + + // Trim UTF8 BOM (don't know how to deal with others yet) + if Head and $FFFFFF = $BFBBEF then + MS.Position := 3 + else + MS.Position := 0; + + SetLength(Result, MS.Size - MS.Position); + if MS.Size - MS.Position > 0 then + MS.Read(Result[1], MS.Size - MS.Position); + finally + MS.Free; + end; +end; + + +//Load ANSI file with codepage we say into unicode string +function ReadTextU(const aFilename: UnicodeString; aEncoding: Word): UnicodeString; +var + {$IFDEF WDC} + SL: TStringList; + DefaultEncoding: TEncoding; + {$ENDIF} + {$IFDEF FPC} + MS: TMemoryStream; + Head: Cardinal; + HasBOM: Boolean; + TmpA: AnsiString; + {$ENDIF} +begin + {$IFDEF WDC} + SL := TStringList.Create; + DefaultEncoding := TEncoding.GetEncoding(aEncoding); + try + //Load the text file with default ANSI encoding. If file has embedded BOM it will be used + SL.DefaultEncoding := DefaultEncoding; + SL.LoadFromFile(aFilename); + Result := SL.Text; + finally + SL.Free; + DefaultEncoding.Free; + end; + {$ENDIF} + {$IFDEF FPC} + MS := TMemoryStream.Create; + try + MS.LoadFromFile(aFileName); + MS.Read(Head, 4); + + //Trim UTF8 BOM (don't know how to deal with others yet) + HasBOM := Head and $FFFFFF = $BFBBEF; + + if HasBOM then + MS.Position := 3 + else + MS.Position := 0; + + SetLength(TmpA, MS.Size - MS.Position); + MS.Read(TmpA[1], MS.Size - MS.Position); + + {$IFDEF ANDROID} + if not HasBOM then + raise Exception.Create('KM_FileIO: ReadTextU codepage conversion is unsupported on Android'); + Result := UTF8Decode(TmpA); + {$ELSE} + //Non-UTF8 files must be converted from their native encoding + if not HasBOM then + TmpA := ConvertEncoding(TmpA, 'cp' + IntToStr(aEncoding), EncodingUTF8); + + Result := UTF8ToUTF16(TmpA); + {$ENDIF} + finally + MS.Free; + end; + {$ENDIF} +end; + + +procedure KMCopyFile(const aSrc, aDest: UnicodeString); +begin + {$IFDEF ANDROID} + raise Exception.Create('KM_FileIO: KMCopyFile is unsupported on Android'); + {$ELSE} + {$IFDEF FPC} + CopyFile(pchar(aSrc), pchar(aDest), True); + {$ENDIF} + {$IFDEF WDC} + TFile.Copy(aSrc, aDest); + {$ENDIF} + {$ENDIF} +end; + + +procedure KMCopyFile(const aSrc, aDest: UnicodeString; aOverwrite: Boolean); +begin + {$IFDEF ANDROID} + raise Exception.Create('KM_FileIO: KMCopyFile is unsupported on Android'); + {$ELSE} + if aOverwrite and FileExists(aDest) then + DeleteFile(aDest); + + {$IFDEF FPC} + CopyFile(pchar(aSrc), pchar(aDest), True); + {$ENDIF} + {$IFDEF WDC} + TFile.Copy(aSrc, aDest); + {$ENDIF} + {$ENDIF} +end; + + +{$IFDEF WDC} +procedure KMCopyFileAsync(const aSrc, aDest: UnicodeString; aOverwrite: Boolean; aWorkerThread: TKMWorkerThread); +begin + {$IFDEF WDC} + aWorkerThread.QueueWork(procedure + begin + KMCopyFile(aSrc, aDest, aOverwrite); + end, 'KMCopyFile'); + {$ELSE} + KMCopyFile(aSrc, aDest, aOverwrite); + {$ENDIF} +end; +{$ENDIF} + + +procedure KMDeleteFileToBin(const aPath: UnicodeString); +begin + {$IFDEF ANDROID} + raise Exception.Create('KM_FileIO: KMDeleteFileToBin is unsupported on Android'); + {$ELSE} + KMDeleteFile(aPath, True); + {$ENDIF} +end; + + +// Same as delete folder actually .. adjoin? +procedure KMDeleteFile(aFilePath: string; aDeleteToBin: Boolean = False); +{$IFDEF MSWINDOWS} +var + ShOp: TSHFileOpStruct; + {$IFDEF FPC} +const + FOF_NO_UI = FOF_SILENT or FOF_NOCONFIRMATION or FOF_NOERRORUI or FOF_NOCONFIRMMKDIR; // don't display any UI at all + {$ENDIF} +{$ENDIF} +begin + {$IFDEF MSWINDOWS} + //{$IFDEF FPC} + //ShOp.hWnd := 0; + //{$ELSE} + ShOp.Wnd := 0; + //{$ENDIF} + ShOp.wFunc := FO_DELETE; + ShOp.pFrom := PChar(aFilePath + #0); + ShOp.pTo := nil; + ShOp.fFlags := FOF_NO_UI or (FOF_ALLOWUNDO * Ord(aDeleteToBin)); + SHFileOperation(ShOp); + {$ELSE} + {$IFDEF ANDROID} + if aDeleteToBin then + raise Exception.Create('KM_FileIO: KMDeleteFile recycle-bin mode is unsupported on Android'); + {$ENDIF} + DeleteFile(aFilePath); + {$ENDIF} +end; + + +procedure KMDeleteFolderToBin(const aPath: UnicodeString); +begin + {$IFDEF ANDROID} + raise Exception.Create('KM_FileIO: KMDeleteFolderToBin is unsupported on Android'); + {$ELSE} + KMDeleteFolder(aPath, True); + {$ENDIF} +end; + + +procedure KMDeleteFolder(const aPath: UnicodeString); +begin + {$IFDEF ANDROID} + raise Exception.Create('KM_FileIO: KMDeleteFolder is unsupported on Android'); + {$ELSE} + KMDeleteFolder(aPath, False); + {$ENDIF} +end; + + +procedure KMDeleteFolder(const aPath: UnicodeString; aDeleteToBin: Boolean); + + procedure DeleteDefault; + {$IFDEF WDC} + var + S: string; + {$ENDIF} + begin + {$IF DEFINED(FPC) AND NOT DEFINED(ANDROID)} + DeleteDirectory(aPath, False); + {$ENDIF} + {$IFDEF WDC} + + //TDirectory.Delete will sometimes delay deletion due to Windows behaviour + //Suggested workarounds: + // - Empty the directory first (seems to work, commented out below) + // - Move the directory to a temporary name then delete it (sounds more robust) + //Discussions of workarounds: + //https://stackoverflow.com/questions/42809389/tdirectory-delete-seems-to-be-asynchronous + //https://github.com/dotnet/runtime/issues/27958 + + //Generate a temporary name based on time and random number + //S := TDirectory.GetParent(ExcludeTrailingPathDelimiter(aPath)) + PathDelim + IntToStr(Random(MaxInt)) + UIntToStr(TimeGet); + //TDirectory.Move(aPath, S); + //TDirectory.Delete(S, True); + + // Rename folder approach could trigger antivirus sometimes (f.e. Kaspersky) + // so there could be many (almost) empty folders after antivirus block folders deletion + // "(folder deletion is potentionly dangeroues operation because of data corruption)" + for S in TDirectory.GetFiles(aPath) do + DeleteFile(S); + TDirectory.Delete(aPath, True); + //Assert(not DirectoryExists(aPath)); + {$ENDIF} + end; + + +{$IFDEF MSWINDOWS} +var + ShOp: TSHFileOpStruct; + {$IFDEF FPC} +const + FOF_NO_UI = FOF_SILENT or FOF_NOCONFIRMATION or FOF_NOERRORUI or FOF_NOCONFIRMMKDIR; // don't display any UI at all + {$ENDIF} +{$ENDIF} + +{$IFNDEF MSWINDOWS} + +{$ENDIF} +begin + {$IFDEF ANDROID} + raise Exception.Create('KM_FileIO: KMDeleteFolder is unsupported on Android'); + {$ELSE} + if DirectoryExists(aPath) then + begin + {$IFDEF MSWINDOWS} + if aDeleteToBin then + begin + //{$IFDEF FPC} + //ShOp.hWnd := 0; + //{$ELSE} + ShOp.Wnd := 0; + //{$ENDIF} + ShOp.wFunc := FO_DELETE; + ShOp.pFrom := PChar(aPath + #0); + ShOp.pTo := nil; + ShOp.fFlags := FOF_NO_UI or (FOF_ALLOWUNDO * Ord(aDeleteToBin)); + SHFileOperation(ShOp); + end + else + DeleteDefault; + {$ELSE} + DeleteDefault; + {$ENDIF} + end; + {$ENDIF} +end; + + +procedure KMDeleteFolderContent(const aPath: UnicodeString; aDeleteToBin: Boolean = False); +{$IFDEF WDC} +var + S: string; +{$ENDIF} +begin + {$IFDEF ANDROID} + raise Exception.Create('KM_FileIO: KMDeleteFolderContent is unsupported on Android'); + {$ELSE} + if DirectoryExists(aPath) then + begin + {$IFDEF FPC} + KMDeleteFolder(aPath, aDeleteToBin); + ForceDirectories(aPath); // We do not care too much about FPC now, recreating directory is ok + {$ENDIF} + {$IFDEF WDC} + + //TDirectory.Delete will sometimes delay deletion due to Windows behaviour + //Suggested workarounds: + // - Empty the directory first (seems to work, commented out below) + // - Move the directory to a temporary name then delete it (sounds more robust) + //Discussions of workarounds: + //https://stackoverflow.com/questions/42809389/tdirectory-delete-seems-to-be-asynchronous + //https://github.com/dotnet/runtime/issues/27958 + + //Generate a temporary name based on time and random number + //S := TDirectory.GetParent(ExcludeTrailingPathDelimiter(aPath)) + PathDelim + IntToStr(Random(MaxInt)) + UIntToStr(TimeGet); + //TDirectory.Move(aPath, S); + //TDirectory.Delete(S, True); + + // Rename folder approach could trigger antivirus sometimes (f.e. Kaspersky) + // so there could be many (almost) empty folders after antivirus block folders deletion + // "(folder deletion is potentionly dangeroues operation because of data corruption)" + for S in TDirectory.GetFiles(aPath) do + KMDeleteFile(S, aDeleteToBin); + //Assert(not DirectoryExists(aPath)); + {$ENDIF} + end; + {$ENDIF} +end; + + +procedure KMRenameFolder(const aSourcePath, aDestPath: UnicodeString); +begin + {$IFDEF FPC} RenameFile(aSourcePath, aDestPath); {$ENDIF} + {$IFDEF WDC} TDirectory.Move(aSourcePath, aDestPath); {$ENDIF} +end; + + +procedure KMRenamePath(const aSourcePath, aDestPath: UnicodeString); +var + ErrorStr: UnicodeString; +begin + if IsFilePath(aSourcePath) then + begin + if FileExists(aSourcePath) then + {$IFDEF FPC} RenameFile(aSourcePath, aDestPath); {$ENDIF} + {$IFDEF WDC} TFile.Move(aSourcePath, aDestPath); {$ENDIF} + end + else + if DirectoryExists(aSourcePath) then + begin + {$IFDEF ANDROID} + raise Exception.Create('KM_FileIO: KMRenamePath directory mode is unsupported on Android'); + {$ELSE} + //Try to delete folder up to 3 times. Sometimes folder could not be deleted for some reason + if not TryExecuteMethodProc(KMDeleteFolder, aDestPath, 'KMDeleteFolder', ErrorStr) then + raise Exception.Create('Can''t delete folder ' + aDestPath + ': ' + ErrorStr); + + //Try to rename folder up to 3 times. Sometimes folder could not be renamed for some reason + if not TryExecuteMethodProc(KMRenameFolder, aSourcePath, aDestPath, 'KMRenameFolder', ErrorStr) then + raise Exception.Create(Format('Can''t rename folder from %s to %s: %s', [aSourcePath, aDestPath, ErrorStr])); + {$ENDIF} + end; +end; + + +//Rename all files inside folder by pattern _old_name_suffix to _new_name_suffix +//Pattern that we use for most of the files for our maps/saves +procedure KMRenameFilesInFolder(const aPathToFolder, aFromName, aToName: UnicodeString); +var + I: Integer; + RenamedFile: UnicodeString; + SearchRec: TSearchRec; + FilesToRename: TStringList; +begin + if (Trim(aFromName) = '') + or (Trim(aToName) = '') + or (aFromName = aToName) then + Exit; + + FilesToRename := TStringList.Create; + try + //Find all files to rename in path + //Need to find them first, rename later, because we can possibly find files, that were already renamed, in case NewName = OldName + Smth + FindFirst(aPathToFolder + aFromName + '*', faAnyFile - faDirectory, SearchRec); + try + repeat + if (SearchRec.Name <> '.') and (SearchRec.Name <> '..') + and (Length(SearchRec.Name) > Length(aFromName)) then + FilesToRename.Add(SearchRec.Name); + until (FindNext(SearchRec) <> 0); + finally + FindClose(SearchRec); + end; + + //Move all previously finded files + for I := 0 to FilesToRename.Count - 1 do + begin + RenamedFile := aPathToFolder + aToName + RightStr(FilesToRename[I], Length(FilesToRename[I]) - Length(aFromName)); + if not FileExists(RenamedFile) and (aPathToFolder + FilesToRename[I] <> RenamedFile) then + KMRenamePath(aPathToFolder + FilesToRename[I], RenamedFile); + end; + finally + FilesToRename.Free; + end; +end; + + +//Move folder and rename all files inside by pattern _old_name_suffix to _new_name_suffix +//Pattern that we use for most of the files for our maps/saves +function KMMoveFolder(const aSourceFolder, aDestFolder: UnicodeString): Boolean; +var + SrcName, DestName: UnicodeString; +begin + Result := False; + if (Trim(aSourceFolder) = '') + or (Trim(aDestFolder) = '') + or (aSourceFolder = aDestFolder) + or not DirectoryExists(aSourceFolder) then Exit; + + {$IFDEF ANDROID} + raise Exception.Create('KM_FileIO: KMMoveFolder is unsupported on Android'); + {$ENDIF} + + KMDeleteFolder(aDestFolder, False); + + //Move directory to dest first + KMRenamePath(aSourceFolder, aDestFolder); + + SrcName := GetFileDirName(aSourceFolder); + DestName := GetFileDirName(aDestFolder); + //Rename all files there + KMRenameFilesInFolder(aDestFolder, SrcName, DestName); + + Result := True; +end; + + +function KMFileSize(const aFilename: String): Int64; +{$IFDEF MSWindows} +var + info: TWin32FileAttributeData; +{$ENDIF} +begin + Result := -1; + + {$IFDEF MSWindows} + if not GetFileAttributesEx({$IFDEF FPC}PChar{$ELSE}PWideChar{$ENDIF}(aFileName), GetFileExInfoStandard, @info) then + EXIT; + + Result := Int64(info.nFileSizeLow) or Int64(info.nFileSizeHigh shl 32); + {$ENDIF} +end; + + +function IsFilePath(const aPath: UnicodeString): Boolean; +begin + // For now we assume, that folder path always ends with PathDelim + Result := RightStr(aPath, 1) <> PathDelim; +end; + + +procedure WriteText(const aText: string; aFilename: string; aEncoding: TEncoding); +var + sl: TStringList; +begin +{$IFDEF ANDROID} + raise Exception.Create('KM_FileIO: WriteText is unsupported on Android'); +{$ELSE} +{$IFDEF WDC} + sl := TStringList.Create; + try + sl.Text := aText; + sl.SaveToFile(aFilename, aEncoding); + finally + sl.Free; + end; +{$ENDIF} +{$ENDIF} +end; + + +// Body taken from TStringList.SaveToFile +procedure WriteTextUtf8(const aText, aFilename: string); +var + Stream: TFileStream; + BOM, Buffer: TBytes; +begin + Stream := TFileStream.Create(aFileName, fmCreate); + try + BOM := TEncoding.UTF8.GetPreamble; + Stream.WriteBuffer(BOM, Length(BOM)); + + Buffer := TEncoding.UTF8.GetBytes(aText); + Stream.WriteBuffer(Buffer, Length(Buffer)); + finally + Stream.Free; + end; +end; + + +function IsDirectoryWriteable(const aDir: string): Boolean; +{$IFDEF WDC} +var + tmpFilename: string; + hnd: THandle; +{$ENDIF} +begin + {$IFDEF ANDROID} + raise Exception.Create('KM_FileIO: IsDirectoryWriteable is unsupported on Android'); + {$ELSE} + {$IFDEF WDC} + tmpFilename := IncludeTrailingPathDelimiter(aDir) + 'chk.tmp'; + + hnd := CreateFile(PChar(tmpFilename), GENERIC_READ or GENERIC_WRITE, 0, nil, + CREATE_NEW, FILE_ATTRIBUTE_TEMPORARY or FILE_FLAG_DELETE_ON_CLOSE, 0); + + Result := hnd <> INVALID_HANDLE_VALUE; + + if Result then + CloseHandle(hnd); + {$ELSE} + Result := True; //todo -cPractical: add Read/Write permissions on lazarus / fpc + {$ENDIF} + {$ENDIF} +end; + + +// Creates directory, if missing +// If its not possible, or there are no read / write permissions on the directory, +// then use execution directory (ExeDir) +function CreateAndGetDocumentsSavePath: string; +begin + {$IFDEF ANDROID} + raise Exception.Create('KM_FileIO: CreateAndGetDocumentsSavePath is unsupported on Android'); + {$ELSE} + // Returns C:\Users\Username\My Documents\My Games\GAME_TITLE\ + // According to GDSE this is the most commonly used savegame location (https://gamedev.stackexchange.com/a/108243) + if FEAT_SETTINGS_IN_MYDOC then + begin + {$IFDEF WDC} + Result := TPath.GetDocumentsPath + PathDelim + 'My Games' + PathDelim + GAME_TITLE + PathDelim; + {$ELSE} + // GetWindowsSpecialDir does not work under old lazarus (1.8.0) / FPC versions, which we use to make linux dedi server + //Result := GetWindowsSpecialDir(CSIDL_PERSONAL) + PathDelim + 'My Games' + PathDelim + GAME_TITLE + PathDelim + Result := GetUserDir + 'My Games' + PathDelim + GAME_TITLE + PathDelim; + {$ENDIF} + ForceDirectories(Result); + if not IsDirectoryWriteable(Result) then + Result := ExtractFilePath(ParamStr(0)); + end + else + Result := ExtractFilePath(ParamStr(0)); + {$ENDIF} +end; + + +{$IFDEF WDC} +const + FILE_READ_DATA = $0001; + FILE_WRITE_DATA = $0002; + FILE_APPEND_DATA = $0004; + FILE_READ_EA = $0008; + FILE_WRITE_EA = $0010; + FILE_EXECUTE = $0020; + FILE_READ_ATTRIBUTES = $0080; + FILE_WRITE_ATTRIBUTES = $0100; + FILE_GENERIC_READ = (STANDARD_RIGHTS_READ or FILE_READ_DATA or + FILE_READ_ATTRIBUTES or FILE_READ_EA or SYNCHRONIZE); + FILE_GENERIC_WRITE = (STANDARD_RIGHTS_WRITE or FILE_WRITE_DATA or + FILE_WRITE_ATTRIBUTES or FILE_WRITE_EA or FILE_APPEND_DATA or SYNCHRONIZE); + FILE_GENERIC_EXECUTE = (STANDARD_RIGHTS_EXECUTE or FILE_READ_ATTRIBUTES or + FILE_EXECUTE or SYNCHRONIZE); + FILE_ALL_ACCESS = STANDARD_RIGHTS_REQUIRED or SYNCHRONIZE or $1FF; + + +// example from https://stackoverflow.com/questions/6908152/how-to-get-permission-level-of-a-folder +function CheckFileAccess(const aFileName: string; const aCheckedAccess: Cardinal): Cardinal; +var + Token: THandle; + Status: LongBool; + Access: Cardinal; + SecDescSize: Cardinal; + PrivSetSize: Cardinal; + PrivSet: PRIVILEGE_SET; + Mapping: GENERIC_MAPPING; + SecDesc: PSECURITY_DESCRIPTOR; +begin + Result := 0; + GetFileSecurity(PChar(aFileName), OWNER_SECURITY_INFORMATION or GROUP_SECURITY_INFORMATION or DACL_SECURITY_INFORMATION, nil, 0, SecDescSize); + SecDesc := GetMemory(SecDescSize); + + if GetFileSecurity(PChar(aFileName), OWNER_SECURITY_INFORMATION or GROUP_SECURITY_INFORMATION or DACL_SECURITY_INFORMATION, SecDesc, SecDescSize, SecDescSize) then + begin + ImpersonateSelf(SecurityImpersonation); + OpenThreadToken(GetCurrentThread, TOKEN_QUERY, False, Token); + if Token <> 0 then + begin + Mapping.GenericRead := FILE_GENERIC_READ; + Mapping.GenericWrite := FILE_GENERIC_WRITE; + Mapping.GenericExecute := FILE_GENERIC_EXECUTE; + Mapping.GenericAll := FILE_ALL_ACCESS; + + MapGenericMask(Access, Mapping); + PrivSetSize := SizeOf(PrivSet); + AccessCheck(SecDesc, Token, aCheckedAccess, Mapping, PrivSet, PrivSetSize, Access, Status); + CloseHandle(Token); + if Status then + Result := Access; + end; + end; + + FreeMem(SecDesc, SecDescSize); +end; +{$ENDIF} + + +// Check game execution dir generic permissions +procedure CheckFolderPermission(const aPath: string; var aRead, aWrite, aExec: Boolean); +begin + {$IFDEF ANDROID} + raise Exception.Create('KM_FileIO: CheckFolderPermission is unsupported on Android'); + {$ELSE} + {$IFDEF WDC} + aRead := (CheckFileAccess(aPath, FILE_GENERIC_READ) = FILE_GENERIC_READ); + aWrite := (CheckFileAccess(aPath, FILE_GENERIC_WRITE) = FILE_GENERIC_WRITE); + aExec := (CheckFileAccess(aPath, FILE_GENERIC_EXECUTE) = FILE_GENERIC_EXECUTE); + {$ENDIF} + {$IFDEF FPC} + // No folder permissions check for FPC yet + aRead := True; + aWrite := True; + aExec := True; + {$ENDIF} + {$ENDIF} +end; + + +procedure KMCreateEmptyFile(const aFilePath: UnicodeString); +var + ft: TextFile; +begin + if FileExists(aFilePath) then Exit; + + AssignFile(ft, aFilePath); + Rewrite(ft); + CloseFile(ft); +end; + + +end.