add a copy of regdata from stimulus control project

- https://github.com/cpicanco/stimulus_control/blob/9846941d5cb375fa578a7063a438082c8a75e29a/units/regdata.pas

add a copy of regdata from stimulus control project
- https://github.com/cpicanco/stimulus_control/blob/9846941d5cb375fa578a7063a438082c8a75e29a/units/regdata.pas
Carlos Picanco
1 parent 5854ffe7
Showing 1 changed file with 145 additions and 0 deletions Show diff stats
experiment_runner/units/regdata.pas
@@ -0,0 +1,145 @@
+{
+  Free-mtrix - Free cultural selection and social behavior experiments.
+  Copyright (C) 2007-2017 Carlos Rafael Fernandes Picanço, Universidade Federal do Pará.
+
+  The present file is distributed under the terms of the GNU General Public License (GPL v3.0).
+
+  You should have received a copy of the GNU General Public License
+  along with this program. If not, see <http://www.gnu.org/licenses/>.
+}
+unit regdata;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses SysUtils, Classes, LazFileUtils;
+
+type
+
+  { TRegData }
+
+  TRegData = class(TComponent)
+  private
+    FFileName: string;
+    FFile: TextFile;
+    FSessionNumber: integer;
+    procedure Close;
+    procedure UpdateFileName(ANewFileName : string);
+    function OpenNoOverride(AFilename : string):string;
+  public
+    constructor Create(AOwner: TComponent; AFileName: String); reintroduce;
+    destructor Destroy; override;
+    procedure SaveData(AData: string);
+    procedure CloseAndOpen;
+    procedure AppendF;
+    procedure AssignFFile;
+    procedure CloseFFile;
+    property SessionNumber : integer read FSessionNumber write FSessionNumber;
+    property DataFile : TextFile read FFile write FFile;
+    property FileName : string read FFileName write UpdateFileName;
+  end;
+
+implementation
+
+   {
+   Do not use the DebugLn inside this unit
+   it will create a circular reference.
+   use writeln instead.
+   }
+
+{$ifdef DEBUG}
+  uses Dialogs
+    , debug_logger
+    ;
+{$endif}
+
+procedure TRegData.Close;
+begin
+  if FFilename <> '' then
+    if TextRec(FFile).Mode = 55218 then // file is opened either read or write
+      begin
+        CloseFile(FFile);
+      end
+end;
+
+procedure TRegData.UpdateFileName(ANewFileName: string);
+begin
+  if (ANewFileName = '') or (ANewFileName = FFilename) then Exit;
+  Close;
+  FFileName := OpenNoOverride(ANewFileName);
+end;
+
+function TRegData.OpenNoOverride(AFilename: string): string;
+var
+  i : Integer;
+  FilePath, LExtension: string;
+begin
+  if AFileName <> '' then
+      begin
+        ForceDirectoriesUTF8(ExtractFilePath(AFilename));
+        FilePath := ExtractFilePath(AFilename);
+        LExtension := ExtractFileExt(AFilename);
+        i := 0;
+
+        // ensure to never override an exinting file
+        while FileExistsUTF8(AFilename) do begin
+          Inc(i);
+          AFilename := FilePath + StringOfChar(#48, 3 - Length(IntToStr(i))) + IntToStr(i) + LExtension;
+        end;
+
+        FSessionNumber := i;
+
+        // as override is impossible, don't mind about an Assign/Rewrite conditional
+        AssignFile(FFile, AFilename);
+        Rewrite(FFile);
+        {$ifdef DEBUG}
+          WriteLn(FFile, mt_Debug + 'Saving data to:' + AFilename );
+        {$endif}
+        Result := AFilename;
+     end;
+end;
+
+constructor TRegData.Create(AOwner: TComponent; AFileName: String);
+begin
+  inherited Create(AOwner);
+  FFilename := OpenNoOverride(AFilename);
+end;
+
+destructor TRegData.Destroy;
+// With the current implementation
+// if undefined DEBUG, CloseFile should be called only once
+begin
+  Close;
+  inherited Destroy;
+end;
+
+procedure TRegData.SaveData(AData: string);
+begin
+  Write(FFile, AData);
+end;
+
+procedure TRegData.CloseAndOpen;
+begin
+  Flush(FFile);
+  Append(FFile);
+end;
+
+procedure TRegData.AppendF;
+begin
+  Append(FFile);
+end;
+
+procedure TRegData.AssignFFile;
+begin
+  AssignFile(FFile, FFileName);
+end;
+
+procedure TRegData.CloseFFile;
+begin
+  CloseFile(FFile);
+end;
+
+
+end.
+
...	...	@@ -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	+
...	...