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

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