source: trunk/Demo/Packages/synapse/ftpsend.pas

Last change on this file was 60, checked in by chronos, 13 years ago
File size: 55.3 KB
Line 
1{==============================================================================|
2| Project : Ararat Synapse | 003.005.001 |
3|==============================================================================|
4| Content: FTP client |
5|==============================================================================|
6| Copyright (c)1999-2008, 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) 1999-2008. |
37| All Rights Reserved. |
38|==============================================================================|
39| Contributor(s): |
40| Petr Esner <petr.esner@atlas.cz> |
41|==============================================================================|
42| History: see HISTORY.HTM from distribution package |
43| (Found at URL: http://www.ararat.cz/synapse/) |
44|==============================================================================}
45
46{: @abstract(FTP client protocol)
47
48Used RFC: RFC-959, RFC-2228, RFC-2428
49}
50
51{$IFDEF FPC}
52 {$MODE DELPHI}
53{$ENDIF}
54{$H+}
55
56unit ftpsend;
57
58interface
59
60uses
61 SysUtils, Classes,
62 blcksock, synautil, synaip, synsock;
63
64const
65 cFtpProtocol = '21';
66 cFtpDataProtocol = '20';
67
68 {:Terminating value for TLogonActions}
69 FTP_OK = 255;
70 {:Terminating value for TLogonActions}
71 FTP_ERR = 254;
72
73type
74 {:Array for holding definition of logon sequence.}
75 TLogonActions = array [0..17] of byte;
76
77 {:Procedural type for OnStatus event. Sender is calling @link(TFTPSend) object.
78 Value is FTP command or reply to this comand. (if it is reply, Response
79 is @True).}
80 TFTPStatus = procedure(Sender: TObject; Response: Boolean;
81 const Value: string) of object;
82
83 {: @abstract(Object for holding file information) parsed from directory
84 listing of FTP server.}
85 TFTPListRec = class(TObject)
86 private
87 FFileName: string;
88 FDirectory: Boolean;
89 FReadable: Boolean;
90 FFileSize: Longint;
91 FFileTime: TDateTime;
92 FOriginalLine: string;
93 FMask: string;
94 FPermission: string;
95 public
96 {: You can assign another TFTPListRec to this object.}
97 procedure Assign(Value: TFTPListRec); virtual;
98 published
99 {:name of file}
100 property FileName: string read FFileName write FFileName;
101 {:if name is subdirectory not file.}
102 property Directory: Boolean read FDirectory write FDirectory;
103 {:if you have rights to read}
104 property Readable: Boolean read FReadable write FReadable;
105 {:size of file in bytes}
106 property FileSize: Longint read FFileSize write FFileSize;
107 {:date and time of file. Local server timezone is used. Any timezone
108 conversions was not done!}
109 property FileTime: TDateTime read FFileTime write FFileTime;
110 {:original unparsed line}
111 property OriginalLine: string read FOriginalLine write FOriginalLine;
112 {:mask what was used for parsing}
113 property Mask: string read FMask write FMask;
114 {:permission string (depending on used mask!)}
115 property Permission: string read FPermission write FPermission;
116 end;
117
118 {:@abstract(This is TList of TFTPListRec objects.)
119 This object is used for holding lististing of all files information in listed
120 directory on FTP server.}
121 TFTPList = class(TObject)
122 protected
123 FList: TList;
124 FLines: TStringList;
125 FMasks: TStringList;
126 FUnparsedLines: TStringList;
127 Monthnames: string;
128 BlockSize: string;
129 DirFlagValue: string;
130 FileName: string;
131 VMSFileName: string;
132 Day: string;
133 Month: string;
134 ThreeMonth: string;
135 YearTime: string;
136 Year: string;
137 Hours: string;
138 HoursModif: string;
139 Minutes: string;
140 Seconds: string;
141 Size: string;
142 Permissions: string;
143 DirFlag: string;
144 function GetListItem(Index: integer): TFTPListRec; virtual;
145 function ParseEPLF(Value: string): Boolean; virtual;
146 procedure ClearStore; virtual;
147 function ParseByMask(Value, NextValue, Mask: string): Integer; virtual;
148 function CheckValues: Boolean; virtual;
149 procedure FillRecord(const Value: TFTPListRec); virtual;
150 public
151 {:Constructor. You not need create this object, it is created by TFTPSend
152 class as their property.}
153 constructor Create;
154 destructor Destroy; override;
155
156 {:Clear list.}
157 procedure Clear; virtual;
158
159 {:count of holded @link(TFTPListRec) objects}
160 function Count: integer; virtual;
161
162 {:Assigns one list to another}
163 procedure Assign(Value: TFTPList); virtual;
164
165 {:try to parse raw directory listing in @link(lines) to list of
166 @link(TFTPListRec).}
167 procedure ParseLines; virtual;
168
169 {:By this property you have access to list of @link(TFTPListRec).
170 This is for compatibility only. Please, use @link(Items) instead.}
171 property List: TList read FList;
172
173 {:By this property you have access to list of @link(TFTPListRec).}
174 property Items[Index: Integer]: TFTPListRec read GetListItem; default;
175
176 {:Set of lines with RAW directory listing for @link(parseLines)}
177 property Lines: TStringList read FLines;
178
179 {:Set of masks for directory listing parser. It is predefined by default,
180 however you can modify it as you need. (for example, you can add your own
181 definition mask.) Mask is same as mask used in TotalCommander.}
182 property Masks: TStringList read FMasks;
183
184 {:After @link(ParseLines) it holding lines what was not sucessfully parsed.}
185 property UnparsedLines: TStringList read FUnparsedLines;
186 end;
187
188 {:@abstract(Implementation of FTP protocol.)
189 Note: Are you missing properties for setting Username and Password? Look to
190 parent @link(TSynaClient) object! (Username and Password have default values
191 for "anonymous" FTP login)
192
193 Are you missing properties for specify server address and port? Look to
194 parent @link(TSynaClient) too!}
195 TFTPSend = class(TSynaClient)
196 protected
197 FOnStatus: TFTPStatus;
198 FSock: TTCPBlockSocket;
199 FDSock: TTCPBlockSocket;
200 FResultCode: Integer;
201 FResultString: string;
202 FFullResult: TStringList;
203 FAccount: string;
204 FFWHost: string;
205 FFWPort: string;
206 FFWUsername: string;
207 FFWPassword: string;
208 FFWMode: integer;
209 FDataStream: TMemoryStream;
210 FDataIP: string;
211 FDataPort: string;
212 FDirectFile: Boolean;
213 FDirectFileName: string;
214 FCanResume: Boolean;
215 FPassiveMode: Boolean;
216 FForceDefaultPort: Boolean;
217 FForceOldPort: Boolean;
218 FFtpList: TFTPList;
219 FBinaryMode: Boolean;
220 FAutoTLS: Boolean;
221 FIsTLS: Boolean;
222 FIsDataTLS: Boolean;
223 FTLSonData: Boolean;
224 FFullSSL: Boolean;
225 function Auth(Mode: integer): Boolean; virtual;
226 function Connect: Boolean; virtual;
227 function InternalStor(const Command: string; RestoreAt: integer): Boolean; virtual;
228 function DataSocket: Boolean; virtual;
229 function AcceptDataSocket: Boolean; virtual;
230 procedure DoStatus(Response: Boolean; const Value: string); virtual;
231 public
232 {:Custom definition of login sequence. You can use this when you set
233 @link(FWMode) to value -1.}
234 CustomLogon: TLogonActions;
235
236 constructor Create;
237 destructor Destroy; override;
238
239 {:Waits and read FTP server response. You need this only in special cases!}
240 function ReadResult: Integer; virtual;
241
242 {:Parse remote side information of data channel from value string (returned
243 by PASV command). This function you need only in special cases!}
244 procedure ParseRemote(Value: string); virtual;
245
246 {:Parse remote side information of data channel from value string (returned
247 by EPSV command). This function you need only in special cases!}
248 procedure ParseRemoteEPSV(Value: string); virtual;
249
250 {:Send Value as FTP command to FTP server. Returned result code is result of
251 this function.
252 This command is good for sending site specific command, or non-standard
253 commands.}
254 function FTPCommand(const Value: string): integer; virtual;
255
256 {:Connect and logon to FTP server. If you specify any FireWall, connect to
257 firewall and throw them connect to FTP server. Login sequence depending on
258 @link(FWMode).}
259 function Login: Boolean; virtual;
260
261 {:Logoff and disconnect from FTP server.}
262 function Logout: Boolean; virtual;
263
264 {:Break current transmission of data. (You can call this method from
265 Sock.OnStatus event, or from another thread.)}
266 procedure Abort; virtual;
267
268 {:Break current transmission of data. It is same as Abort, but it send abort
269 telnet commands prior ABOR FTP command. Some servers need it. (You can call
270 this method from Sock.OnStatus event, or from another thread.)}
271 procedure TelnetAbort; virtual;
272
273 {:Download directory listing of Directory on FTP server. If Directory is
274 empty string, download listing of current working directory.
275 If NameList is @true, download only names of files in directory.
276 (internally use NLST command instead LIST command)
277 If NameList is @false, returned list is also parsed to @link(FTPList)
278 property.}
279 function List(Directory: string; NameList: Boolean): Boolean; virtual;
280
281 {:Read data from FileName on FTP server. If Restore is @true and server
282 supports resume dowloads, download is resumed. (received is only rest
283 of file)}
284 function RetrieveFile(const FileName: string; Restore: Boolean): Boolean; virtual;
285
286 {:Send data to FileName on FTP server. If Restore is @true and server
287 supports resume upload, upload is resumed. (send only rest of file)
288 In this case if remote file is same length as local file, nothing will be
289 done. If remote file is larger then local, resume is disabled and file is
290 transfered from begin!}
291 function StoreFile(const FileName: string; Restore: Boolean): Boolean; virtual;
292
293 {:Send data to FTP server and assing unique name for this file.}
294 function StoreUniqueFile: Boolean; virtual;
295
296 {:Append data to FileName on FTP server.}
297 function AppendFile(const FileName: string): Boolean; virtual;
298
299 {:Rename on FTP server file with OldName to NewName.}
300 function RenameFile(const OldName, NewName: string): Boolean; virtual;
301
302 {:Delete file FileName on FTP server.}
303 function DeleteFile(const FileName: string): Boolean; virtual;
304
305 {:Return size of Filename file on FTP server. If command failed (i.e. not
306 implemented), return -1.}
307 function FileSize(const FileName: string): integer; virtual;
308
309 {:Send NOOP command to FTP server for preserve of disconnect by inactivity
310 timeout.}
311 function NoOp: Boolean; virtual;
312
313 {:Change currect working directory to Directory on FTP server.}
314 function ChangeWorkingDir(const Directory: string): Boolean; virtual;
315
316 {:walk to upper directory on FTP server.}
317 function ChangeToParentDir: Boolean; virtual;
318
319 {:walk to root directory on FTP server. (May not work with all servers properly!)}
320 function ChangeToRootDir: Boolean; virtual;
321
322 {:Delete Directory on FTP server.}
323 function DeleteDir(const Directory: string): Boolean; virtual;
324
325 {:Create Directory on FTP server.}
326 function CreateDir(const Directory: string): Boolean; virtual;
327
328 {:Return current working directory on FTP server.}
329 function GetCurrentDir: String; virtual;
330
331 {:Establish data channel to FTP server and retrieve data.
332 This function you need only in special cases, i.e. when you need to implement
333 some special unsupported FTP command!}
334 function DataRead(const DestStream: TStream): Boolean; virtual;
335
336 {:Establish data channel to FTP server and send data.
337 This function you need only in special cases, i.e. when you need to implement
338 some special unsupported FTP command.}
339 function DataWrite(const SourceStream: TStream): Boolean; virtual;
340 published
341 {:After FTP command contains result number of this operation.}
342 property ResultCode: Integer read FResultCode;
343
344 {:After FTP command contains main line of result.}
345 property ResultString: string read FResultString;
346
347 {:After any FTP command it contains all lines of FTP server reply.}
348 property FullResult: TStringList read FFullResult;
349
350 {:Account information used in some cases inside login sequence.}
351 property Account: string read FAccount Write FAccount;
352
353 {:Address of firewall. If empty string (default), firewall not used.}
354 property FWHost: string read FFWHost Write FFWHost;
355
356 {:port of firewall. standard value is same port as ftp server used. (21)}
357 property FWPort: string read FFWPort Write FFWPort;
358
359 {:Username for login to firewall. (if needed)}
360 property FWUsername: string read FFWUsername Write FFWUsername;
361
362 {:password for login to firewall. (if needed)}
363 property FWPassword: string read FFWPassword Write FFWPassword;
364
365 {:Type of Firewall. Used only if you set some firewall address. Supported
366 predefined firewall login sequences are described by comments in source
367 file where you can see pseudocode decribing each sequence.}
368 property FWMode: integer read FFWMode Write FFWMode;
369
370 {:Socket object used for TCP/IP operation on control channel. Good for
371 seting OnStatus hook, etc.}
372 property Sock: TTCPBlockSocket read FSock;
373
374 {:Socket object used for TCP/IP operation on data channel. Good for seting
375 OnStatus hook, etc.}
376 property DSock: TTCPBlockSocket read FDSock;
377
378 {:If you not use @link(DirectFile) mode, all data transfers is made to or
379 from this stream.}
380 property DataStream: TMemoryStream read FDataStream;
381
382 {:After data connection is established, contains remote side IP of this
383 connection.}
384 property DataIP: string read FDataIP;
385
386 {:After data connection is established, contains remote side port of this
387 connection.}
388 property DataPort: string read FDataPort;
389
390 {:Mode of data handling by data connection. If @False, all data operations
391 are made to or from @link(DataStream) TMemoryStream.
392 If @true, data operations is made directly to file in your disk. (filename
393 is specified by @link(DirectFileName) property.) Dafault is @False!}
394 property DirectFile: Boolean read FDirectFile Write FDirectFile;
395
396 {:Filename for direct disk data operations.}
397 property DirectFileName: string read FDirectFileName Write FDirectFileName;
398
399 {:Indicate after @link(Login) if remote server support resume downloads and
400 uploads.}
401 property CanResume: Boolean read FCanResume;
402
403 {:If true (default value), all transfers is made by passive method.
404 It is safer method for various firewalls.}
405 property PassiveMode: Boolean read FPassiveMode Write FPassiveMode;
406
407 {:Force to listen for dataconnection on standard port (20). Default is @false,
408 dataconnections will be made to any non-standard port reported by PORT FTP
409 command. This setting is not used, if you use passive mode.}
410 property ForceDefaultPort: Boolean read FForceDefaultPort Write FForceDefaultPort;
411
412 {:When is @true, then is disabled EPSV and EPRT support. However without this
413 commands you cannot use IPv6! (Disabling of this commands is needed only
414 when you are behind some crap firewall/NAT.}
415 property ForceOldPort: Boolean read FForceOldPort Write FForceOldPort;
416
417 {:You may set this hook for monitoring FTP commands and replies.}
418 property OnStatus: TFTPStatus read FOnStatus write FOnStatus;
419
420 {:After LIST command is here parsed list of files in given directory.}
421 property FtpList: TFTPList read FFtpList;
422
423 {:if @true (default), then data transfers is in binary mode. If this is set
424 to @false, then ASCII mode is used.}
425 property BinaryMode: Boolean read FBinaryMode Write FBinaryMode;
426
427 {:if is true, then if server support upgrade to SSL/TLS mode, then use them.}
428 property AutoTLS: Boolean read FAutoTLS Write FAutoTLS;
429
430 {:if server listen on SSL/TLS port, then you set this to true.}
431 property FullSSL: Boolean read FFullSSL Write FFullSSL;
432
433 {:Signalise, if control channel is in SSL/TLS mode.}
434 property IsTLS: Boolean read FIsTLS;
435
436 {:Signalise, if data transfers is in SSL/TLS mode.}
437 property IsDataTLS: Boolean read FIsDataTLS;
438
439 {:If @true (default), then try to use SSL/TLS on data transfers too.
440 If @false, then SSL/TLS is used only for control connection.}
441 property TLSonData: Boolean read FTLSonData write FTLSonData;
442 end;
443
444{:A very useful function, and example of use can be found in the TFtpSend object.
445 Dowload specified file from FTP server to LocalFile.}
446function FtpGetFile(const IP, Port, FileName, LocalFile,
447 User, Pass: string): Boolean;
448
449{:A very useful function, and example of use can be found in the TFtpSend object.
450 Upload specified LocalFile to FTP server.}
451function FtpPutFile(const IP, Port, FileName, LocalFile,
452 User, Pass: string): Boolean;
453
454{:A very useful function, and example of use can be found in the TFtpSend object.
455 Initiate transfer of file between two FTP servers.}
456function FtpInterServerTransfer(
457 const FromIP, FromPort, FromFile, FromUser, FromPass: string;
458 const ToIP, ToPort, ToFile, ToUser, ToPass: string): Boolean;
459
460implementation
461
462constructor TFTPSend.Create;
463begin
464 inherited Create;
465 FFullResult := TStringList.Create;
466 FDataStream := TMemoryStream.Create;
467 FSock := TTCPBlockSocket.Create;
468 FSock.ConvertLineEnd := True;
469 FDSock := TTCPBlockSocket.Create;
470 FFtpList := TFTPList.Create;
471 FTimeout := 300000;
472 FTargetPort := cFtpProtocol;
473 FUsername := 'anonymous';
474 FPassword := 'anonymous@' + FSock.LocalName;
475 FDirectFile := False;
476 FPassiveMode := True;
477 FForceDefaultPort := False;
478 FForceOldPort := false;
479 FAccount := '';
480 FFWHost := '';
481 FFWPort := cFtpProtocol;
482 FFWUsername := '';
483 FFWPassword := '';
484 FFWMode := 0;
485 FBinaryMode := True;
486 FAutoTLS := False;
487 FFullSSL := False;
488 FIsTLS := False;
489 FIsDataTLS := False;
490 FTLSonData := True;
491end;
492
493destructor TFTPSend.Destroy;
494begin
495 FDSock.Free;
496 FSock.Free;
497 FFTPList.Free;
498 FDataStream.Free;
499 FFullResult.Free;
500 inherited Destroy;
501end;
502
503procedure TFTPSend.DoStatus(Response: Boolean; const Value: string);
504begin
505 if assigned(OnStatus) then
506 OnStatus(Self, Response, Value);
507end;
508
509function TFTPSend.ReadResult: Integer;
510var
511 s, c: string;
512begin
513 FFullResult.Clear;
514 c := '';
515 repeat
516 s := FSock.RecvString(FTimeout);
517 if c = '' then
518 if length(s) > 3 then
519 if s[4] in [' ', '-'] then
520 c :=Copy(s, 1, 3);
521 FResultString := s;
522 FFullResult.Add(s);
523 DoStatus(True, s);
524 if FSock.LastError <> 0 then
525 Break;
526 until (c <> '') and (Pos(c + ' ', s) = 1);
527 Result := StrToIntDef(c, 0);
528 FResultCode := Result;
529end;
530
531function TFTPSend.FTPCommand(const Value: string): integer;
532begin
533 FSock.Purge;
534 FSock.SendString(Value + CRLF);
535 DoStatus(False, Value);
536 Result := ReadResult;
537end;
538
539// based on idea by Petr Esner <petr.esner@atlas.cz>
540function TFTPSend.Auth(Mode: integer): Boolean;
541const
542 //if not USER <username> then
543 // if not PASS <password> then
544 // if not ACCT <account> then ERROR!
545 //OK!
546 Action0: TLogonActions =
547 (0, FTP_OK, 3,
548 1, FTP_OK, 6,
549 2, FTP_OK, FTP_ERR,
550 0, 0, 0, 0, 0, 0, 0, 0, 0);
551
552 //if not USER <FWusername> then
553 // if not PASS <FWPassword> then ERROR!
554 //if SITE <FTPServer> then ERROR!
555 //if not USER <username> then
556 // if not PASS <password> then
557 // if not ACCT <account> then ERROR!
558 //OK!
559 Action1: TLogonActions =
560 (3, 6, 3,
561 4, 6, FTP_ERR,
562 5, FTP_ERR, 9,
563 0, FTP_OK, 12,
564 1, FTP_OK, 15,
565 2, FTP_OK, FTP_ERR);
566
567 //if not USER <FWusername> then
568 // if not PASS <FWPassword> then ERROR!
569 //if USER <UserName>'@'<FTPServer> then OK!
570 //if not PASS <password> then
571 // if not ACCT <account> then ERROR!
572 //OK!
573 Action2: TLogonActions =
574 (3, 6, 3,
575 4, 6, FTP_ERR,
576 6, FTP_OK, 9,
577 1, FTP_OK, 12,
578 2, FTP_OK, FTP_ERR,
579 0, 0, 0);
580
581 //if not USER <FWusername> then
582 // if not PASS <FWPassword> then ERROR!
583 //if not USER <username> then
584 // if not PASS <password> then
585 // if not ACCT <account> then ERROR!
586 //OK!
587 Action3: TLogonActions =
588 (3, 6, 3,
589 4, 6, FTP_ERR,
590 0, FTP_OK, 9,
591 1, FTP_OK, 12,
592 2, FTP_OK, FTP_ERR,
593 0, 0, 0);
594
595 //OPEN <FTPserver>
596 //if not USER <username> then
597 // if not PASS <password> then
598 // if not ACCT <account> then ERROR!
599 //OK!
600 Action4: TLogonActions =
601 (7, 3, 3,
602 0, FTP_OK, 6,
603 1, FTP_OK, 9,
604 2, FTP_OK, FTP_ERR,
605 0, 0, 0, 0, 0, 0);
606
607 //if USER <UserName>'@'<FTPServer> then OK!
608 //if not PASS <password> then
609 // if not ACCT <account> then ERROR!
610 //OK!
611 Action5: TLogonActions =
612 (6, FTP_OK, 3,
613 1, FTP_OK, 6,
614 2, FTP_OK, FTP_ERR,
615 0, 0, 0, 0, 0, 0, 0, 0, 0);
616
617 //if not USER <FWUserName>@<FTPServer> then
618 // if not PASS <FWPassword> then ERROR!
619 //if not USER <username> then
620 // if not PASS <password> then
621 // if not ACCT <account> then ERROR!
622 //OK!
623 Action6: TLogonActions =
624 (8, 6, 3,
625 4, 6, FTP_ERR,
626 0, FTP_OK, 9,
627 1, FTP_OK, 12,
628 2, FTP_OK, FTP_ERR,
629 0, 0, 0);
630
631 //if USER <UserName>@<FTPServer> <FWUserName> then ERROR!
632 //if not PASS <password> then
633 // if not ACCT <account> then ERROR!
634 //OK!
635 Action7: TLogonActions =
636 (9, FTP_ERR, 3,
637 1, FTP_OK, 6,
638 2, FTP_OK, FTP_ERR,
639 0, 0, 0, 0, 0, 0, 0, 0, 0);
640
641 //if not USER <UserName>@<FWUserName>@<FTPServer> then
642 // if not PASS <Password>@<FWPassword> then
643 // if not ACCT <account> then ERROR!
644 //OK!
645 Action8: TLogonActions =
646 (10, FTP_OK, 3,
647 11, FTP_OK, 6,
648 2, FTP_OK, FTP_ERR,
649 0, 0, 0, 0, 0, 0, 0, 0, 0);
650var
651 FTPServer: string;
652 LogonActions: TLogonActions;
653 i: integer;
654 s: string;
655 x: integer;
656begin
657 Result := False;
658 if FFWHost = '' then
659 Mode := 0;
660 if (FTargetPort = cFtpProtocol) or (FTargetPort = '21') then
661 FTPServer := FTargetHost
662 else
663 FTPServer := FTargetHost + ':' + FTargetPort;
664 case Mode of
665 -1:
666 LogonActions := CustomLogon;
667 1:
668 LogonActions := Action1;
669 2:
670 LogonActions := Action2;
671 3:
672 LogonActions := Action3;
673 4:
674 LogonActions := Action4;
675 5:
676 LogonActions := Action5;
677 6:
678 LogonActions := Action6;
679 7:
680 LogonActions := Action7;
681 8:
682 LogonActions := Action8;
683 else
684 LogonActions := Action0;
685 end;
686 i := 0;
687 repeat
688 case LogonActions[i] of
689 0: s := 'USER ' + FUserName;
690 1: s := 'PASS ' + FPassword;
691 2: s := 'ACCT ' + FAccount;
692 3: s := 'USER ' + FFWUserName;
693 4: s := 'PASS ' + FFWPassword;
694 5: s := 'SITE ' + FTPServer;
695 6: s := 'USER ' + FUserName + '@' + FTPServer;
696 7: s := 'OPEN ' + FTPServer;
697 8: s := 'USER ' + FFWUserName + '@' + FTPServer;
698 9: s := 'USER ' + FUserName + '@' + FTPServer + ' ' + FFWUserName;
699 10: s := 'USER ' + FUserName + '@' + FFWUserName + '@' + FTPServer;
700 11: s := 'PASS ' + FPassword + '@' + FFWPassword;
701 end;
702 x := FTPCommand(s);
703 x := x div 100;
704 if (x <> 2) and (x <> 3) then
705 Exit;
706 i := LogonActions[i + x - 1];
707 case i of
708 FTP_ERR:
709 Exit;
710 FTP_OK:
711 begin
712 Result := True;
713 Exit;
714 end;
715 end;
716 until False;
717end;
718
719
720function TFTPSend.Connect: Boolean;
721begin
722 FSock.CloseSocket;
723 FSock.Bind(FIPInterface, cAnyPort);
724 if FSock.LastError = 0 then
725 if FFWHost = '' then
726 FSock.Connect(FTargetHost, FTargetPort)
727 else
728 FSock.Connect(FFWHost, FFWPort);
729 if FSock.LastError = 0 then
730 if FFullSSL then
731 FSock.SSLDoConnect;
732 Result := FSock.LastError = 0;
733end;
734
735function TFTPSend.Login: Boolean;
736var
737 x: integer;
738begin
739 Result := False;
740 FCanResume := False;
741 if not Connect then
742 Exit;
743 FIsTLS := FFullSSL;
744 FIsDataTLS := False;
745 repeat
746 x := ReadResult div 100;
747 until x <> 1;
748 if x <> 2 then
749 Exit;
750 if FAutoTLS and not(FIsTLS) then
751 if (FTPCommand('AUTH TLS') div 100) = 2 then
752 begin
753 FSock.SSLDoConnect;
754 FIsTLS := FSock.LastError = 0;
755 if not FIsTLS then
756 begin
757 Result := False;
758 Exit;
759 end;
760 end;
761 if not Auth(FFWMode) then
762 Exit;
763 if FIsTLS then
764 begin
765 FTPCommand('PBSZ 0');
766 if FTLSonData then
767 FIsDataTLS := (FTPCommand('PROT P') div 100) = 2;
768 if not FIsDataTLS then
769 FTPCommand('PROT C');
770 end;
771 FTPCommand('TYPE I');
772 FTPCommand('STRU F');
773 FTPCommand('MODE S');
774 if FTPCommand('REST 0') = 350 then
775 if FTPCommand('REST 1') = 350 then
776 begin
777 FTPCommand('REST 0');
778 FCanResume := True;
779 end;
780 Result := True;
781end;
782
783function TFTPSend.Logout: Boolean;
784begin
785 Result := (FTPCommand('QUIT') div 100) = 2;
786 FSock.CloseSocket;
787end;
788
789procedure TFTPSend.ParseRemote(Value: string);
790var
791 n: integer;
792 nb, ne: integer;
793 s: string;
794 x: integer;
795begin
796 Value := trim(Value);
797 nb := Pos('(',Value);
798 ne := Pos(')',Value);
799 if (nb = 0) or (ne = 0) then
800 begin
801 nb:=RPos(' ',Value);
802 s:=Copy(Value, nb + 1, Length(Value) - nb);
803 end
804 else
805 begin
806 s:=Copy(Value,nb+1,ne-nb-1);
807 end;
808 for n := 1 to 4 do
809 if n = 1 then
810 FDataIP := Fetch(s, ',')
811 else
812 FDataIP := FDataIP + '.' + Fetch(s, ',');
813 x := StrToIntDef(Fetch(s, ','), 0) * 256;
814 x := x + StrToIntDef(Fetch(s, ','), 0);
815 FDataPort := IntToStr(x);
816end;
817
818procedure TFTPSend.ParseRemoteEPSV(Value: string);
819var
820 n: integer;
821 s, v: string;
822begin
823 s := SeparateRight(Value, '(');
824 s := Trim(SeparateLeft(s, ')'));
825 Delete(s, Length(s), 1);
826 v := '';
827 for n := Length(s) downto 1 do
828 if s[n] in ['0'..'9'] then
829 v := s[n] + v
830 else
831 Break;
832 FDataPort := v;
833 FDataIP := FTargetHost;
834end;
835
836function TFTPSend.DataSocket: boolean;
837var
838 s: string;
839begin
840 Result := False;
841 if FIsDataTLS then
842 FPassiveMode := True;
843 if FPassiveMode then
844 begin
845 if FSock.IP6used then
846 s := '2'
847 else
848 s := '1';
849 if not(FForceOldPort) and ((FTPCommand('EPSV ' + s) div 100) = 2) then
850 begin
851 ParseRemoteEPSV(FResultString);
852 end
853 else
854 if FSock.IP6used then
855 Exit
856 else
857 begin
858 if (FTPCommand('PASV') div 100) <> 2 then
859 Exit;
860 ParseRemote(FResultString);
861 end;
862 FDSock.CloseSocket;
863 FDSock.Bind(FIPInterface, cAnyPort);
864 FDSock.Connect(FDataIP, FDataPort);
865 Result := FDSock.LastError = 0;
866 end
867 else
868 begin
869 FDSock.CloseSocket;
870 if FForceDefaultPort then
871 s := cFtpDataProtocol
872 else
873 s := '0';
874 //data conection from same interface as command connection
875 FDSock.Bind(FSock.GetLocalSinIP, s);
876 if FDSock.LastError <> 0 then
877 Exit;
878 FDSock.SetLinger(True, 10000);
879 FDSock.Listen;
880 FDSock.GetSins;
881 FDataIP := FDSock.GetLocalSinIP;
882 FDataIP := FDSock.ResolveName(FDataIP);
883 FDataPort := IntToStr(FDSock.GetLocalSinPort);
884 if not FForceOldPort then
885 begin
886 if IsIp6(FDataIP) then
887 s := '2'
888 else
889 s := '1';
890 s := 'EPRT |' + s +'|' + FDataIP + '|' + FDataPort + '|';
891 Result := (FTPCommand(s) div 100) = 2;
892 end;
893 if not Result and IsIP(FDataIP) then
894 begin
895 s := ReplaceString(FDataIP, '.', ',');
896 s := 'PORT ' + s + ',' + IntToStr(FDSock.GetLocalSinPort div 256)
897 + ',' + IntToStr(FDSock.GetLocalSinPort mod 256);
898 Result := (FTPCommand(s) div 100) = 2;
899 end;
900 end;
901end;
902
903function TFTPSend.AcceptDataSocket: Boolean;
904var
905 x: TSocket;
906begin
907 if FPassiveMode then
908 Result := True
909 else
910 begin
911 Result := False;
912 if FDSock.CanRead(FTimeout) then
913 begin
914 x := FDSock.Accept;
915 if not FDSock.UsingSocks then
916 FDSock.CloseSocket;
917 FDSock.Socket := x;
918 Result := True;
919 end;
920 end;
921 if Result and FIsDataTLS then
922 begin
923 FDSock.SSL.Assign(FSock.SSL);
924 FDSock.SSLDoConnect;
925 Result := FDSock.LastError = 0;
926 end;
927end;
928
929function TFTPSend.DataRead(const DestStream: TStream): Boolean;
930var
931 x: integer;
932begin
933 Result := False;
934 try
935 if not AcceptDataSocket then
936 Exit;
937 FDSock.RecvStreamRaw(DestStream, FTimeout);
938 FDSock.CloseSocket;
939 x := ReadResult;
940 Result := (x div 100) = 2;
941 finally
942 FDSock.CloseSocket;
943 end;
944end;
945
946function TFTPSend.DataWrite(const SourceStream: TStream): Boolean;
947var
948 x: integer;
949 b: Boolean;
950begin
951 Result := False;
952 try
953 if not AcceptDataSocket then
954 Exit;
955 FDSock.SendStreamRaw(SourceStream);
956 b := FDSock.LastError = 0;
957 FDSock.CloseSocket;
958 x := ReadResult;
959 Result := b and ((x div 100) = 2);
960 finally
961 FDSock.CloseSocket;
962 end;
963end;
964
965function TFTPSend.List(Directory: string; NameList: Boolean): Boolean;
966var
967 x: integer;
968begin
969 Result := False;
970 FDataStream.Clear;
971 FFTPList.Clear;
972 if Directory <> '' then
973 Directory := ' ' + Directory;
974 FTPCommand('TYPE A');
975 if not DataSocket then
976 Exit;
977 if NameList then
978 x := FTPCommand('NLST' + Directory)
979 else
980 x := FTPCommand('LIST' + Directory);
981 if (x div 100) <> 1 then
982 Exit;
983 Result := DataRead(FDataStream);
984 if (not NameList) and Result then
985 begin
986 FDataStream.Position := 0;
987 FFTPList.Lines.LoadFromStream(FDataStream);
988 FFTPList.ParseLines;
989 end;
990 FDataStream.Position := 0;
991end;
992
993function TFTPSend.RetrieveFile(const FileName: string; Restore: Boolean): Boolean;
994var
995 RetrStream: TStream;
996begin
997 Result := False;
998 if FileName = '' then
999 Exit;
1000 if not DataSocket then
1001 Exit;
1002 Restore := Restore and FCanResume;
1003 if FDirectFile then
1004 if Restore and FileExists(FDirectFileName) then
1005 RetrStream := TFileStream.Create(FDirectFileName,
1006 fmOpenReadWrite or fmShareExclusive)
1007 else
1008 RetrStream := TFileStream.Create(FDirectFileName,
1009 fmCreate or fmShareDenyWrite)
1010 else
1011 RetrStream := FDataStream;
1012 try
1013 if FBinaryMode then
1014 FTPCommand('TYPE I')
1015 else
1016 FTPCommand('TYPE A');
1017 if Restore then
1018 begin
1019 RetrStream.Position := RetrStream.Size;
1020 if (FTPCommand('REST ' + IntToStr(RetrStream.Size)) div 100) <> 3 then
1021 Exit;
1022 end
1023 else
1024 if RetrStream is TMemoryStream then
1025 TMemoryStream(RetrStream).Clear;
1026 if (FTPCommand('RETR ' + FileName) div 100) <> 1 then
1027 Exit;
1028 Result := DataRead(RetrStream);
1029 if not FDirectFile then
1030 RetrStream.Position := 0;
1031 finally
1032 if FDirectFile then
1033 RetrStream.Free;
1034 end;
1035end;
1036
1037function TFTPSend.InternalStor(const Command: string; RestoreAt: integer): Boolean;
1038var
1039 SendStream: TStream;
1040 StorSize: integer;
1041begin
1042 Result := False;
1043 if FDirectFile then
1044 if not FileExists(FDirectFileName) then
1045 Exit
1046 else
1047 SendStream := TFileStream.Create(FDirectFileName,
1048 fmOpenRead or fmShareDenyWrite)
1049 else
1050 SendStream := FDataStream;
1051 try
1052 if not DataSocket then
1053 Exit;
1054 if FBinaryMode then
1055 FTPCommand('TYPE I')
1056 else
1057 FTPCommand('TYPE A');
1058 StorSize := SendStream.Size;
1059 if not FCanResume then
1060 RestoreAt := 0;
1061 if (StorSize > 0) and (RestoreAt = StorSize) then
1062 begin
1063 Result := True;
1064 Exit;
1065 end;
1066 if RestoreAt > StorSize then
1067 RestoreAt := 0;
1068 FTPCommand('ALLO ' + IntToStr(StorSize - RestoreAt));
1069 if FCanResume then
1070 if (FTPCommand('REST ' + IntToStr(RestoreAt)) div 100) <> 3 then
1071 Exit;
1072 SendStream.Position := RestoreAt;
1073 if (FTPCommand(Command) div 100) <> 1 then
1074 Exit;
1075 Result := DataWrite(SendStream);
1076 finally
1077 if FDirectFile then
1078 SendStream.Free;
1079 end;
1080end;
1081
1082function TFTPSend.StoreFile(const FileName: string; Restore: Boolean): Boolean;
1083var
1084 RestoreAt: integer;
1085begin
1086 Result := False;
1087 if FileName = '' then
1088 Exit;
1089 RestoreAt := 0;
1090 Restore := Restore and FCanResume;
1091 if Restore then
1092 begin
1093 RestoreAt := Self.FileSize(FileName);
1094 if RestoreAt < 0 then
1095 RestoreAt := 0;
1096 end;
1097 Result := InternalStor('STOR ' + FileName, RestoreAt);
1098end;
1099
1100function TFTPSend.StoreUniqueFile: Boolean;
1101begin
1102 Result := InternalStor('STOU', 0);
1103end;
1104
1105function TFTPSend.AppendFile(const FileName: string): Boolean;
1106begin
1107 Result := False;
1108 if FileName = '' then
1109 Exit;
1110 Result := InternalStor('APPE '+FileName, 0);
1111end;
1112
1113function TFTPSend.NoOp: Boolean;
1114begin
1115 Result := (FTPCommand('NOOP') div 100) = 2;
1116end;
1117
1118function TFTPSend.RenameFile(const OldName, NewName: string): Boolean;
1119begin
1120 Result := False;
1121 if (FTPCommand('RNFR ' + OldName) div 100) <> 3 then
1122 Exit;
1123 Result := (FTPCommand('RNTO ' + NewName) div 100) = 2;
1124end;
1125
1126function TFTPSend.DeleteFile(const FileName: string): Boolean;
1127begin
1128 Result := (FTPCommand('DELE ' + FileName) div 100) = 2;
1129end;
1130
1131function TFTPSend.FileSize(const FileName: string): integer;
1132var
1133 s: string;
1134begin
1135 Result := -1;
1136 if (FTPCommand('SIZE ' + FileName) div 100) = 2 then
1137 begin
1138 s := Trim(SeparateRight(ResultString, ' '));
1139 s := Trim(SeparateLeft(s, ' '));
1140 Result := StrToIntDef(s, -1);
1141 end;
1142end;
1143
1144function TFTPSend.ChangeWorkingDir(const Directory: string): Boolean;
1145begin
1146 Result := (FTPCommand('CWD ' + Directory) div 100) = 2;
1147end;
1148
1149function TFTPSend.ChangeToParentDir: Boolean;
1150begin
1151 Result := (FTPCommand('CDUP') div 100) = 2;
1152end;
1153
1154function TFTPSend.ChangeToRootDir: Boolean;
1155begin
1156 Result := ChangeWorkingDir('/');
1157end;
1158
1159function TFTPSend.DeleteDir(const Directory: string): Boolean;
1160begin
1161 Result := (FTPCommand('RMD ' + Directory) div 100) = 2;
1162end;
1163
1164function TFTPSend.CreateDir(const Directory: string): Boolean;
1165begin
1166 Result := (FTPCommand('MKD ' + Directory) div 100) = 2;
1167end;
1168
1169function TFTPSend.GetCurrentDir: String;
1170begin
1171 Result := '';
1172 if (FTPCommand('PWD') div 100) = 2 then
1173 begin
1174 Result := SeparateRight(FResultString, '"');
1175 Result := Trim(Separateleft(Result, '"'));
1176 end;
1177end;
1178
1179procedure TFTPSend.Abort;
1180begin
1181 FSock.SendString('ABOR' + CRLF);
1182 FDSock.StopFlag := True;
1183end;
1184
1185procedure TFTPSend.TelnetAbort;
1186begin
1187 FSock.SendString(#$FF + #$F4 + #$FF + #$F2);
1188 Abort;
1189end;
1190
1191{==============================================================================}
1192
1193procedure TFTPListRec.Assign(Value: TFTPListRec);
1194begin
1195 FFileName := Value.FileName;
1196 FDirectory := Value.Directory;
1197 FReadable := Value.Readable;
1198 FFileSize := Value.FileSize;
1199 FFileTime := Value.FileTime;
1200 FOriginalLine := Value.OriginalLine;
1201 FMask := Value.Mask;
1202end;
1203
1204constructor TFTPList.Create;
1205begin
1206 inherited Create;
1207 FList := TList.Create;
1208 FLines := TStringList.Create;
1209 FMasks := TStringList.Create;
1210 FUnparsedLines := TStringList.Create;
1211 //various UNIX
1212 FMasks.add('pppppppppp $!!!S*$TTT$DD$hh mm ss$YYYY$n*');
1213 FMasks.add('pppppppppp $!!!S*$DD$TTT$hh mm ss$YYYY$n*');
1214 FMasks.add('pppppppppp $!!!S*$TTT$DD$UUUUU$n*'); //mostly used UNIX format
1215 FMasks.add('pppppppppp $!!!S*$DD$TTT$UUUUU$n*');
1216 //MacOS
1217 FMasks.add('pppppppppp $!!S*$TTT$DD$UUUUU$n*');
1218 FMasks.add('pppppppppp $!S*$TTT$DD$UUUUU$n*');
1219 //Novell
1220 FMasks.add('d $!S*$TTT$DD$UUUUU$n*');
1221 //Windows
1222 FMasks.add('MM DD YY hh mmH !S* n*');
1223 FMasks.add('MM DD YY hh mmH $ d!n*');
1224 FMasks.add('MM DD YYYY hh mmH !S* n*');
1225 FMasks.add('MM DD YYYY hh mmH $ d!n*');
1226 FMasks.add('DD MM YYYY hh mmH !S* n*');
1227 FMasks.add('DD MM YYYY hh mmH $ d!n*');
1228 //VMS
1229 FMasks.add('v*$ DD TTT YYYY hh mm');
1230 FMasks.add('v*$!DD TTT YYYY hh mm');
1231 FMasks.add('n*$ YYYY MM DD hh mm$S*');
1232 //AS400
1233 FMasks.add('!S*$MM DD YY hh mm ss !n*');
1234 FMasks.add('!S*$DD MM YY hh mm ss !n*');
1235 FMasks.add('n*!S*$MM DD YY hh mm ss d');
1236 FMasks.add('n*!S*$DD MM YY hh mm ss d');
1237 //VxWorks
1238 FMasks.add('$S* TTT DD YYYY hh mm ss $n* $ d');
1239 FMasks.add('$S* TTT DD YYYY hh mm ss $n*');
1240 //Distinct
1241 FMasks.add('d $S*$TTT DD YYYY hh mm$n*');
1242 FMasks.add('d $S*$TTT DD$hh mm$n*');
1243 //PC-NFSD
1244 FMasks.add('nnnnnnnn.nnn dSSSSSSSSSSS MM DD YY hh mmH');
1245 //VOS
1246 FMasks.add('- SSSSS YY MM DD hh mm ss n*');
1247 FMasks.add('- d= SSSSS YY MM DD hh mm ss n*');
1248 //Unissys ClearPath
1249 FMasks.add('nnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnn SSSSSSSSS MM DD YYYY hh mm');
1250 FMasks.add('n*\x SSSSSSSSS MM DD YYYY hh mm');
1251 //IBM
1252 FMasks.add('- SSSSSSSSSSSS d MM DD YYYY hh mm n*');
1253 //OS9
1254 FMasks.add('- YY MM DD hhmm d SSSSSSSSS n*');
1255 //tandem
1256 FMasks.add('nnnnnnnn SSSSSSS DD TTT YY hh mm ss');
1257 //MVS
1258 FMasks.add('- YYYY MM DD SSSSS d=O n*');
1259 //BullGCOS8
1260 FMasks.add(' $S* MM DD YY hh mm ss !n*');
1261 FMasks.add('d $S* MM DD YY !n*');
1262 //BullGCOS7
1263 FMasks.add(' TTT DD YYYY n*');
1264 FMasks.add(' d n*');
1265end;
1266
1267destructor TFTPList.Destroy;
1268begin
1269 Clear;
1270 FList.Free;
1271 FLines.Free;
1272 FMasks.Free;
1273 FUnparsedLines.Free;
1274 inherited Destroy;
1275end;
1276
1277procedure TFTPList.Clear;
1278var
1279 n:integer;
1280begin
1281 for n := 0 to FList.Count - 1 do
1282 if Assigned(FList[n]) then
1283 TFTPListRec(FList[n]).Free;
1284 FList.Clear;
1285 FLines.Clear;
1286 FUnparsedLines.Clear;
1287end;
1288
1289function TFTPList.Count: integer;
1290begin
1291 Result := FList.Count;
1292end;
1293
1294function TFTPList.GetListItem(Index: integer): TFTPListRec;
1295begin
1296 Result := nil;
1297 if Index < Count then
1298 Result := TFTPListRec(FList[Index]);
1299end;
1300
1301procedure TFTPList.Assign(Value: TFTPList);
1302var
1303 flr: TFTPListRec;
1304 n: integer;
1305begin
1306 Clear;
1307 for n := 0 to Value.Count - 1 do
1308 begin
1309 flr := TFTPListRec.Create;
1310 flr.Assign(Value[n]);
1311 Flist.Add(flr);
1312 end;
1313 Lines.Assign(Value.Lines);
1314 Masks.Assign(Value.Masks);
1315 UnparsedLines.Assign(Value.UnparsedLines);
1316end;
1317
1318procedure TFTPList.ClearStore;
1319begin
1320 Monthnames := '';
1321 BlockSize := '';
1322 DirFlagValue := '';
1323 FileName := '';
1324 VMSFileName := '';
1325 Day := '';
1326 Month := '';
1327 ThreeMonth := '';
1328 YearTime := '';
1329 Year := '';
1330 Hours := '';
1331 HoursModif := '';
1332 Minutes := '';
1333 Seconds := '';
1334 Size := '';
1335 Permissions := '';
1336 DirFlag := '';
1337end;
1338
1339function TFTPList.ParseByMask(Value, NextValue, Mask: string): Integer;
1340var
1341 Ivalue, IMask: integer;
1342 MaskC, LastMaskC: Char;
1343 c: char;
1344 s: string;
1345begin
1346 ClearStore;
1347 Result := 0;
1348 if Value = '' then
1349 Exit;
1350 if Mask = '' then
1351 Exit;
1352 Ivalue := 1;
1353 IMask := 1;
1354 Result := 1;
1355 LastMaskC := ' ';
1356 while Imask <= Length(mask) do
1357 begin
1358 if (Mask[Imask] <> '*') and (Ivalue > Length(Value)) then
1359 begin
1360 Result := 0;
1361 Exit;
1362 end;
1363 MaskC := Mask[Imask];
1364 if Ivalue > Length(Value) then
1365 Exit;
1366 c := Value[Ivalue];
1367 case MaskC of
1368 'n':
1369 FileName := FileName + c;
1370 'v':
1371 VMSFileName := VMSFileName + c;
1372 '.':
1373 begin
1374 if c in ['.', ' '] then
1375 FileName := TrimSP(FileName) + '.'
1376 else
1377 begin
1378 Result := 0;
1379 Exit;
1380 end;
1381 end;
1382 'D':
1383 Day := Day + c;
1384 'M':
1385 Month := Month + c;
1386 'T':
1387 ThreeMonth := ThreeMonth + c;
1388 'U':
1389 YearTime := YearTime + c;
1390 'Y':
1391 Year := Year + c;
1392 'h':
1393 Hours := Hours + c;
1394 'H':
1395 HoursModif := HoursModif + c;
1396 'm':
1397 Minutes := Minutes + c;
1398 's':
1399 Seconds := Seconds + c;
1400 'S':
1401 Size := Size + c;
1402 'p':
1403 Permissions := Permissions + c;
1404 'd':
1405 DirFlag := DirFlag + c;
1406 'x':
1407 if c <> ' ' then
1408 begin
1409 Result := 0;
1410 Exit;
1411 end;
1412 '*':
1413 begin
1414 s := '';
1415 if LastMaskC in ['n', 'v'] then
1416 begin
1417 if Imask = Length(Mask) then
1418 s := Copy(Value, IValue, Maxint)
1419 else
1420 while IValue <= Length(Value) do
1421 begin
1422 if Value[Ivalue] = ' ' then
1423 break;
1424 s := s + Value[Ivalue];
1425 Inc(Ivalue);
1426 end;
1427 if LastMaskC = 'n' then
1428 FileName := FileName + s
1429 else
1430 VMSFileName := VMSFileName + s;
1431 end
1432 else
1433 begin
1434 while IValue <= Length(Value) do
1435 begin
1436 if not(Value[Ivalue] in ['0'..'9']) then
1437 break;
1438 s := s + Value[Ivalue];
1439 Inc(Ivalue);
1440 end;
1441 case LastMaskC of
1442 'S':
1443 Size := Size + s;
1444 end;
1445 end;
1446 Dec(IValue);
1447 end;
1448 '!':
1449 begin
1450 while IValue <= Length(Value) do
1451 begin
1452 if Value[Ivalue] = ' ' then
1453 break;
1454 Inc(Ivalue);
1455 end;
1456 while IValue <= Length(Value) do
1457 begin
1458 if Value[Ivalue] <> ' ' then
1459 break;
1460 Inc(Ivalue);
1461 end;
1462 Dec(IValue);
1463 end;
1464 '$':
1465 begin
1466 while IValue <= Length(Value) do
1467 begin
1468 if not(Value[Ivalue] in [' ', #9]) then
1469 break;
1470 Inc(Ivalue);
1471 end;
1472 Dec(IValue);
1473 end;
1474 '=':
1475 begin
1476 s := '';
1477 case LastmaskC of
1478 'S':
1479 begin
1480 while Imask <= Length(Mask) do
1481 begin
1482 if not(Mask[Imask] in ['0'..'9']) then
1483 break;
1484 s := s + Mask[Imask];
1485 Inc(Imask);
1486 end;
1487 Dec(Imask);
1488 BlockSize := s;
1489 end;
1490 'T':
1491 begin
1492 Monthnames := Copy(Mask, IMask, 12 * 3);
1493 Inc(IMask, 12 * 3);
1494 end;
1495 'd':
1496 begin
1497 Inc(Imask);
1498 DirFlagValue := Mask[Imask];
1499 end;
1500 end;
1501 end;
1502 '\':
1503 begin
1504 Value := NextValue;
1505 IValue := 0;
1506 Result := 2;
1507 end;
1508 end;
1509 Inc(Ivalue);
1510 Inc(Imask);
1511 LastMaskC := MaskC;
1512 end;
1513end;
1514
1515function TFTPList.CheckValues: Boolean;
1516var
1517 x, n: integer;
1518begin
1519 Result := false;
1520 if FileName <> '' then
1521 begin
1522 if pos('?', VMSFilename) > 0 then
1523 Exit;
1524 if pos('*', VMSFilename) > 0 then
1525 Exit;
1526 end;
1527 if VMSFileName <> '' then
1528 if pos(';', VMSFilename) <= 0 then
1529 Exit;
1530 if (FileName = '') and (VMSFileName = '') then
1531 Exit;
1532 if Permissions <> '' then
1533 begin
1534 if length(Permissions) <> 10 then
1535 Exit;
1536 for n := 1 to 10 do
1537 if not(Permissions[n] in
1538 ['a', 'b', 'c', 'd', 'h', 'l', 'p', 'r', 's', 't', 'w', 'x', 'y', '-']) then
1539 Exit;
1540 end;
1541 if Day <> '' then
1542 begin
1543 Day := TrimSP(Day);
1544 x := StrToIntDef(day, -1);
1545 if (x < 1) or (x > 31) then
1546 Exit;
1547 end;
1548 if Month <> '' then
1549 begin
1550 Month := TrimSP(Month);
1551 x := StrToIntDef(Month, -1);
1552 if (x < 1) or (x > 12) then
1553 Exit;
1554 end;
1555 if Hours <> '' then
1556 begin
1557 Hours := TrimSP(Hours);
1558 x := StrToIntDef(Hours, -1);
1559 if (x < 0) or (x > 24) then
1560 Exit;
1561 end;
1562 if HoursModif <> '' then
1563 begin
1564 if not (HoursModif[1] in ['a', 'A', 'p', 'P']) then
1565 Exit;
1566 end;
1567 if Minutes <> '' then
1568 begin
1569 Minutes := TrimSP(Minutes);
1570 x := StrToIntDef(Minutes, -1);
1571 if (x < 0) or (x > 59) then
1572 Exit;
1573 end;
1574 if Seconds <> '' then
1575 begin
1576 Seconds := TrimSP(Seconds);
1577 x := StrToIntDef(Seconds, -1);
1578 if (x < 0) or (x > 59) then
1579 Exit;
1580 end;
1581 if Size <> '' then
1582 begin
1583 Size := TrimSP(Size);
1584 for n := 1 to Length(Size) do
1585 if not (Size[n] in ['0'..'9']) then
1586 Exit;
1587 end;
1588
1589 if length(Monthnames) = (12 * 3) then
1590 for n := 1 to 12 do
1591 CustomMonthNames[n] := Copy(Monthnames, ((n - 1) * 3) + 1, 3);
1592 if ThreeMonth <> '' then
1593 begin
1594 x := GetMonthNumber(ThreeMonth);
1595 if (x = 0) then
1596 Exit;
1597 end;
1598 if YearTime <> '' then
1599 begin
1600 YearTime := ReplaceString(YearTime, '-', ':');
1601 if pos(':', YearTime) > 0 then
1602 begin
1603 if (GetTimeFromstr(YearTime) = -1) then
1604 Exit;
1605 end
1606 else
1607 begin
1608 YearTime := TrimSP(YearTime);
1609 x := StrToIntDef(YearTime, -1);
1610 if (x = -1) then
1611 Exit;
1612 if (x < 1900) or (x > 2100) then
1613 Exit;
1614 end;
1615 end;
1616 if Year <> '' then
1617 begin
1618 Year := TrimSP(Year);
1619 x := StrToIntDef(Year, -1);
1620 if (x = -1) then
1621 Exit;
1622 if Length(Year) = 4 then
1623 begin
1624 if not((x > 1900) and (x < 2100)) then
1625 Exit;
1626 end
1627 else
1628 if Length(Year) = 2 then
1629 begin
1630 if not((x >= 0) and (x <= 99)) then
1631 Exit;
1632 end
1633 else
1634 if Length(Year) = 3 then
1635 begin
1636 if not((x >= 100) and (x <= 110)) then
1637 Exit;
1638 end
1639 else
1640 Exit;
1641 end;
1642 Result := True;
1643end;
1644
1645procedure TFTPList.FillRecord(const Value: TFTPListRec);
1646var
1647 s: string;
1648 x: integer;
1649 myear: Word;
1650 mmonth: Word;
1651 mday: Word;
1652 mhours, mminutes, mseconds: word;
1653 n: integer;
1654begin
1655 s := DirFlagValue;
1656 if s = '' then
1657 s := 'D';
1658 s := Uppercase(s);
1659 Value.Directory := s = Uppercase(DirFlag);
1660 if FileName <> '' then
1661 Value.FileName := SeparateLeft(Filename, ' -> ');
1662 if VMSFileName <> '' then
1663 begin
1664 Value.FileName := VMSFilename;
1665 Value.Directory := Pos('.DIR;',VMSFilename) > 0;
1666 end;
1667 Value.FileName := TrimSPRight(Value.FileName);
1668 Value.Readable := not Value.Directory;
1669 if BlockSize <> '' then
1670 x := StrToIntDef(BlockSize, 1)
1671 else
1672 x := 1;
1673 Value.FileSize := x * StrToIntDef(Size, 0);
1674
1675 DecodeDate(Date,myear,mmonth,mday);
1676 mhours := 0;
1677 mminutes := 0;
1678 mseconds := 0;
1679
1680 if Day <> '' then
1681 mday := StrToIntDef(day, 1);
1682 if Month <> '' then
1683 mmonth := StrToIntDef(Month, 1);
1684 if length(Monthnames) = (12 * 3) then
1685 for n := 1 to 12 do
1686 CustomMonthNames[n] := Copy(Monthnames, ((n - 1) * 3) + 1, 3);
1687 if ThreeMonth <> '' then
1688 mmonth := GetMonthNumber(ThreeMonth);
1689 if Year <> '' then
1690 begin
1691 myear := StrToIntDef(Year, 0);
1692 if (myear <= 99) and (myear > 50) then
1693 myear := myear + 1900;
1694 if myear <= 50 then
1695 myear := myear + 2000;
1696 end;
1697 if YearTime <> '' then
1698 begin
1699 if pos(':', YearTime) > 0 then
1700 begin
1701 YearTime := TrimSP(YearTime);
1702 mhours := StrToIntDef(Separateleft(YearTime, ':'), 0);
1703 mminutes := StrToIntDef(SeparateRight(YearTime, ':'), 0);
1704 if (Encodedate(myear, mmonth, mday)
1705 + EncodeTime(mHours, mminutes, 0, 0)) > now then
1706 Dec(mYear);
1707 end
1708 else
1709 myear := StrToIntDef(YearTime, 0);
1710 end;
1711 if Minutes <> '' then
1712 mminutes := StrToIntDef(Minutes, 0);
1713 if Seconds <> '' then
1714 mseconds := StrToIntDef(Seconds, 0);
1715 if Hours <> '' then
1716 begin
1717 mHours := StrToIntDef(Hours, 0);
1718 if HoursModif <> '' then
1719 if Uppercase(HoursModif[1]) = 'P' then
1720 if mHours <> 12 then
1721 mHours := MHours + 12;
1722 end;
1723 Value.FileTime := Encodedate(myear, mmonth, mday)
1724 + EncodeTime(mHours, mminutes, mseconds, 0);
1725 if Permissions <> '' then
1726 begin
1727 Value.Permission := Permissions;
1728 Value.Readable := Uppercase(permissions)[2] = 'R';
1729 if Uppercase(permissions)[1] = 'D' then
1730 begin
1731 Value.Directory := True;
1732 Value.Readable := false;
1733 end
1734 else
1735 if Uppercase(permissions)[1] = 'L' then
1736 Value.Directory := True;
1737 end;
1738end;
1739
1740function TFTPList.ParseEPLF(Value: string): Boolean;
1741var
1742 s, os: string;
1743 flr: TFTPListRec;
1744begin
1745 Result := False;
1746 if Value <> '' then
1747 if Value[1] = '+' then
1748 begin
1749 os := Value;
1750 Delete(Value, 1, 1);
1751 flr := TFTPListRec.create;
1752 flr.FileName := SeparateRight(Value, #9);
1753 s := Fetch(Value, ',');
1754 while s <> '' do
1755 begin
1756 if s[1] = #9 then
1757 Break;
1758 case s[1] of
1759 '/':
1760 flr.Directory := true;
1761 'r':
1762 flr.Readable := true;
1763 's':
1764 flr.FileSize := StrToIntDef(Copy(s, 2, Length(s) - 1), 0);
1765 'm':
1766 flr.FileTime := (StrToIntDef(Copy(s, 2, Length(s) - 1), 0) / 86400)
1767 + 25569;
1768 end;
1769 s := Fetch(Value, ',');
1770 end;
1771 if flr.FileName <> '' then
1772 if (flr.Directory and ((flr.FileName = '.') or (flr.FileName = '..')))
1773 or (flr.FileName = '') then
1774 flr.free
1775 else
1776 begin
1777 flr.OriginalLine := os;
1778 flr.Mask := 'EPLF';
1779 Flist.Add(flr);
1780 Result := True;
1781 end;
1782 end;
1783end;
1784
1785procedure TFTPList.ParseLines;
1786var
1787 flr: TFTPListRec;
1788 n, m: Integer;
1789 S: string;
1790 x: integer;
1791 b: Boolean;
1792begin
1793 n := 0;
1794 while n < Lines.Count do
1795 begin
1796 if n = Lines.Count - 1 then
1797 s := ''
1798 else
1799 s := Lines[n + 1];
1800 b := False;
1801 x := 0;
1802 if ParseEPLF(Lines[n]) then
1803 begin
1804 b := True;
1805 x := 1;
1806 end
1807 else
1808 for m := 0 to Masks.Count - 1 do
1809 begin
1810 x := ParseByMask(Lines[n], s, Masks[m]);
1811 if x > 0 then
1812 if CheckValues then
1813 begin
1814 flr := TFTPListRec.create;
1815 FillRecord(flr);
1816 flr.OriginalLine := Lines[n];
1817 flr.Mask := Masks[m];
1818 if flr.Directory and ((flr.FileName = '.') or (flr.FileName = '..')) then
1819 flr.free
1820 else
1821 Flist.Add(flr);
1822 b := True;
1823 Break;
1824 end;
1825 end;
1826 if not b then
1827 FUnparsedLines.Add(Lines[n]);
1828 Inc(n);
1829 if x > 1 then
1830 Inc(n, x - 1);
1831 end;
1832end;
1833
1834{==============================================================================}
1835
1836function FtpGetFile(const IP, Port, FileName, LocalFile,
1837 User, Pass: string): Boolean;
1838begin
1839 Result := False;
1840 with TFTPSend.Create do
1841 try
1842 if User <> '' then
1843 begin
1844 Username := User;
1845 Password := Pass;
1846 end;
1847 TargetHost := IP;
1848 TargetPort := Port;
1849 if not Login then
1850 Exit;
1851 DirectFileName := LocalFile;
1852 DirectFile:=True;
1853 Result := RetrieveFile(FileName, False);
1854 Logout;
1855 finally
1856 Free;
1857 end;
1858end;
1859
1860function FtpPutFile(const IP, Port, FileName, LocalFile,
1861 User, Pass: string): Boolean;
1862begin
1863 Result := False;
1864 with TFTPSend.Create do
1865 try
1866 if User <> '' then
1867 begin
1868 Username := User;
1869 Password := Pass;
1870 end;
1871 TargetHost := IP;
1872 TargetPort := Port;
1873 if not Login then
1874 Exit;
1875 DirectFileName := LocalFile;
1876 DirectFile:=True;
1877 Result := StoreFile(FileName, False);
1878 Logout;
1879 finally
1880 Free;
1881 end;
1882end;
1883
1884function FtpInterServerTransfer(
1885 const FromIP, FromPort, FromFile, FromUser, FromPass: string;
1886 const ToIP, ToPort, ToFile, ToUser, ToPass: string): Boolean;
1887var
1888 FromFTP, ToFTP: TFTPSend;
1889 s: string;
1890 x: integer;
1891begin
1892 Result := False;
1893 FromFTP := TFTPSend.Create;
1894 toFTP := TFTPSend.Create;
1895 try
1896 if FromUser <> '' then
1897 begin
1898 FromFTP.Username := FromUser;
1899 FromFTP.Password := FromPass;
1900 end;
1901 if ToUser <> '' then
1902 begin
1903 ToFTP.Username := ToUser;
1904 ToFTP.Password := ToPass;
1905 end;
1906 FromFTP.TargetHost := FromIP;
1907 FromFTP.TargetPort := FromPort;
1908 ToFTP.TargetHost := ToIP;
1909 ToFTP.TargetPort := ToPort;
1910 if not FromFTP.Login then
1911 Exit;
1912 if not ToFTP.Login then
1913 Exit;
1914 if (FromFTP.FTPCommand('PASV') div 100) <> 2 then
1915 Exit;
1916 FromFTP.ParseRemote(FromFTP.ResultString);
1917 s := ReplaceString(FromFTP.DataIP, '.', ',');
1918 s := 'PORT ' + s + ',' + IntToStr(StrToIntDef(FromFTP.DataPort, 0) div 256)
1919 + ',' + IntToStr(StrToIntDef(FromFTP.DataPort, 0) mod 256);
1920 if (ToFTP.FTPCommand(s) div 100) <> 2 then
1921 Exit;
1922 x := ToFTP.FTPCommand('RETR ' + FromFile);
1923 if (x div 100) <> 1 then
1924 Exit;
1925 x := FromFTP.FTPCommand('STOR ' + ToFile);
1926 if (x div 100) <> 1 then
1927 Exit;
1928 FromFTP.Timeout := 21600000;
1929 x := FromFTP.ReadResult;
1930 if (x div 100) <> 2 then
1931 Exit;
1932 ToFTP.Timeout := 21600000;
1933 x := ToFTP.ReadResult;
1934 if (x div 100) <> 2 then
1935 Exit;
1936 Result := True;
1937 finally
1938 ToFTP.Free;
1939 FromFTP.Free;
1940 end;
1941end;
1942
1943end.
Note: See TracBrowser for help on using the repository browser.