客服电话
APP下载
迪恩网络APP
随时随地掌握行业动态
官方微信
扫描二维码
关注迪恩网络微信公众号
|
在Delphi 7开发下有强大的Indy控件，版本为9，要实现一个FTP服务器，参考自带的例子，发现还要写很多函数，而且不支持中文显示文件列表等等。 于是，自己改进封装了下，形成一个TFTPServer类。 源码如下： 1 {*******************************************************} 2 { } 3 { 系统名称 FTP服务器类 } 4 { 版权所有 (C) http://blog.csdn.net/akof1314 } 5 { 单元名称 FTPServer.pas } 6 { 单元功能 在Delphi 7下TIdFTPServer实现FTP服务器 } 7 { } 8 {*******************************************************} 9 unit FTPServer; 10 11 interface 12 13 uses 14 Classes, Windows, Sysutils, IdFTPList, IdFTPServer, Idtcpserver, IdSocketHandle, Idglobal, IdHashCRC, IdStack; 15 {------------------------------------------------------------------------------- 16 功能: 自定义消息，方便与窗体进行消息传递 17 -------------------------------------------------------------------------------} 18 type 19 TFtpNotifyEvent = procedure (ADatetime: TDateTime;AUserIP, AEventMessage: string) of object; 20 {------------------------------------------------------------------------------- 21 功能: FTP服务器类 22 -------------------------------------------------------------------------------} 23 type 24 TFTPServer = class 25 private 26 FUserName,FUserPassword,FBorrowDirectory: string; 27 FBorrowPort: Integer; 28 IdFTPServer: TIdFTPServer; 29 FOnFtpNotifyEvent: TFtpNotifyEvent; 30 procedure IdFTPServer1UserLogin( ASender: TIdFTPServerThread; const AUsername, APassword: string; var AAuthenticated: Boolean ) ; 31 procedure IdFTPServer1ListDirectory( ASender: TIdFTPServerThread; const APath: string; ADirectoryListing: TIdFTPListItems ) ; 32 procedure IdFTPServer1RenameFile( ASender: TIdFTPServerThread; const ARenameFromFile, ARenameToFile: string ) ; 33 procedure IdFTPServer1RetrieveFile( ASender: TIdFTPServerThread; const AFilename: string; var VStream: TStream ) ; 34 procedure IdFTPServer1StoreFile( ASender: TIdFTPServerThread; const AFilename: string; AAppend: Boolean; var VStream: TStream ) ; 35 procedure IdFTPServer1RemoveDirectory( ASender: TIdFTPServerThread; var VDirectory: string ) ; 36 procedure IdFTPServer1MakeDirectory( ASender: TIdFTPServerThread; var VDirectory: string ) ; 37 procedure IdFTPServer1GetFileSize( ASender: TIdFTPServerThread; const AFilename: string; var VFileSize: Int64 ) ; 38 procedure IdFTPServer1DeleteFile( ASender: TIdFTPServerThread; const APathname: string ) ; 39 procedure IdFTPServer1ChangeDirectory( ASender: TIdFTPServerThread; var VDirectory: string ) ; 40 procedure IdFTPServer1CommandXCRC( ASender: TIdCommand ) ; 41 procedure IdFTPServer1DisConnect( AThread: TIdPeerThread ) ; 42 protected 43 function TransLatePath( const APathname, homeDir: string ) : string; 44 public 45 constructor Create; reintroduce; 46 destructor Destroy; override; 47 procedure Run; 48 procedure Stop; 49 function GetBindingIP():string; 50 property UserName: string read FUserName write FUserName; 51 property UserPassword: string read FUserPassword write FUserPassword; 52 property BorrowDirectory: string read FBorrowDirectory write FBorrowDirectory; 53 property BorrowPort: Integer read FBorrowPort write FBorrowPort; 54 property OnFtpNotifyEvent: TFtpNotifyEvent read FOnFtpNotifyEvent write FOnFtpNotifyEvent; 55 end; 56 57 implementation 58 59 {------------------------------------------------------------------------------- 60 过程名: TFTPServer.Create 61 功能: 创建函数 62 参数: 无 63 返回值: 无 64 -------------------------------------------------------------------------------} 65 constructor TFTPServer.Create; 66 begin 67 IdFTPServer := tIdFTPServer.create( nil ) ; 68 IdFTPServer.DefaultPort := 21; //默认端口号 69 IdFTPServer.AllowAnonymousLogin := False; //是否允许匿名登录 70 IdFTPServer.EmulateSystem := ftpsUNIX; 71 IdFTPServer.HelpReply.text := '帮助还未实现！'; 72 IdFTPServer.OnChangeDirectory := IdFTPServer1ChangeDirectory; 73 IdFTPServer.OnGetFileSize := IdFTPServer1GetFileSize; 74 IdFTPServer.OnListDirectory := IdFTPServer1ListDirectory; 75 IdFTPServer.OnUserLogin := IdFTPServer1UserLogin; 76 IdFTPServer.OnRenameFile := IdFTPServer1RenameFile; 77 IdFTPServer.OnDeleteFile := IdFTPServer1DeleteFile; 78 IdFTPServer.OnRetrieveFile := IdFTPServer1RetrieveFile; 79 IdFTPServer.OnStoreFile := IdFTPServer1StoreFile; 80 IdFTPServer.OnMakeDirectory := IdFTPServer1MakeDirectory; 81 IdFTPServer.OnRemoveDirectory := IdFTPServer1RemoveDirectory; 82 IdFTPServer.Greeting.Text.Text := '欢迎进入FTP服务器'; 83 IdFTPServer.Greeting.NumericCode := 220; 84 IdFTPServer.OnDisconnect := IdFTPServer1DisConnect; 85 with IdFTPServer.CommandHandlers.add do 86 begin 87 Command := 'XCRC'; //可以迅速验证所下载的文档是否和源文档一样 88 OnCommand := IdFTPServer1CommandXCRC; 89 end; 90 end; 91 {------------------------------------------------------------------------------- 92 过程名: CalculateCRC 93 功能: 计算CRC 94 参数: const path: string 95 返回值: string 96 -------------------------------------------------------------------------------} 97 function CalculateCRC( const path: string ) : string; 98 var 99 f: tfilestream; 100 value: dword; 101 IdHashCRC32: TIdHashCRC32; 102 begin 103 IdHashCRC32 := nil; 104 f := nil; 105 try 106 IdHashCRC32 := TIdHashCRC32.create; 107 f := TFileStream.create( path, fmOpenRead or fmShareDenyWrite ) ; 108 value := IdHashCRC32.HashValue( f ) ; 109 result := inttohex( value, 8 ) ; 110 finally 111 f.free; 112 IdHashCRC32.free; 113 end; 114 end; 115 116 {------------------------------------------------------------------------------- 117 过程名: TFTPServer.IdFTPServer1CommandXCRC 118 功能: XCRC命令 119 参数: ASender: TIdCommand 120 返回值: 无 121 -------------------------------------------------------------------------------} 122 procedure TFTPServer.IdFTPServer1CommandXCRC( ASender: TIdCommand ) ; 123 // note, this is made up, and not defined in any rfc. 124 var 125 s: string; 126 begin 127 with TIdFTPServerThread( ASender.Thread ) do 128 begin 129 if Authenticated then 130 begin 131 try 132 s := ProcessPath( CurrentDir, ASender.UnparsedParams ) ; 133 s := TransLatePath( s, TIdFTPServerThread( ASender.Thread ) .HomeDir ) ; 134 ASender.Reply.SetReply( 213, CalculateCRC( s ) ) ; 135 except 136 ASender.Reply.SetReply( 500, 'file error' ) ; 137 end; 138 end; 139 end; 140 end; 141 142 {------------------------------------------------------------------------------- 143 过程名: TFTPServer.Destroy 144 功能: 析构函数 145 参数: 无 146 返回值: 无 147 -------------------------------------------------------------------------------} 148 destructor TFTPServer.Destroy; 149 begin 150 IdFTPServer.free; 151 inherited destroy; 152 end; 153 154 function StartsWith( const str, substr: string ) : boolean; 155 begin 156 result := copy( str, 1, length( substr ) ) = substr; 157 end; 158 159 {------------------------------------------------------------------------------- 160 过程名: TFTPServer.Run 161 功能: 开启服务 162 参数: 无 163 返回值: 无 164 -------------------------------------------------------------------------------} 165 procedure TFTPServer.Run; 166 begin 167 IdFTPServer.DefaultPort := BorrowPort; 168 IdFTPServer.Active := True; 169 end; 170 171 {------------------------------------------------------------------------------- 172 过程名: TFTPServer.Stop 173 功能: 关闭服务 174 参数: 无 175 返回值: 无 176 -------------------------------------------------------------------------------} 177 procedure TFTPServer.Stop; 178 begin 179 IdFTPServer.Active := False; 180 end; 181 182 {------------------------------------------------------------------------------- 183 过程名: TFTPServer.GetBindingIP 184 功能: 获取绑定的IP地址 185 参数: 186 返回值: string 187 -------------------------------------------------------------------------------} 188 function TFTPServer.GetBindingIP():string ; 189 begin 190 Result := GStack.LocalAddress; 191 end; 192 {------------------------------------------------------------------------------- 193 过程名: BackSlashToSlash 194 功能: 反斜杠到斜杠 195 参数: const str: string 196 返回值: string 197 -------------------------------------------------------------------------------} 198 function BackSlashToSlash( const str: string ) : string; 199 var 200 a: dword; 201 begin 202 result := str; 203 for a := 1 to length( result ) do 204 if result[a] = '/' then 205 result[a] := '/'; 206 end; 207 208 {------------------------------------------------------------------------------- 209 过程名: SlashToBackSlash 210 功能: 斜杠到反斜杠 211 参数: const str: string 212 返回值: string 213 -------------------------------------------------------------------------------} 214 function SlashToBackSlash( const str: string ) : string; 215 var 216 a: dword; 217 begin 218 result := str; 219 for a := 1 to length( result ) do 220 if result[a] = '/' then 221 result[a] := '/'; 222 end; 223 224 {------------------------------------------------------------------------------- 225 过程名: TFTPServer.TransLatePath 226 功能: 路径名称翻译 227 参数: const APathname, homeDir: string 228 返回值: string 229 -------------------------------------------------------------------------------} 230 function TFTPServer.TransLatePath( const APathname, homeDir: string ) : string; 231 var 232 tmppath: string; 233 begin 234 result := SlashToBackSlash(Utf8ToAnsi(homeDir) ) ; 235 tmppath := SlashToBackSlash( Utf8ToAnsi(APathname) ) ; 236 if homedir = '/' then 237 begin 238 result := tmppath; 239 exit; 240 end; 241 242 if length( APathname ) = 0 then 243 exit; 244 if result[length( result ) ] = '/' then 245 result := copy( result, 1, length( result ) - 1 ) ; 246 if tmppath[1] <> '/' then 247 result := result + '/'; 248 result := result + tmppath; 249 end; 250 251 {------------------------------------------------------------------------------- 252 过程名: GetNewDirectory 253 功能: 得到新目录 254 参数: old, action: string 255 返回值: string 256 -------------------------------------------------------------------------------} 257 function GetNewDirectory( old, action: string ) : string; 258 var 259 a: integer; 260 begin 261 if action = '../' then 262 begin 263 if old = '/' then 264 begin 265 result := old; 266 exit; 267 end; 268 a := length( old ) - 1; 269 while ( old[a] <> '/' ) and ( old[a] <> '/' ) do 270 dec( a ) ; 271 result := copy( old, 1, a ) ; 272 exit; 273 end; 274 if ( action[1] = '/' ) or ( action[1] = '/' ) then 275 result := action 276 else 277 result := old + action; 278 end; 279 280 {------------------------------------------------------------------------------- 281 过程名: TFTPServer.IdFTPServer1UserLogin 282 功能: 允许服务器执行一个客户端连接的用户帐户身份验证 283 参数: ASender: TIdFTPServerThread; const AUsername, APassword: string; var AAuthenticated: Boolean 284 返回值: 无 285 -------------------------------------------------------------------------------} 286 procedure TFTPServer.IdFTPServer1UserLogin( ASender: TIdFTPServerThread; 287 const AUsername, APassword: string; var AAuthenticated: Boolean ) ; 288 begin 289 AAuthenticated := ( AUsername = UserName ) and ( APassword = UserPassword ) ; 290 if not AAuthenticated then 291 exit; 292 ASender.HomeDir := AnsiToUtf8(BorrowDirectory); 293 asender.currentdir := '/'; 294 if Assigned(FOnFtpNotifyEvent) then 295 OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'用户登录服务器'); 296 end; 297 298 {------------------------------------------------------------------------------- 299 过程名: TFTPServer.IdFTPServer1ListDirectory 300 功能: 允许服务器生成格式化的目录列表 301 参数: ASender: TIdFTPServerThread; const APath: string; ADirectoryListing: TIdFTPListItems 302 返回值: 无 303 -------------------------------------------------------------------------------} 304 procedure TFTPServer.IdFTPServer1ListDirectory( ASender: TIdFTPServerThread; const APath: string; ADirectoryListing: TIdFTPListItems ) ; 305 306 procedure AddlistItem( aDirectoryListing: TIdFTPListItems; Filename: string; ItemType: TIdDirItemType; size: int64; date: tdatetime ) ; 307 var 308 listitem: TIdFTPListItem; 309 begin 310 listitem := aDirectoryListing.Add; 311 listitem.ItemType := ItemType; //表示一个文件系统的属性集 312 listitem.FileName := AnsiToUtf8(Filename); //名称分配给目录中的列表项,这里防止了中文乱码 313 listitem.OwnerName := 'anonymous';//代表了用户拥有的文件或目录项的名称 314 listitem.GroupName := 'all'; //指定组名拥有的文件名称或目录条目 315 listitem.OwnerPermissions := 'rwx'; //拥有者权限，R读W写X执行 316 listitem.GroupPermissions := 'rwx'; //组拥有者权限 317 listitem.UserPermissions := 'rwx'; //用户权限，基于用户和组权限 318 listitem.Size := size; 319 listitem.ModifiedDate := date; 320 end; 321 322 var 323 f: tsearchrec; 324 a: integer; 325 begin 326 ADirectoryListing.DirectoryName := apath; 327 a := FindFirst( TransLatePath( apath, ASender.HomeDir ) + '*.*', faAnyFile, f ) ; 328 while ( a = 0 ) do 329 begin 330 if ( f.Attr and faDirectory > 0 ) then 331 AddlistItem( ADirectoryListing, f.Name, ditDirectory, f.size, FileDateToDateTime( f.Time ) ) 332 else 333 AddlistItem( ADirectoryListing, f.Name, ditFile, f.size, FileDateToDateTime( f.Time ) ) ; 334 a := FindNext( f ) ; 335 end; 336 337 FindClose( f ) ; 338 end; 339 340 {------------------------------------------------------------------------------- 341 过程名: TFTPServer.IdFTPServer1RenameFile 342 功能: 允许服务器重命名服务器文件系统中的文件 343 参数: ASender: TIdFTPServerThread; const ARenameFromFile, ARenameToFile: string 344 返回值: 无 345 -------------------------------------------------------------------------------} 346 procedure TFTPServer.IdFTPServer1RenameFile( ASender: TIdFTPServerThread; 347 const ARenameFromFile, ARenameToFile: string ) ; 348 begin 349 try 350 if not MoveFile( pchar( TransLatePath( ARenameFromFile, ASender.HomeDir ) ) , pchar( TransLatePath( ARenameToFile, ASender.HomeDir ) ) ) then 351 RaiseLastOSError; 352 except 353 on e:Exception do 354 begin 355 if Assigned(FOnFtpNotifyEvent) then 356 OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'重命名文件[' + Utf8ToAnsi(ARenameFromFile) + |
2023-10-27
2022-08-15
2022-08-17
2022-09-23
2022-08-13
六六分期app的软件客服如何联系？不知道吗？加qq群【895510560】即可！标题：六六分期
今天小编告诉大家如何处理win10系统火狐flash插件总是崩溃的问题，可能很多用户都不知
今天小编告诉大家如何对win10系统删除桌面回收站图标进行设置，可能很多用户都不知道
今天小编告诉大家如何对win10系统电脑设置节能降温的设置方法，想必大家都遇到过需要
我们在使用xp系统的过程中,经常需要对xp系统无线网络安装向导设置进行设置，可能很多
今天小编告诉大家如何处理win7系统玩cf老是与主机连接不稳定的问题，可能很多用户都不
电脑对日常生活的重要性小编就不多说了，可是一旦碰到win7系统设置cf烟雾头的问题，很
我们在日常使用电脑的时候，有的小伙伴们可能在打开应用的时候会遇见提示应用程序无法
今天小编告诉大家如何对win7系统打开vcf文件进行设置，可能很多用户都不知道怎么对win
今天小编告诉大家如何对win10系统s4开启USB调试模式进行设置，可能很多用户都不知道怎
请发表评论