UindexFTP基于ICS实现的FTP操作类[转]

//-----------------------------------------

//组件定义CUindexFTP类

//编写环境:Borland Delphi 7.0 +WinXP

//编写时间:12:47 11.21

//作者地址:****** **

//实现功能:搜索引擎核心类之一,实现一个简化FTP操作的控件

//-----------------------------------------

//更新日志:

//14:51 2006-11-7

//ddd50:修正了新添加站点无法搜索的错误并修改相关错误.

//ZengJun:允许站点入口地址不填写结束的斜杠.

//ZengJun:被分到VIP分组的站点排名更加靠前.

//ZengJun:优化代码,对已经检索的且没有更新的网页不记录内容.

//

//12:54 2006-11-6

//ZengJun:借助于FastMM对程序进行内存泄漏检查,重写了替换函数等存在内存泄漏的类,再次规范化代码.

//LRCMP4工作室:在他(QQ:472053531)的建议下,在程序新建查询线程前处理一次消息,避免界面出现"卡"的现象.

//ZengJun:增加网站列表导入导出功能,整理代码,将不常用的字符串函数放于NCstring.PAS中.

//

//12:10 2006-11-3

//ZengJun:修正信息片算法的一处不合理,提高信息片算法的效率.

//ZengJun:应正龙数据要求,可以自定义程序版权,可搜索多级子域名,添加仅搜索指定关键词功能.

//ZengJun:增加违禁关键字检查功能,并可以打印违禁网页列表.

//

//13:08 2006-10-29

//ZengJun:修正发现的错误,优化编码,R2.Beta测试继续.

//ZengJun:不纪录无意义的小数字,对网页URL跳转进行检查,改善收录不合格链接的情况.

//ZengJun:修正SQLserver数据库创建脚本中未实现部分字段唯一性约束的错误.

//ZengJun:将ASP.Net网页部分与VS.Net编辑环境脱离,用户可以直接编辑网页文件并立即在IIS上看到修改效果.

//

//13:32 2006-10-19

//ZengJun:修正网页显示时空标题网页为正文首行.

//ZengJun:加入时间栏图标,当程序在运行时点叉叉按钮会缩小到时间栏中.

//ZengJun:信息片算法在进行动态排序时,由于未检查索引范围,导致程序崩溃,现已解决.

//ZengJun:进度条和界面的刷新占用了大量资源,导致CPU一直100%,现在改为在几个关键点才显示进度.

//

//21:29 2006-10-16

//zlnic:感谢咸阳市正龙资讯有限公司,赞助服务器一台(双奔腾四2.4G+512M内存),Uindex非常感谢!

//ZengJun:修正在SQLserver上调试时发现的错误,优化测试版源代码.

//ZengJun:加入对禁止内容检测支持,用户可以自定义敏感词表以实现选择性标志.

//ZengJun:改善对明显的跳转和无意义网页的检测.

//

//11:40 2006-10-15

//cnjlc:修改CHM文档,加入SQLserver数据库的格式描述.

//ZengJun:实际测试了ASPX搜索页面,修正R1发行版时留下的若干问题.

//ZengJun:索引程序可以自动识别CSW,将CSW5.0的一个DLL和两个词库文件复制到Lucene.Net.exe相同目录即可实现中文分词索引.

//ZengJun:加入站点搜索页面上限值(默认5120),同时增加禁止访问列表,站点导出功能.

//

//20:36 2006-10-13

//飞来飞去:搜索运行一段时间后CPU占用变大,原因是信息片全部存储,现已修正为存储哈希值并动态调整信息片概率列表,信息片算法最多额外占用96KB.

//ZengJun:信息片拆分算法存在问题,效率和逻辑现已修正.

//

//15:03 2006-10-6

//ZengJun:Uindex第一版发行,Uindex.R1首次将WWW搜索和FTP搜索作为合集发行.

//ZengJun:界面部分设计完成,发行这个版本花费了我4个月的休息时间,修改1895次,源代码文件合计5820行.

//

//11:23 2006-10-1

//ZengJun:开始实现界面逻辑,准备发行UindexWeb.R1.

//ZengJun:PageRank物理分值计算模块设计完成,网页长度和连接信息比均考虑在内,主要使用正态分布(GAUSS)函数,和拟GAMMA函数计算分值.

//ZengJun:网页解析组件在处理弹出窗口时存在问题,更正为在onurl时先效验地址合法性.

//ZengJun:信息片算法开始发挥功用,搜索网页结果中无效信息明显减少.

//

//20:23 2006-9-26

//ZengJun:WWW搜索发布内部测试版本,UindexWeb.R1,这个版本的发布经历了1260次修改,仍然有很多未定的算法,功能.

//ZengJun:ICS.V6.Beta的HTTPCli组件在使用异步传输时出现超时处理异常,修正为阻塞模式.

//

//21:43 2006-9-15

//ZengJun:WWW搜索陷入困境,开学后实习结束了,编写Web搜索的热情反而比不上修改UindexFTP的热情,面对困难都想退却了,等待状态好转继续(实际上花费了整整1个月的休息时间).

//

//21:17 2006-8-29

//ZengJun:在发现连接算法中使用多次递归,而不是像信息片算法那样一次完成,主要是为了算法清晰,例外主要的时间也不是花在Html分析上而是在网页读取上,更重要的工作是协调多个线程。

//ZengJun:在与TPerlRegEx进行网页链接提取的比较中,RegEx把操作变得简单很多,但是搜索项目不吝惜复杂,自主实现链接分析,换来的是正则无法比拟的速度.

//

//2006-8-22

//ZengJun:设计将更多的人的因素加到搜索中,比如文件类型识别,域名IP归属识别,网页编程语言识别等。

//ZengJun:当前版本Delphi 7 Entireprise Edition 字符处理函数posex存在bug,当string为空时会出现非法读取错误,因此在使用前需要判断一下,这里没有新写一个posex函数.

//

unit UindexFTP;
interface
uses
SysUtils, Classes ,StrUtils ,OverbyteIcsWndControl, OverbyteIcsFtpCli;
type
TFindFile  = procedure(FileName,EditTime,Attribute,Owner,Group,Size:string) of object;
TFindDir   = procedure(DirName,EditTime,Attribute,Owner,Group:string) of object;
TOnMessage = procedure(msg:string) of object;
TOnTimeOut = procedure(status:integer) of object;
CUindexFTP = class(TComponent)
private
//来自ICS的TFTPclient控件,基本上成了Winsock的实现
//结果我不得不写一个更加友好的FTP组件UindexFTP
MySpider    : TFtpClient;
Fusername   : string;
Fpassword   : string;
Fserverport : integer;
Fserver     : string;
Fversion    : string;
FWorkDir    : string;
FFindFile   : TFindFile;
FFindDir    : TFindDir;
FOnMessage  : TOnMessage;
FOnTimeOut  : TOnTimeOut;
procedure   Display(Sender: TObject; var Msg: String);
procedure   Error(Sender: TObject; var Msg: String);
procedure   StateChange(Sender: TObject);
procedure   ParseList(List:string);
protected
Ftimeout        : integer;
FConnTimeOut    : integer;
Fstatus         : integer;
public
constructor Create(Owner: TComponent); override;
destructor  Destroy; override;
function    connect():boolean;
function    ChangeDir(dir:string):boolean;
function    ListDir():integer;
published
property TimeOut     : integer      Read Ftimeout     Write Ftimeout;
property Host        : string       Read Fserver      Write Fserver;
property User        : string       Read Fusername    Write Fusername;
Property Pass        : string       Read Fpassword    Write Fpassword;
property Port        : integer      Read Fserverport  Write Fserverport;
property ConnTimeOut : integer      read FConnTimeOut Write FConnTimeOut;
property OnFindFile  : TFindFile    Read FFindFile    write FFindFile;
property OnFindDir   : TFindDir     read FFindDir     write FFindDir;
Property CurrentDir  : string       read FWorkDir     write FWorkDir;
property OnMessage   : TOnMessage   read FOnMessage   write FOnMessage;
property OnTimeOut   : TOnTimeOut   read FOnTimeOut   write FOnTimeOut;
property Status      : integer      read Fstatus      write Fstatus;
Property version     : string       read Fversion;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('FPiette', [CUindexFTP]);
end;
{ CUindexFTP }
function CUindexFTP.ChangeDir(dir: string): boolean;
begin
result:=false;
if MySpider.Connected then begin
MySpider.HostDirName:=dir;
FWorkDir:=dir;
result:=MySpider.Cwd;
end else begin
if assigned(OnTimeOut) then OnTimeOut(MySpider.StatusCode);
end;
end;
function CUindexFTP.connect: boolean;
begin
result :=false;
MySpider.HostName:=Fserver;
MySpider.UserName:=Fusername;
MySpider.PassWord:=Fpassword;
MySpider.Port:=IntToStr(Fserverport);
MySpider.Timeout:=Ftimeout;
MySpider.MultiThreaded:=true;
if MySpider.Open then
if MySpider.User then
result :=MySpider.Pass;
end;
constructor CUindexFTP.Create(Owner: TComponent);
begin
inherited Create(Owner);
MySpider:=TFtpClient.Create(nil);
MySpider.OnDisplay:=Display;
MySpider.OnError:=Error;
MySpider.OnStateChange:=StateChange;
Fserverport:=21;
Fusername:='anonymous';
Fversion :='UindexFTP V3.0';
Ftimeout :=10;
FConnTimeOut:=10;
end;
destructor CUindexFTP.Destroy;
begin
MySpider.Abort;
MySpider.Free;
inherited Destroy;
end;
procedure CUindexFTP.Display(Sender: TObject; var Msg: String);
begin
if assigned(OnMessage) then OnMessage(Msg);
end;
procedure CUindexFTP.Error(Sender: TObject; var Msg: String);
begin
if assigned(OnMessage) then OnMessage(Msg);
end;
function CUindexFTP.ListDir: integer;
var stm:TMemoryStream;
mylist:TStringList;
buffer:string;
ItemCount:integer;
begin
result:=0;
if MySpider.Connected then begin
stm:=TMemoryStream.Create;
mylist:=TStringList.Create;
try
MySpider.LocalStream:=stm;
if MySpider.Dir then begin
setlength(buffer,stm.size);
stm.Seek(0, soFromBeginning);
stm.Read(buffer[1],stm.size);
mylist.Text:=buffer;
for ItemCount := 0 to mylist.Count-1 do
begin
ParseList(mylist[ItemCount]);
end;
end;
finally
MySpider.LocalStream:=nil;
stm.Free;
mylist.Free;
end;
end else begin
if assigned(OnTimeOut) then OnTimeOut(MySpider.StatusCode);
end;
end;
procedure CUindexFTP.ParseList(List: string);
var i,j,k:integer;
Line,FileDate,FileName,FileAttribute,Owner,Group,FileSize:string;
begin
if List<>'' then begin
Line:=List;
if Line[1] in ['0'..'9'] then begin
//WinNT FTP Service
//微软的IIS附带的 FTP 服务器 DOS 响应选中
i:=pos(#32,Line);
FileDate:=Copy(Line,1,i-1);
Line:=Trim(Copy(Line,i+1,length(Line)-i));
j:=pos(#32,Line);
FileDate:=FileDate+' '+Copy(Line,1,j-1);
Line:=Trim(Copy(Line,j+1,length(Line)-j));
k:=pos('>',Line);
if k>0 then begin
//发现的是目录
FileName:=Trim(Copy(Line,k+1,length(Line)-k));
if Assigned(OnFindDir) then OnFindDir(FileName,FileDate,'','','');
end else begin
//发现的是文件
k:=pos(#32,Line);
FileSize:=Copy(Line,1,k-1);
FileName:=Trim(Copy(Line,k+1,length(Line)-k));
if Assigned(OnFindFile) then OnFindFile(FileName,FileDate,'','','',FileSize);
end;
end else begin
//UNIX SVR 4 或其兼容服务器 目录列表格式:
//drwxr-xr-x   6 1001   1001       512 Jan 19 2006 download
//属性      保留 用户   组         大小 时间       文件名
i:=pos(#32,Line);
FileAttribute:=Copy(Line,1,i-1);
Line:=Trim(Copy(Line,i+1,length(Line)-i));
//6 1001   1001       512 Jan 19 2006 download
i:=pos(#32,Line);
//保留
Line:=Trim(Copy(Line,i+1,length(Line)-i));
//1001   1001       512 Jan 19 2006 download
i:=pos(#32,Line);
Owner:=Copy(Line,1,i-1);
Line:=Trim(Copy(Line,i+1,length(Line)-i));
//1001       512 Jan 19 2006 download
i:=pos(#32,Line);
Group:=Copy(Line,1,i-1);
Line:=Trim(Copy(Line,i+1,length(Line)-i));
//512 Jan 19 2006 download
i:=pos(#32,Line);
FileSize:=Copy(Line,1,i-1);
Line:=Trim(Copy(Line,i+1,length(Line)-i));
//-------------------------------------------------------------------
//Jan 19 2006 download
//查找 3 次空格,做trim即可得到文件名
//-------------------------------------------------------------------
i:=pos(#32,Line);
FileDate:=Copy(Line,1,i-1);
Line:=Trim(Copy(Line,i+1,length(Line)-i));
i:=pos(#32,Line);
FileDate:=FileDate +' '+ Copy(Line,1,i-1);
Line:=Trim(Copy(Line,i+1,length(Line)-i));
i:=pos(#32,Line);
FileDate:=FileDate +' '+ Copy(Line,1,i-1);
FileName:=Trim(Copy(Line,i+1,length(Line)-i));
if LowerCase(List[1])='d' then begin
if Assigned(OnFindDir) then OnFindDir(FileName,FileDate,FileAttribute,Owner,Group);
end else begin
if Assigned(OnFindFile) then OnFindFile(FileName,FileDate,FileAttribute,Owner,Group,FileSize);
end;
end;
end;
end;
procedure CUindexFTP.StateChange(Sender: TObject);
begin
Fstatus:=MySpider.StatusCode;
end;
end.