← Back to branch summary

~ubuntu-branches/ubuntu/quantal/transgui/quantal-proposed

« back to all changes in this revision

Viewing changes to synapse/source/lib/ftptsend.pas

  • Committer: Bazaar Package Importer
  • Author(s): Andreas Noteng
  • Date: 2011-04-30 19:43:19 UTC
  • mfrom: (1.1.2 upstream)
  • Revision ID: james.westby@ubuntu.com-20110430194319-umpkh5ud1mjousbq
Tags: 3.1+svn607-1
http://bugs.debian.org/620713
* New upstream version
* Update with upstream svn revision 607 to correctly build with
  fpc-2.4.2 and lazarus-0.9.30 (Closes: #620713)
* Bump Standards-Version to 3.9.2 (no change)

Show diffs side-by-side

added added

removed removed

Lines of Context:
synapse/source/lib/ftptsend.pas
1
 
{==============================================================================|
2
 
| Project : Ararat Synapse                                       | 001.001.001 |
3
 
|==============================================================================|
4
 
| Content: Trivial FTP (TFTP) client and server                                |
5
 
|==============================================================================|
6
 
| Copyright (c)1999-2010, Lukas Gebauer                                        |
7
 
| All rights reserved.                                                         |
8
 
|                                                                              |
9
 
| Redistribution and use in source and binary forms, with or without           |
10
 
| modification, are permitted provided that the following conditions are met:  |
11
 
|                                                                              |
12
 
| Redistributions of source code must retain the above copyright notice, this  |
13
 
| list of conditions and the following disclaimer.                             |
14
 
|                                                                              |
15
 
| Redistributions in binary form must reproduce the above copyright notice,    |
16
 
| this list of conditions and the following disclaimer in the documentation    |
17
 
| and/or other materials provided with the distribution.                       |
18
 
|                                                                              |
19
 
| Neither the name of Lukas Gebauer nor the names of its contributors may      |
20
 
| be used to endorse or promote products derived from this software without    |
21
 
| specific prior written permission.                                           |
22
 
|                                                                              |
23
 
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
24
 
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
25
 
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
26
 
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
27
 
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
28
 
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
29
 
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
30
 
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
31
 
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
32
 
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
33
 
| DAMAGE.                                                                      |
34
 
|==============================================================================|
35
 
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
36
 
| Portions created by Lukas Gebauer are Copyright (c)2003-2010.                |
37
 
| All Rights Reserved.                                                         |
38
 
|==============================================================================|
39
 
| Contributor(s):                                                              |
40
 
|==============================================================================|
41
 
| History: see HISTORY.HTM from distribution package                           |
42
 
|          (Found at URL: http://www.ararat.cz/synapse/)                       |
43
 
|==============================================================================}
44
 
 
45
 
{: @abstract(TFTP client and server protocol)
46
 
 
47
 
Used RFC: RFC-1350
48
 
}
49
 
 
50
 
{$IFDEF FPC}
51
 
  {$MODE DELPHI}
52
 
{$ENDIF}
53
 
{$Q-}
54
 
{$H+}
55
 
 
56
 
{$IFDEF UNICODE}
57
 
  {$WARN IMPLICIT_STRING_CAST OFF}
58
 
  {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
59
 
{$ENDIF}
60
 
 
61
 
unit ftptsend;
62
 
 
63
 
interface
64
 
 
65
 
uses
66
 
  SysUtils, Classes,
67
 
  blcksock, synautil;
68
 
 
69
 
const
70
 
  cTFTPProtocol = '69';
71
 
 
72
 
  cTFTP_RRQ = word(1);
73
 
  cTFTP_WRQ = word(2);
74
 
  cTFTP_DTA = word(3);
75
 
  cTFTP_ACK = word(4);
76
 
  cTFTP_ERR = word(5);
77
 
 
78
 
type
79
 
  {:@abstract(Implementation of TFTP client and server)
80
 
   Note: Are you missing properties for specify server address and port? Look to
81
 
   parent @link(TSynaClient) too!}
82
 
  TTFTPSend = class(TSynaClient)
83
 
  private
84
 
    FSock: TUDPBlockSocket;
85
 
    FErrorCode: integer;
86
 
    FErrorString: string;
87
 
    FData: TMemoryStream;
88
 
    FRequestIP: string;
89
 
    FRequestPort: string;
90
 
    function SendPacket(Cmd: word; Serial: word; const Value: string): Boolean;
91
 
    function RecvPacket(Serial: word; var Value: string): Boolean;
92
 
  public
93
 
    constructor Create;
94
 
    destructor Destroy; override;
95
 
 
96
 
    {:Upload @link(data) as file to TFTP server.}
97
 
    function SendFile(const Filename: string): Boolean;
98
 
 
99
 
    {:Download file from TFTP server to @link(data).}
100
 
    function RecvFile(const Filename: string): Boolean;
101
 
 
102
 
    {:Acts as TFTP server and wait for client request. When some request
103
 
     incoming within Timeout, result is @true and parametres is filled with
104
 
     information from request. You must handle this request, validate it, and
105
 
     call @link(ReplyError), @link(ReplyRecv) or @link(ReplySend) for send reply
106
 
     to TFTP Client.}
107
 
    function WaitForRequest(var Req: word; var filename: string): Boolean;
108
 
 
109
 
    {:send error to TFTP client, when you acts as TFTP server.}
110
 
    procedure ReplyError(Error: word; Description: string);
111
 
 
112
 
    {:Accept uploaded file from TFTP client to @link(data), when you acts as
113
 
     TFTP server.}
114
 
    function ReplyRecv: Boolean;
115
 
 
116
 
    {:Accept download request file from TFTP client and send content of
117
 
     @link(data), when you acts as TFTP server.}
118
 
    function ReplySend: Boolean;
119
 
  published
120
 
    {:Code of TFTP error.}
121
 
    property ErrorCode: integer read FErrorCode;
122
 
 
123
 
    {:Human readable decription of TFTP error. (if is sended by remote side)}
124
 
    property ErrorString: string read FErrorString;
125
 
 
126
 
    {:MemoryStream with datas for sending or receiving}
127
 
    property Data: TMemoryStream read FData;
128
 
 
129
 
    {:Address of TFTP remote side.}
130
 
    property RequestIP: string read FRequestIP write FRequestIP;
131
 
 
132
 
    {:Port of TFTP remote side.}
133
 
    property RequestPort: string read FRequestPort write FRequestPort;
134
 
  end;
135
 
 
136
 
implementation
137
 
 
138
 
constructor TTFTPSend.Create;
139
 
begin
140
 
  inherited Create;
141
 
  FSock := TUDPBlockSocket.Create;
142
 
  FSock.Owner := self;
143
 
  FTargetPort := cTFTPProtocol;
144
 
  FData := TMemoryStream.Create;
145
 
  FErrorCode := 0;
146
 
  FErrorString := '';
147
 
end;
148
 
 
149
 
destructor TTFTPSend.Destroy;
150
 
begin
151
 
  FSock.Free;
152
 
  FData.Free;
153
 
  inherited Destroy;
154
 
end;
155
 
 
156
 
function TTFTPSend.SendPacket(Cmd: word; Serial: word; const Value: string): Boolean;
157
 
var
158
 
  s, sh: string;
159
 
begin
160
 
  FErrorCode := 0;
161
 
  FErrorString := '';
162
 
  Result := false;
163
 
  if Cmd <> 2 then
164
 
    s := CodeInt(Cmd) + CodeInt(Serial) + Value
165
 
  else
166
 
    s := CodeInt(Cmd) + Value;
167
 
  FSock.SendString(s);
168
 
  s := FSock.RecvPacket(FTimeout);
169
 
  if FSock.LastError = 0 then
170
 
    if length(s) >= 4 then
171
 
    begin
172
 
      sh := CodeInt(4) + CodeInt(Serial);
173
 
      if Pos(sh, s) = 1 then
174
 
        Result := True
175
 
      else
176
 
        if s[1] = #5 then
177
 
        begin
178
 
          FErrorCode := DecodeInt(s, 3);
179
 
          Delete(s, 1, 4);
180
 
          FErrorString := SeparateLeft(s, #0);
181
 
        end;
182
 
    end;
183
 
end;
184
 
 
185
 
function TTFTPSend.RecvPacket(Serial: word; var Value: string): Boolean;
186
 
var
187
 
  s: string;
188
 
  ser: word;
189
 
begin
190
 
  FErrorCode := 0;
191
 
  FErrorString := '';
192
 
  Result := False;
193
 
  Value := '';
194
 
  s := FSock.RecvPacket(FTimeout);
195
 
  if FSock.LastError = 0 then
196
 
    if length(s) >= 4 then
197
 
      if DecodeInt(s, 1) = 3 then
198
 
      begin
199
 
        ser := DecodeInt(s, 3);
200
 
        if ser = Serial then
201
 
        begin
202
 
          Delete(s, 1, 4);
203
 
          Value := s;
204
 
          S := CodeInt(4) + CodeInt(ser);
205
 
          FSock.SendString(s);
206
 
          Result := FSock.LastError = 0;
207
 
        end
208
 
        else
209
 
        begin
210
 
          S := CodeInt(5) + CodeInt(5) + 'Unexcepted serial#' + #0;
211
 
          FSock.SendString(s);
212
 
        end;
213
 
      end;
214
 
      if DecodeInt(s, 1) = 5 then
215
 
      begin
216
 
        FErrorCode := DecodeInt(s, 3);
217
 
        Delete(s, 1, 4);
218
 
        FErrorString := SeparateLeft(s, #0);
219
 
      end;
220
 
end;
221
 
 
222
 
function TTFTPSend.SendFile(const Filename: string): Boolean;
223
 
var
224
 
  s: string;
225
 
  ser: word;
226
 
  n, n1, n2: integer;
227
 
begin
228
 
  Result := False;
229
 
  FErrorCode := 0;
230
 
  FErrorString := '';
231
 
  FSock.CloseSocket;
232
 
  FSock.Connect(FTargetHost, FTargetPort);
233
 
  try
234
 
    if FSock.LastError = 0 then
235
 
    begin
236
 
      s := Filename + #0 + 'octet' + #0;
237
 
      if not Sendpacket(2, 0, s) then
238
 
        Exit;
239
 
      ser := 1;
240
 
      FData.Position := 0;
241
 
      n1 := FData.Size div 512;
242
 
      n2 := FData.Size mod 512;
243
 
      for n := 1 to n1 do
244
 
      begin
245
 
        s := ReadStrFromStream(FData, 512);
246
 
//        SetLength(s, 512);
247
 
//        FData.Read(pointer(s)^, 512);
248
 
        if not Sendpacket(3, ser, s) then
249
 
          Exit;
250
 
        inc(ser);
251
 
      end;
252
 
      s := ReadStrFromStream(FData, n2);
253
 
//      SetLength(s, n2);
254
 
//      FData.Read(pointer(s)^, n2);
255
 
      if not Sendpacket(3, ser, s) then
256
 
        Exit;
257
 
      Result := True;
258
 
    end;
259
 
  finally
260
 
    FSock.CloseSocket;
261
 
  end;
262
 
end;
263
 
 
264
 
function TTFTPSend.RecvFile(const Filename: string): Boolean;
265
 
var
266
 
  s: string;
267
 
  ser: word;
268
 
begin
269
 
  Result := False;
270
 
  FErrorCode := 0;
271
 
  FErrorString := '';
272
 
  FSock.CloseSocket;
273
 
  FSock.Connect(FTargetHost, FTargetPort);
274
 
  try
275
 
    if FSock.LastError = 0 then
276
 
    begin
277
 
      s := CodeInt(1) + Filename + #0 + 'octet' + #0;
278
 
      FSock.SendString(s);
279
 
      if FSock.LastError <> 0 then
280
 
        Exit;
281
 
      FData.Clear;
282
 
      ser := 1;
283
 
      repeat
284
 
        if not RecvPacket(ser, s) then
285
 
          Exit;
286
 
        inc(ser);
287
 
        WriteStrToStream(FData, s);
288
 
//        FData.Write(pointer(s)^, length(s));
289
 
      until length(s) <> 512;
290
 
      FData.Position := 0;
291
 
      Result := true;
292
 
    end;
293
 
  finally
294
 
    FSock.CloseSocket;
295
 
  end;
296
 
end;
297
 
 
298
 
function TTFTPSend.WaitForRequest(var Req: word; var filename: string): Boolean;
299
 
var
300
 
  s: string;
301
 
begin
302
 
  Result := False;
303
 
  FErrorCode := 0;
304
 
  FErrorString := '';
305
 
  FSock.CloseSocket;
306
 
  FSock.Bind('0.0.0.0', FTargetPort);
307
 
  if FSock.LastError = 0 then
308
 
  begin
309
 
    s := FSock.RecvPacket(FTimeout);
310
 
    if FSock.LastError = 0 then
311
 
      if Length(s) >= 4 then
312
 
      begin
313
 
        FRequestIP := FSock.GetRemoteSinIP;
314
 
        FRequestPort := IntToStr(FSock.GetRemoteSinPort);
315
 
        Req := DecodeInt(s, 1);
316
 
        delete(s, 1, 2);
317
 
        filename := Trim(SeparateLeft(s, #0));
318
 
        s := SeparateRight(s, #0);
319
 
        s := SeparateLeft(s, #0);
320
 
        Result := lowercase(trim(s)) = 'octet';
321
 
      end;
322
 
  end;
323
 
end;
324
 
 
325
 
procedure TTFTPSend.ReplyError(Error: word; Description: string);
326
 
var
327
 
  s: string;
328
 
begin
329
 
  FSock.CloseSocket;
330
 
  FSock.Connect(FRequestIP, FRequestPort);
331
 
  s := CodeInt(5) + CodeInt(Error) + Description + #0;
332
 
  FSock.SendString(s);
333
 
  FSock.CloseSocket;
334
 
end;
335
 
 
336
 
function TTFTPSend.ReplyRecv: Boolean;
337
 
var
338
 
  s: string;
339
 
  ser: integer;
340
 
begin
341
 
  Result := False;
342
 
  FErrorCode := 0;
343
 
  FErrorString := '';
344
 
  FSock.CloseSocket;
345
 
  FSock.Connect(FRequestIP, FRequestPort);
346
 
  try
347
 
    s := CodeInt(4) + CodeInt(0);
348
 
    FSock.SendString(s);
349
 
    FData.Clear;
350
 
    ser := 1;
351
 
    repeat
352
 
      if not RecvPacket(ser, s) then
353
 
        Exit;
354
 
      inc(ser);
355
 
      WriteStrToStream(FData, s);
356
 
//      FData.Write(pointer(s)^, length(s));
357
 
    until length(s) <> 512;
358
 
    FData.Position := 0;
359
 
    Result := true;
360
 
  finally
361
 
    FSock.CloseSocket;
362
 
  end;
363
 
end;
364
 
 
365
 
function TTFTPSend.ReplySend: Boolean;
366
 
var
367
 
  s: string;
368
 
  ser: word;
369
 
  n, n1, n2: integer;
370
 
begin
371
 
  Result := False;
372
 
  FErrorCode := 0;
373
 
  FErrorString := '';
374
 
  FSock.CloseSocket;
375
 
  FSock.Connect(FRequestIP, FRequestPort);
376
 
  try
377
 
    ser := 1;
378
 
    FData.Position := 0;
379
 
    n1 := FData.Size div 512;
380
 
    n2 := FData.Size mod 512;
381
 
    for n := 1 to n1 do
382
 
    begin
383
 
      s := ReadStrFromStream(FData, 512);
384
 
//      SetLength(s, 512);
385
 
//      FData.Read(pointer(s)^, 512);
386
 
      if not Sendpacket(3, ser, s) then
387
 
        Exit;
388
 
      inc(ser);
389
 
    end;
390
 
    s := ReadStrFromStream(FData, n2);
391
 
//    SetLength(s, n2);
392
 
//    FData.Read(pointer(s)^, n2);
393
 
    if not Sendpacket(3, ser, s) then
394
 
      Exit;
395
 
    Result := True;
396
 
  finally
397
 
    FSock.CloseSocket;
398
 
  end;
399
 
end;
400
 
 
401
 
{==============================================================================}
402
 
 
403
 
end.
 
1
{==============================================================================|
 
2
| Project : Ararat Synapse                                       | 001.001.001 |
 
3
|==============================================================================|
 
4
| Content: Trivial FTP (TFTP) client and server                                |
 
5
|==============================================================================|
 
6
| Copyright (c)1999-2010, Lukas Gebauer                                        |
 
7
| All rights reserved.                                                         |
 
8
|                                                                              |
 
9
| Redistribution and use in source and binary forms, with or without           |
 
10
| modification, are permitted provided that the following conditions are met:  |
 
11
|                                                                              |
 
12
| Redistributions of source code must retain the above copyright notice, this  |
 
13
| list of conditions and the following disclaimer.                             |
 
14
|                                                                              |
 
15
| Redistributions in binary form must reproduce the above copyright notice,    |
 
16
| this list of conditions and the following disclaimer in the documentation    |
 
17
| and/or other materials provided with the distribution.                       |
 
18
|                                                                              |
 
19
| Neither the name of Lukas Gebauer nor the names of its contributors may      |
 
20
| be used to endorse or promote products derived from this software without    |
 
21
| specific prior written permission.                                           |
 
22
|                                                                              |
 
23
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
 
24
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
 
25
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
 
26
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
 
27
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
 
28
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
 
29
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
 
30
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
 
31
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
 
32
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
 
33
| DAMAGE.                                                                      |
 
34
|==============================================================================|
 
35
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
 
36
| Portions created by Lukas Gebauer are Copyright (c)2003-2010.                |
 
37
| All Rights Reserved.                                                         |
 
38
|==============================================================================|
 
39
| Contributor(s):                                                              |
 
40
|==============================================================================|
 
41
| History: see HISTORY.HTM from distribution package                           |
 
42
|          (Found at URL: http://www.ararat.cz/synapse/)                       |
 
43
|==============================================================================}
 
44
 
 
45
{: @abstract(TFTP client and server protocol)
 
46
 
 
47
Used RFC: RFC-1350
 
48
}
 
49
 
 
50
{$IFDEF FPC}
 
51
  {$MODE DELPHI}
 
52
{$ENDIF}
 
53
{$Q-}
 
54
{$H+}
 
55
 
 
56
{$IFDEF UNICODE}
 
57
  {$WARN IMPLICIT_STRING_CAST OFF}
 
58
  {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
 
59
{$ENDIF}
 
60
 
 
61
unit ftptsend;
 
62
 
 
63
interface
 
64
 
 
65
uses
 
66
  SysUtils, Classes,
 
67
  blcksock, synautil;
 
68
 
 
69
const
 
70
  cTFTPProtocol = '69';
 
71
 
 
72
  cTFTP_RRQ = word(1);
 
73
  cTFTP_WRQ = word(2);
 
74
  cTFTP_DTA = word(3);
 
75
  cTFTP_ACK = word(4);
 
76
  cTFTP_ERR = word(5);
 
77
 
 
78
type
 
79
  {:@abstract(Implementation of TFTP client and server)
 
80
   Note: Are you missing properties for specify server address and port? Look to
 
81
   parent @link(TSynaClient) too!}
 
82
  TTFTPSend = class(TSynaClient)
 
83
  private
 
84
    FSock: TUDPBlockSocket;
 
85
    FErrorCode: integer;
 
86
    FErrorString: string;
 
87
    FData: TMemoryStream;
 
88
    FRequestIP: string;
 
89
    FRequestPort: string;
 
90
    function SendPacket(Cmd: word; Serial: word; const Value: string): Boolean;
 
91
    function RecvPacket(Serial: word; var Value: string): Boolean;
 
92
  public
 
93
    constructor Create;
 
94
    destructor Destroy; override;
 
95
 
 
96
    {:Upload @link(data) as file to TFTP server.}
 
97
    function SendFile(const Filename: string): Boolean;
 
98
 
 
99
    {:Download file from TFTP server to @link(data).}
 
100
    function RecvFile(const Filename: string): Boolean;
 
101
 
 
102
    {:Acts as TFTP server and wait for client request. When some request
 
103
     incoming within Timeout, result is @true and parametres is filled with
 
104
     information from request. You must handle this request, validate it, and
 
105
     call @link(ReplyError), @link(ReplyRecv) or @link(ReplySend) for send reply
 
106
     to TFTP Client.}
 
107
    function WaitForRequest(var Req: word; var filename: string): Boolean;
 
108
 
 
109
    {:send error to TFTP client, when you acts as TFTP server.}
 
110
    procedure ReplyError(Error: word; Description: string);
 
111
 
 
112
    {:Accept uploaded file from TFTP client to @link(data), when you acts as
 
113
     TFTP server.}
 
114
    function ReplyRecv: Boolean;
 
115
 
 
116
    {:Accept download request file from TFTP client and send content of
 
117
     @link(data), when you acts as TFTP server.}
 
118
    function ReplySend: Boolean;
 
119
  published
 
120
    {:Code of TFTP error.}
 
121
    property ErrorCode: integer read FErrorCode;
 
122
 
 
123
    {:Human readable decription of TFTP error. (if is sended by remote side)}
 
124
    property ErrorString: string read FErrorString;
 
125
 
 
126
    {:MemoryStream with datas for sending or receiving}
 
127
    property Data: TMemoryStream read FData;
 
128
 
 
129
    {:Address of TFTP remote side.}
 
130
    property RequestIP: string read FRequestIP write FRequestIP;
 
131
 
 
132
    {:Port of TFTP remote side.}
 
133
    property RequestPort: string read FRequestPort write FRequestPort;
 
134
  end;
 
135
 
 
136
implementation
 
137
 
 
138
constructor TTFTPSend.Create;
 
139
begin
 
140
  inherited Create;
 
141
  FSock := TUDPBlockSocket.Create;
 
142
  FSock.Owner := self;
 
143
  FTargetPort := cTFTPProtocol;
 
144
  FData := TMemoryStream.Create;
 
145
  FErrorCode := 0;
 
146
  FErrorString := '';
 
147
end;
 
148
 
 
149
destructor TTFTPSend.Destroy;
 
150
begin
 
151
  FSock.Free;
 
152
  FData.Free;
 
153
  inherited Destroy;
 
154
end;
 
155
 
 
156
function TTFTPSend.SendPacket(Cmd: word; Serial: word; const Value: string): Boolean;
 
157
var
 
158
  s, sh: string;
 
159
begin
 
160
  FErrorCode := 0;
 
161
  FErrorString := '';
 
162
  Result := false;
 
163
  if Cmd <> 2 then
 
164
    s := CodeInt(Cmd) + CodeInt(Serial) + Value
 
165
  else
 
166
    s := CodeInt(Cmd) + Value;
 
167
  FSock.SendString(s);
 
168
  s := FSock.RecvPacket(FTimeout);
 
169
  if FSock.LastError = 0 then
 
170
    if length(s) >= 4 then
 
171
    begin
 
172
      sh := CodeInt(4) + CodeInt(Serial);
 
173
      if Pos(sh, s) = 1 then
 
174
        Result := True
 
175
      else
 
176
        if s[1] = #5 then
 
177
        begin
 
178
          FErrorCode := DecodeInt(s, 3);
 
179
          Delete(s, 1, 4);
 
180
          FErrorString := SeparateLeft(s, #0);
 
181
        end;
 
182
    end;
 
183
end;
 
184
 
 
185
function TTFTPSend.RecvPacket(Serial: word; var Value: string): Boolean;
 
186
var
 
187
  s: string;
 
188
  ser: word;
 
189
begin
 
190
  FErrorCode := 0;
 
191
  FErrorString := '';
 
192
  Result := False;
 
193
  Value := '';
 
194
  s := FSock.RecvPacket(FTimeout);
 
195
  if FSock.LastError = 0 then
 
196
    if length(s) >= 4 then
 
197
      if DecodeInt(s, 1) = 3 then
 
198
      begin
 
199
        ser := DecodeInt(s, 3);
 
200
        if ser = Serial then
 
201
        begin
 
202
          Delete(s, 1, 4);
 
203
          Value := s;
 
204
          S := CodeInt(4) + CodeInt(ser);
 
205
          FSock.SendString(s);
 
206
          Result := FSock.LastError = 0;
 
207
        end
 
208
        else
 
209
        begin
 
210
          S := CodeInt(5) + CodeInt(5) + 'Unexcepted serial#' + #0;
 
211
          FSock.SendString(s);
 
212
        end;
 
213
      end;
 
214
      if DecodeInt(s, 1) = 5 then
 
215
      begin
 
216
        FErrorCode := DecodeInt(s, 3);
 
217
        Delete(s, 1, 4);
 
218
        FErrorString := SeparateLeft(s, #0);
 
219
      end;
 
220
end;
 
221
 
 
222
function TTFTPSend.SendFile(const Filename: string): Boolean;
 
223
var
 
224
  s: string;
 
225
  ser: word;
 
226
  n, n1, n2: integer;
 
227
begin
 
228
  Result := False;
 
229
  FErrorCode := 0;
 
230
  FErrorString := '';
 
231
  FSock.CloseSocket;
 
232
  FSock.Connect(FTargetHost, FTargetPort);
 
233
  try
 
234
    if FSock.LastError = 0 then
 
235
    begin
 
236
      s := Filename + #0 + 'octet' + #0;
 
237
      if not Sendpacket(2, 0, s) then
 
238
        Exit;
 
239
      ser := 1;
 
240
      FData.Position := 0;
 
241
      n1 := FData.Size div 512;
 
242
      n2 := FData.Size mod 512;
 
243
      for n := 1 to n1 do
 
244
      begin
 
245
        s := ReadStrFromStream(FData, 512);
 
246
//        SetLength(s, 512);
 
247
//        FData.Read(pointer(s)^, 512);
 
248
        if not Sendpacket(3, ser, s) then
 
249
          Exit;
 
250
        inc(ser);
 
251
      end;
 
252
      s := ReadStrFromStream(FData, n2);
 
253
//      SetLength(s, n2);
 
254
//      FData.Read(pointer(s)^, n2);
 
255
      if not Sendpacket(3, ser, s) then
 
256
        Exit;
 
257
      Result := True;
 
258
    end;
 
259
  finally
 
260
    FSock.CloseSocket;
 
261
  end;
 
262
end;
 
263
 
 
264
function TTFTPSend.RecvFile(const Filename: string): Boolean;
 
265
var
 
266
  s: string;
 
267
  ser: word;
 
268
begin
 
269
  Result := False;
 
270
  FErrorCode := 0;
 
271
  FErrorString := '';
 
272
  FSock.CloseSocket;
 
273
  FSock.Connect(FTargetHost, FTargetPort);
 
274
  try
 
275
    if FSock.LastError = 0 then
 
276
    begin
 
277
      s := CodeInt(1) + Filename + #0 + 'octet' + #0;
 
278
      FSock.SendString(s);
 
279
      if FSock.LastError <> 0 then
 
280
        Exit;
 
281
      FData.Clear;
 
282
      ser := 1;
 
283
      repeat
 
284
        if not RecvPacket(ser, s) then
 
285
          Exit;
 
286
        inc(ser);
 
287
        WriteStrToStream(FData, s);
 
288
//        FData.Write(pointer(s)^, length(s));
 
289
      until length(s) <> 512;
 
290
      FData.Position := 0;
 
291
      Result := true;
 
292
    end;
 
293
  finally
 
294
    FSock.CloseSocket;
 
295
  end;
 
296
end;
 
297
 
 
298
function TTFTPSend.WaitForRequest(var Req: word; var filename: string): Boolean;
 
299
var
 
300
  s: string;
 
301
begin
 
302
  Result := False;
 
303
  FErrorCode := 0;
 
304
  FErrorString := '';
 
305
  FSock.CloseSocket;
 
306
  FSock.Bind('0.0.0.0', FTargetPort);
 
307
  if FSock.LastError = 0 then
 
308
  begin
 
309
    s := FSock.RecvPacket(FTimeout);
 
310
    if FSock.LastError = 0 then
 
311
      if Length(s) >= 4 then
 
312
      begin
 
313
        FRequestIP := FSock.GetRemoteSinIP;
 
314
        FRequestPort := IntToStr(FSock.GetRemoteSinPort);
 
315
        Req := DecodeInt(s, 1);
 
316
        delete(s, 1, 2);
 
317
        filename := Trim(SeparateLeft(s, #0));
 
318
        s := SeparateRight(s, #0);
 
319
        s := SeparateLeft(s, #0);
 
320
        Result := lowercase(trim(s)) = 'octet';
 
321
      end;
 
322
  end;
 
323
end;
 
324
 
 
325
procedure TTFTPSend.ReplyError(Error: word; Description: string);
 
326
var
 
327
  s: string;
 
328
begin
 
329
  FSock.CloseSocket;
 
330
  FSock.Connect(FRequestIP, FRequestPort);
 
331
  s := CodeInt(5) + CodeInt(Error) + Description + #0;
 
332
  FSock.SendString(s);
 
333
  FSock.CloseSocket;
 
334
end;
 
335
 
 
336
function TTFTPSend.ReplyRecv: Boolean;
 
337
var
 
338
  s: string;
 
339
  ser: integer;
 
340
begin
 
341
  Result := False;
 
342
  FErrorCode := 0;
 
343
  FErrorString := '';
 
344
  FSock.CloseSocket;
 
345
  FSock.Connect(FRequestIP, FRequestPort);
 
346
  try
 
347
    s := CodeInt(4) + CodeInt(0);
 
348
    FSock.SendString(s);
 
349
    FData.Clear;
 
350
    ser := 1;
 
351
    repeat
 
352
      if not RecvPacket(ser, s) then
 
353
        Exit;
 
354
      inc(ser);
 
355
      WriteStrToStream(FData, s);
 
356
//      FData.Write(pointer(s)^, length(s));
 
357
    until length(s) <> 512;
 
358
    FData.Position := 0;
 
359
    Result := true;
 
360
  finally
 
361
    FSock.CloseSocket;
 
362
  end;
 
363
end;
 
364
 
 
365
function TTFTPSend.ReplySend: Boolean;
 
366
var
 
367
  s: string;
 
368
  ser: word;
 
369
  n, n1, n2: integer;
 
370
begin
 
371
  Result := False;
 
372
  FErrorCode := 0;
 
373
  FErrorString := '';
 
374
  FSock.CloseSocket;
 
375
  FSock.Connect(FRequestIP, FRequestPort);
 
376
  try
 
377
    ser := 1;
 
378
    FData.Position := 0;
 
379
    n1 := FData.Size div 512;
 
380
    n2 := FData.Size mod 512;
 
381
    for n := 1 to n1 do
 
382
    begin
 
383
      s := ReadStrFromStream(FData, 512);
 
384
//      SetLength(s, 512);
 
385
//      FData.Read(pointer(s)^, 512);
 
386
      if not Sendpacket(3, ser, s) then
 
387
        Exit;
 
388
      inc(ser);
 
389
    end;
 
390
    s := ReadStrFromStream(FData, n2);
 
391
//    SetLength(s, n2);
 
392
//    FData.Read(pointer(s)^, n2);
 
393
    if not Sendpacket(3, ser, s) then
 
394
      Exit;
 
395
    Result := True;
 
396
  finally
 
397
    FSock.CloseSocket;
 
398
  end;
 
399
end;
 
400
 
 
401
{==============================================================================}
 
402
 
 
403
end.