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 @@ | @@ -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 | + |