1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
|
unit webmodule;
{$mode objfpc}{$H+}
interface
uses
SysUtils, Classes, httpdefs, fpHTTP, fpWeb;
type
{ TFPWebModule1 }
TFPWebModule1 = class(TFPWebModule)
procedure DataModuleAfterResponse(Sender: TObject; AResponse: TResponse);
procedure DataModuleCreate(Sender: TObject);
procedure listfilesRequest(Sender: TObject; ARequest: TRequest;
AResponse: TResponse; var Handled: Boolean);
private
{ private declarations }
UploadDir:String;
FileDB:String;
MaxSize:Integer;
procedure DeleteTheFile(const FN:String);
procedure HandleUploadedFiles;
procedure listfilesReplaceTag(Sender: TObject; const TagString:String;
TagParams: TStringList; Out ReplaceText: String);
public
{ public declarations }
end;
var
FPWebModule1: TFPWebModule1;
implementation
{$R *.lfm}
{ TFPWebModule1 }
//In real applications, CopyFile should be used from unit FileUtil of the LCL
function CopyTheFile(const SrcFilename, DestFilename: String): Boolean;
var SrcFS, DestFS: TFileStream;
begin
Result := False;
SrcFS := TFileStream.Create(SrcFilename, fmOpenRead or fmShareDenyWrite);
try
DestFS := TFileStream.Create(DestFilename, fmCreate);
try
DestFS.CopyFrom(SrcFS, SrcFS.Size);
finally
DestFS.Free;
end;
finally
SrcFS.Free;
end;
Result := True;
end;
procedure TFPWebModule1.DataModuleAfterResponse(Sender: TObject;
AResponse: TResponse);
begin
//reset global variables for apache modules for the next incoming request
//
end;
procedure TFPWebModule1.DataModuleCreate(Sender: TObject);
begin
UploadDir := 'upfiles/';
FileDB := 'filelist.txt';
MaxSize := 2;//MB
end;
procedure TFPWebModule1.DeleteTheFile(const FN:String);
var
FDB: TStringList;
s:String;
begin
FDB := TStringList.Create;
if FileExists(FileDB) then
FDB.LoadFromFile(FileDB);
s := FDB.Values[FN];
if s <> '' then
begin
FDB.Delete(FDB.IndexOfName(FN));
FDB.SaveToFile(FileDB);
FDB.Free;
end else begin
FDB.Free;
Request.QueryFields.Add('_MSG=NOTFOUND');//NOTFOUND message will be displayed on the response page
Exit;
end;
//delete the file
s := UploadDir + FN;
if FileExists(s) then
DeleteFile(s);
end;
procedure TFPWebModule1.HandleUploadedFiles;
var
i:Integer;
all_ok:Boolean;
FDB: TStringList;
Uploader, FN:String;
begin
if Request.Files.Count <= 0 then Exit;
//process the uploaded files if there was any
all_ok := true;
for i := 0 to Request.Files.Count - 1 do
begin//check sizes
if Request.Files[i].Size > (MaxSize * 1024 * 1024) then
begin//exceeds size limit
all_ok := false;
Request.QueryFields.Add('_MSG=TOOBIG');//TOOBIG message will be displayed on the response page
break;
end;
end;
if all_ok then //copy the file(s) to the upload directory (the temporary files will be deleted automatically after the request is handled)
begin
Uploader := Request.ContentFields.Values['UPLOADERPERSON'];
if Uploader = '' then
Uploader := '-';
FDB := TStringList.Create;
if FileExists(FileDB) then
FDB.LoadFromFile(FileDB);
for i := 0 to Request.Files.Count - 1 do
begin
FN := Request.Files[i].FileName;
if (FN <> '')and(Request.Files[i].Size > 0) then
begin
CopyTheFile(Request.Files[i].LocalFileName, UploadDir + FN);//copy (or overwrite) the file to the upload dir
if FDB.Values[FN] <> '' then
FDB.Values[FN] := Uploader //overwrite the previous uploader
else
FDB.Add(FN + '=' + Uploader); //store the file and the uploader into the file database
end;
end;
FDB.SaveToFile(FileDB);
FDB.Free;
end;
end;
procedure TFPWebModule1.listfilesRequest(Sender: TObject; ARequest: TRequest;
AResponse: TResponse; var Handled: Boolean);
var
FN:String;
begin
//ModuleTemplate is a web module global property
//To use the Template propery of the current web action (which is visible in
//the object inspector for every Action), use
//(Sender as TFPWebAction).Template.FileName := 'mytemplate1.html'; and so on.
ModuleTemplate.FileName := 'uploadform.html';
ModuleTemplate.AllowTagParams := true;
ModuleTemplate.StartDelimiter := '{+';
ModuleTemplate.EndDelimiter := '+}';
ModuleTemplate.OnReplaceTag := @listfilesReplaceTag;
FN := ARequest.QueryFields.Values['DELETE'];
if FN <> '' then
DeleteTheFile(FN)
else
HandleUploadedFiles;
AResponse.Content := ModuleTemplate.GetContent;//Generate the response page using the template
Handled := true;
end;
procedure TFPWebModule1.listfilesReplaceTag(Sender: TObject; const TagString:
String; TagParams: TStringList; Out ReplaceText: String);
var
SL:TStringList;
i:Integer;
FileName, Uploader, One_Row:String;
begin
if AnsiCompareText(TagString, 'DATETIME') = 0 then
begin
ReplaceText := FormatDateTime(TagParams.Values['FORMAT'], Now);
end else
if AnsiCompareText(TagString, 'MAX_SIZE') = 0 then
begin
ReplaceText := IntToStr(MaxSize);
end else
if AnsiCompareText(TagString, 'UPLOAD_DIR') = 0 then
begin
ReplaceText := UploadDir;
end else
if AnsiCompareText(TagString, 'MESSAGES') = 0 then
begin
ReplaceText := TagParams.Values[Request.QueryFields.Values['_MSG']];
end else
if AnsiCompareText(TagString, 'FILELIST') = 0 then
begin
SL := TStringList.Create;
if FileExists(FileDB) then
SL.LoadFromFile(FileDB);
if SL.Count > 0 then
begin
One_Row := TagParams.Values['ONE_ROW'];
for i := 0 to SL.Count - 1 do
begin
FileName := SL.Names[i];
Uploader := SL.Values[FileName];
if (FileName <> '')and(Uploader <> '') then
ReplaceText := ReplaceText + StringReplace(StringReplace(StringReplace(One_Row
,'~FILENAME', FileName, [])
,'~UPLOADER', Uploader, [])
,'~DFILENAME', HTTPEncode(FileName), []) + #13#10;
end;
end else begin
ReplaceText := TagParams.Values['NOTHINGTOLIST'];
end;
SL.Free;
end else
{Message for tags not handled}
begin
ReplaceText := '[Template tag {+' + TagString + '+} is not implemented yet.]';
end;
end;
initialization
RegisterHTTPModule('TFPWebModule1', TFPWebModule1);
end.
|
