Commit 1f22c13aaf9e14ec8235d3bf7b56165bee5cad38
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
... | ... | @@ -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 | + | ... | ... |