Commit 1f22c13aaf9e14ec8235d3bf7b56165bee5cad38

Authored by Carlos Picanco
1 parent 5854ffe7
Exists in master

add a copy of regdata from stimulus control project

- https://github.com/cpicanco/stimulus_control/blob/9846941d5cb375fa578a7063a438082c8a75e29a/units/regdata.pas
Showing 1 changed file with 145 additions and 0 deletions   Show diff stats
experiment_runner/units/regdata.pas 0 → 100644
... ... @@ -0,0 +1,145 @@
  1 +{
  2 + Free-mtrix - Free cultural selection and social behavior experiments.
  3 + Copyright (C) 2007-2017 Carlos Rafael Fernandes Picanço, Universidade Federal do Pará.
  4 +
  5 + The present file is distributed under the terms of the GNU General Public License (GPL v3.0).
  6 +
  7 + You should have received a copy of the GNU General Public License
  8 + along with this program. If not, see <http://www.gnu.org/licenses/>.
  9 +}
  10 +unit regdata;
  11 +
  12 +{$mode objfpc}{$H+}
  13 +
  14 +interface
  15 +
  16 +uses SysUtils, Classes, LazFileUtils;
  17 +
  18 +type
  19 +
  20 + { TRegData }
  21 +
  22 + TRegData = class(TComponent)
  23 + private
  24 + FFileName: string;
  25 + FFile: TextFile;
  26 + FSessionNumber: integer;
  27 + procedure Close;
  28 + procedure UpdateFileName(ANewFileName : string);
  29 + function OpenNoOverride(AFilename : string):string;
  30 + public
  31 + constructor Create(AOwner: TComponent; AFileName: String); reintroduce;
  32 + destructor Destroy; override;
  33 + procedure SaveData(AData: string);
  34 + procedure CloseAndOpen;
  35 + procedure AppendF;
  36 + procedure AssignFFile;
  37 + procedure CloseFFile;
  38 + property SessionNumber : integer read FSessionNumber write FSessionNumber;
  39 + property DataFile : TextFile read FFile write FFile;
  40 + property FileName : string read FFileName write UpdateFileName;
  41 + end;
  42 +
  43 +implementation
  44 +
  45 + {
  46 + Do not use the DebugLn inside this unit
  47 + it will create a circular reference.
  48 + use writeln instead.
  49 + }
  50 +
  51 +{$ifdef DEBUG}
  52 + uses Dialogs
  53 + , debug_logger
  54 + ;
  55 +{$endif}
  56 +
  57 +procedure TRegData.Close;
  58 +begin
  59 + if FFilename <> '' then
  60 + if TextRec(FFile).Mode = 55218 then // file is opened either read or write
  61 + begin
  62 + CloseFile(FFile);
  63 + end
  64 +end;
  65 +
  66 +procedure TRegData.UpdateFileName(ANewFileName: string);
  67 +begin
  68 + if (ANewFileName = '') or (ANewFileName = FFilename) then Exit;
  69 + Close;
  70 + FFileName := OpenNoOverride(ANewFileName);
  71 +end;
  72 +
  73 +function TRegData.OpenNoOverride(AFilename: string): string;
  74 +var
  75 + i : Integer;
  76 + FilePath, LExtension: string;
  77 +begin
  78 + if AFileName <> '' then
  79 + begin
  80 + ForceDirectoriesUTF8(ExtractFilePath(AFilename));
  81 + FilePath := ExtractFilePath(AFilename);
  82 + LExtension := ExtractFileExt(AFilename);
  83 + i := 0;
  84 +
  85 + // ensure to never override an exinting file
  86 + while FileExistsUTF8(AFilename) do begin
  87 + Inc(i);
  88 + AFilename := FilePath + StringOfChar(#48, 3 - Length(IntToStr(i))) + IntToStr(i) + LExtension;
  89 + end;
  90 +
  91 + FSessionNumber := i;
  92 +
  93 + // as override is impossible, don't mind about an Assign/Rewrite conditional
  94 + AssignFile(FFile, AFilename);
  95 + Rewrite(FFile);
  96 + {$ifdef DEBUG}
  97 + WriteLn(FFile, mt_Debug + 'Saving data to:' + AFilename );
  98 + {$endif}
  99 + Result := AFilename;
  100 + end;
  101 +end;
  102 +
  103 +constructor TRegData.Create(AOwner: TComponent; AFileName: String);
  104 +begin
  105 + inherited Create(AOwner);
  106 + FFilename := OpenNoOverride(AFilename);
  107 +end;
  108 +
  109 +destructor TRegData.Destroy;
  110 +// With the current implementation
  111 +// if undefined DEBUG, CloseFile should be called only once
  112 +begin
  113 + Close;
  114 + inherited Destroy;
  115 +end;
  116 +
  117 +procedure TRegData.SaveData(AData: string);
  118 +begin
  119 + Write(FFile, AData);
  120 +end;
  121 +
  122 +procedure TRegData.CloseAndOpen;
  123 +begin
  124 + Flush(FFile);
  125 + Append(FFile);
  126 +end;
  127 +
  128 +procedure TRegData.AppendF;
  129 +begin
  130 + Append(FFile);
  131 +end;
  132 +
  133 +procedure TRegData.AssignFFile;
  134 +begin
  135 + AssignFile(FFile, FFileName);
  136 +end;
  137 +
  138 +procedure TRegData.CloseFFile;
  139 +begin
  140 + CloseFile(FFile);
  141 +end;
  142 +
  143 +
  144 +end.
  145 +
... ...