CSDN博客

img mysine

TCP/IP 使网络连接驱向简单化

发表于2001/7/30 16:40:00  925人阅读

自创改编小控件,不是一个哟!!

仔细看一下,你一定会喜欢的!

unit tcpip;


(*@/// interface *)
interface
  (*$x+ *)

(*@/// uses *)
uses
  sysutils,
  classes,
  controls,
  forms,
  winsock,
(*$ifdef ver80 *)
  winprocs,
  wintypes,
(*$else *)
  windows,
(*$endif *)
  messages,
  ip_misc;
(*@///*)

type
  t_socket_state = (invalid,valid,connected,state_unknown);
  t_timemode     = (tzUTC,tzLocal);
  t_ftp_mode     = (tftp_download,tftp_upload,tftp_getdir);
  t_filetype     = (ft_none, ft_dir, ft_file, ft_link);
  t_lpr_types    = (lp_plain, lp_ascii, lp_dvi, lp_plot, lp_ditroff, lp_ps,
                    lp_pr, lp_fortran, lp_troff, lp_raster, lp_cif);
  t_encoding     = (ec_base64, ec_quotedprintable, ec_none);
  TTraceLevel    = (tt_proto_sent, tt_proto_get, tt_socket);
(*@///   t_filedata=record ... end; *)
t_filedata=packed record
  filetype: t_filetype;
  size: integer;
  name: string;
  datetime: TDateTime;
  end;
(*@///*)
  ETcpIpError=class(Exception);
(*@///   ESocketError=class(ETcpIpError) *)
ESocketError=class(ETcpIpError)
  errornumber: word;
  constructor Create(number:word);
  end;
(*@///0000000301*)
(*@///   EProtocolError=class(ETcpIpError) *)
EProtocolError=class(ETcpIpError)
  errornumber: word;
  protocoll: string;
  constructor Create(const proto,Msg:String; number:word);
  end;
(*@///0000000401*)
(*@///   EProtocolBusy=class(ETcpIpError) *)
EProtocolBusy=class(ETcpIpError)
  constructor Create;
  end;
(*@///0000000201*)

  TTraceProc = procedure (const s:string; level:TTraceLevel) of object;
  TDataTransferProc = procedure (Sender:TObject; mode: t_ftp_mode; bytes: integer) of object;
  TFTPActionCompleteProc = procedure (Sender:TObject; mode: t_ftp_mode) of object;

  { The base component }
(*@///   T_TcpIp = class(TComponent) *)
T_TcpIp = class(TComponent)
protected
  f_handle: THandle;
  f_Socket: tsocket;
  f_hostname: string;
  f_tracer: TTraceProc;
  f_socket_number: smallint;
  ip_address: longint;  (* Network order! *)
  f_eof: boolean;
  f_newdata: boolean;
  f_stream: TStream;
  f_buffer: pointer;
  f_async: boolean;
  f_logged_in: boolean;
  procedure WndProc(var Msg : TMessage); virtual;
  function Create_Socket:TSocket;
  procedure connect_socket(var socket:TSocket; Socket_number:smallint;ip_address:longint);
  procedure bind_socket(var socket:TSocket; out_port_min,out_port_max: word);
  procedure open_socket_out(var socket:TSocket; Socket_number:smallint;ip_address:longint); virtual;
  procedure open_socket_in(var socket:TSocket; Socket_number:smallint;ip_address:longint);
  procedure close_socket(var socket:TSocket);
  procedure close_socket_linger(var socket:TSocket);
  function accept_socket_in(socket:TSocket; var SockInfo:TSockAddr):TSocket;
  function socket_state(socket:TSocket):T_Socket_State;
  function Socket_by_name(const service:string):smallint;
  function read_line(f_socket:TSocket):string;
  procedure read_var(f_socket:TSocket; var buf; size:integer; var _ok:integer);
  procedure write_buf(f_socket:TSocket; const buf; size:integer);
  procedure write_s(f_socket:TSocket; const s:string);
  procedure SetStream(value:TStream); (* for the property write of f_stream *)
  procedure action; VIRTUAL;
{   property Async:boolean read f_async write f_async default false; }
  procedure SendCommand(const s:string); VIRTUAL;
public
  procedure Login; virtual;
  procedure Logout; virtual;
  property OnTrace:TTraceProc read f_tracer write f_tracer;
  constructor Create(Aowner:TComponent); override;
  destructor Destroy; override;
  function eof(f_socket:TSocket):boolean; VIRTUAL;
  end;
(*@///0000002901*)

  { Finger client and demon      // RFC 1288 }
(*@///   T_Finger = class(T_TcpIp) *)
T_Finger = class(T_TcpIp)
protected
  f_user: string;
public
  constructor Create(Aowner:TComponent); override;
  property stream: TStream read f_stream;
  procedure action; override;
published
  property Hostname: string read f_hostname write f_hostname;
  property User: string read f_user write f_user;
  end;
(*@///0000000118*)
(*@///   T_Fingerd = class(T_TcpIp) *)
type
(*@///   TFingerInfo=record *)
TFingerInfo=record
  hostname: string;
  address: longint;
  request: string;
  end;
(*@///0000000203*)
  TFingerRequest=procedure (Sender:TObject; FingerInfo:TFingerInfo) of object;

T_Fingerd = class(T_TcpIp)
protected
  f_fingerrequest: TFingerRequest;
  f_answer: TStringList;
  procedure WndProc(var Msg : TMessage); override;
  procedure SetAnswer(Value: TStringList);
  procedure do_action; virtual;                    (* The real action *)
public
  constructor Create(Aowner:TComponent); override;
  destructor Destroy; override;
  procedure action; override;                      (* Only to set up *)
published
  property OnFingerRequest:TFingerRequest read f_fingerrequest write f_fingerrequest;
  property Answer: TStringList read f_answer write SetAnswer;
  end;
(*@///0000000503*)

  { HTTP and FTP - the file transfer protocols }
(*@///   T_HTTP = class(T_TcpIp)          // RFC 1945 (V1.0), RFC 2068 (V1.1) *)
T_HTTP = class(T_TcpIp)
protected
  f_url: string;
  f_path: string;   (* The real request string, calculated internally *)
  f_proxy: string;
  f_sender: string;
  f_reference: string;
  f_agent: string;
  f_nocache: boolean;
  f_status_nr: integer;
  f_status_txt: string;
  f_size: integer;
  f_type: string;
  f_author: string;
  f_do_author: TStringList;
  f_content_post: string;
  procedure GetHead;
  procedure GetBody;
  procedure sendrequest(const method,version: string);
  procedure getanswer;
public
  property stream: TStream read f_stream write SetStream;
  property content_size: integer read f_size;
  property content_type: string read f_type;
  property status_number: integer read f_status_nr;
  property status_text: string read f_status_txt;
  procedure action; override;                          (* the GET method *)
  procedure Post;                                      (* the POST method, untested!  *)
  constructor Create(Aowner:TComponent); override;
  destructor Destroy; override;
  procedure DoBasicAuthorization(const username,password:string);
  property AuthorizationRequest: TStringList read f_do_author;
  property Authorization: string read f_author write f_author;
published
  property URL: string read f_url write f_url;
  property Proxy: string read f_proxy write f_proxy;
  property Sender: string read f_sender write f_sender;
  property Agent: string read f_agent write f_agent;
  property Reference: string read f_reference write f_reference;
  property NoCache: boolean read f_nocache write f_nocache;
  property ContentTypePost: string read f_content_post write f_content_post;
  property OnTrace;
  end;
(*@///0000000C01*)
(*@///   T_FTP = class(T_TcpIp)           // RFC 959 *)
T_FTP = class(T_TcpIp)
protected
  f_url: string;
  f_status_nr: integer;
  f_status_txt: string;
  f_user: string;
  f_password: string;
  f_comm_socket: tsocket;
  f_passive: boolean;
  f_port: word;
  f_mode: t_ftp_mode;
  f_mode_intern: t_ftp_mode;
  f_cur_dir: TStringList;
  f_cur_dir_index: integer;
  f_size: integer;
  f_busy: boolean;
  f_onaction: TFTPActionCompleteProc;
  f_ondata_got: TDataTransferProc;
  f_dir_stream: TMemoryStream;
  f_async_data: boolean;
  procedure response;
  function read_line_comm:string;
  procedure SendCommand(const s:string); override;
  procedure get_datasocket;
  procedure WndProc(var Msg : TMessage); override;
  function do_write:boolean;
  function do_read:boolean;
  procedure finish_upload;
  procedure finish_download;
  procedure finish_getdir;
public   (* will become public once tested *)
  procedure changedir(const f_dir:string);
  procedure removefile(const filename:string);
  procedure removedir(const dirname:string);
  procedure makedir(const dirname:string);
  procedure renamefile(const prior,after:string);
  procedure getdir(const dirname:string);
  function getdirentry:t_filedata;
public
  property stream: TStream read f_stream write SetStream;
  property status_number: integer read f_status_nr;
  property status_text: string read f_status_txt;
  property busy: boolean read f_busy;
  procedure login; override;
  procedure logout; override;
  procedure download;
  procedure upload;
  procedure abort;
  procedure noop;
  constructor Create(Aowner:TComponent); override;
  destructor Destroy; override;
  procedure action; override;
  property Size:integer read f_size;
published
  property Hostname: string read f_hostname write f_hostname;
  property URI: string read f_url write f_url;
  property Password:string read f_password write f_password;
  property Username:string read f_user write f_user;
  property Passive:boolean read f_passive write f_passive default true;
  property Port:word read f_port write f_port default 21;
  property Mode:t_ftp_mode read f_mode write f_mode default tftp_download;
  property OnDataReceived:TDataTransferProc read f_ondata_got write f_ondata_got;
  property OnActionComplete:TFTPActionCompleteProc read f_onaction write f_onaction;
  property Async:boolean read f_async_data write f_async_data;
  property OnTrace;
end;
(*@///0000003501*)

  { Time, RExec, LPR - the most useful UNIX services }
(*@///   T_Time = class(T_TcpIp)          // RFC 868 *)
T_Time = class(T_TcpIp)
protected
  f_time: TDateTime;
  f_timemode: T_TimeMode;
public
  constructor Create(Aowner:TComponent); override;
  procedure action; override;
  property time: TDateTime read f_time;
published
  property Hostname: string read f_hostname write f_hostname;
  property TimeMode: T_TimeMode read f_timemode write f_timemode default tzUTC;
  end;
(*@///0000000103*)
(*@///   T_RCommon = class(T_TcpIp) *)
T_RCommon = class(T_TcpIp)
protected
  procedure open_socket_out(var socket:TSocket; Socket_number:smallint;ip_address:longint); override;
public
  procedure action; override;
  property stream: TStream read f_stream;
published
  property Hostname: string read f_hostname write f_hostname;
  end;
(*@///0000000103*)
(*@///   T_RExec = class(T_RCommon) *)
T_RExec = class(T_RCommon)
protected
  f_user: string;
  f_pass: string;
  f_command: string;
  procedure login; override;
public
  constructor Create(Aowner:TComponent); override;
published
  property UserName: string read f_user write f_user;
  property Password: string read f_pass write f_pass;
  property Command: string read f_command write f_command;
  end;
(*@///0000000113*)
(*@///   T_Rsh = class(T_RCommon) *)
T_Rsh = class(T_RCommon)
protected
  f_user_r: string;
  f_user_l: string;
  f_command: string;
  procedure login; override;
public
  constructor Create(Aowner:TComponent); override;
published
  property LocalUser: string read f_user_l write f_user_l;
  property RemoteUser: string read f_user_r write f_user_r;
  property Command: string read f_command write f_command;
  end;
(*@///0000000111*)
(*@///   T_lpr = class(T_TcpIp)           // RFC 1179 *)
T_lpr = class(T_TcpIp)
protected
  f_printtype: t_lpr_types;
  f_banner: boolean;
  f_count: integer;
  f_user: string;
  f_queue: string;
  f_user_mail: string;
  f_jobname: string;
  f_title: string;
  procedure response;
  procedure open_socket_out(var socket:TSocket; Socket_number:smallint;ip_address:longint); override;
public
  constructor Create(Aowner:TComponent); override;
  property stream: TStream read f_stream write SetStream;
  procedure action; override;
  procedure SendPrintData;
  procedure GetQueueStatus(detailed:boolean);
published
  property Hostname: string read f_hostname write f_hostname;
  property User: string read f_user write f_user;
  property PrintQueue: string read f_queue write f_queue;
  property MailTo: string read f_user_mail write f_user_mail;
  property JobName: string read f_jobname write f_jobname;
  property PrintType:t_lpr_types read f_printtype write f_printtype default lp_ascii;
  property CopyCount:integer read f_count write f_count default 1;
  property PrintBanner:boolean read f_banner write f_banner default false;
  property PrintTitle:string read f_title write f_title;
  end;
(*@///0000000103*)

  { The Mail and News protocols }
(*@///   T_SMTP = class(T_TcpIp)          // RFC 821 *)
T_SMTP = class(T_TcpIp)
protected
  f_user, f_host: string;
  f_status_nr: integer;
  f_status_txt: string;
  f_receipts, f_body: tstringlist;
  procedure SetBody(Value: TStringList);
  procedure SetRecipients(Value: TStringList);
  procedure response;
public
  constructor Create(Aowner:TComponent); override;
  destructor Destroy; override;
  procedure action; override;
  property Recipients: TStringlist read f_receipts write SetRecipients;
  property Message: TStringList read f_body write SetBody;
  property Sender: string read f_user write f_user;
published
  property Hostname: string read f_hostname write f_hostname;
  property OnTrace;
  end;
(*@///0000001001*)
(*@///   T_Pop3 = class(T_TcpIp)          // RFC 1725 *)
T_Pop3 = class(T_TcpIp)
protected
  f_user: string;
  f_pass: string;
  f_list: TList;
  f_mail: TStringList;
  procedure response;
public
  property Mail: TStringlist read f_mail;
  constructor Create(Aowner:TComponent); override;
  destructor Destroy; override;
  procedure action; override;     (* retrieval of first message *)
  procedure Login; override;
  procedure GetHeaders;
  procedure Logout; override;
  procedure GetMail(index: integer);
  procedure DeleteMail(index:integer);
published
  property Hostname: string read f_hostname write f_hostname;
  property UserName: string read f_user write f_user;
  property Password: string read f_pass write f_pass;
  property OnTrace;
end;
(*@///0000001701*)
(*@///   T_NNTP = class(T_TcpIp)          // RFC 977 *)
T_NNTP = class(T_TcpIp)
protected
  f_news: TStringList;
  f_newsgroups: TStringList;
  f_status_nr: integer;
  f_status_txt: string;
  procedure response;
  procedure action; override;     (* ??? *)
  procedure SetNews(value:TStringlist);
  procedure GetArticleInternally;
public
  property News: TStringlist read f_news write SetNews;
  property NewsGroups: TStringlist read f_newsgroups;
  constructor Create(Aowner:TComponent); override;
  destructor Destroy; override;
  procedure Login; override;
  procedure Logout; override;
    (* To get an article from a URL like nntp://hostname/number *)
  procedure GetArticle(const group:string; index:integer);
    (* To get an article from a URL like news:msgid *)
  procedure GetArticleID(const msgid:string);
  procedure PostArticle;
    (* Methods more for a Newsreader *)
  procedure GetAllNewsgroups;
  procedure GetNewNewsgroups(since:TDateTime);
  procedure SetGroup(const group:string; var low,high,count: integer);
  procedure GetArticleNr(index:integer);
  procedure SetCurrentArticle(index:integer);
  procedure GetCurrentArticle;
  procedure GetNextArticle;
  procedure GetPreviousArticle;
published
  property Hostname: string read f_hostname write f_hostname;
  property OnTrace;
end;
(*@///0000002301*)

  { Mail and News text components }
(*@///   T_MailNews = class(TComponent) *)
T_MailNews = class(TComponent)
protected
  f_from, f_sender, f_subject: string;
  f_body: TStringlist;
  f_add_header: TStringlist;
  f_message: TStringlist;
  f_references: string;
  f_replyto: string;
  procedure SetBody(Value: TStringList);
  procedure SetHeader(Value: TStringList);
public
  constructor Create(Aowner:TComponent); override;
  destructor Destroy; override;
  procedure action; VIRTUAL;
published
  property Sender: string read f_sender write f_sender;
  property From: string read f_from write f_from;
  property Body: TStringList read f_body write SetBody;
  property Header: TStringList read f_add_header write SetHeader;
  property Subject:string read f_subject write f_subject;
  property References:string read f_references write f_references;
  property ReplyTo:string read f_replyto write f_replyto;
end;
(*@///0000001001*)
(*@///   T_Mail = class(T_MailNews)       // RFC 822 *)
T_Mail = class(T_MailNews)
protected
  f_smtp: T_SMTP;
  f_receipts: TStringlist;
  f_cc: TStringlist;
  f_bcc: TStringlist;
  f_disclose_receipts: boolean;
  procedure SetRecipients(Value: TStringList);
  procedure SetCC(Value: TStringList);
  procedure SetBCC(Value: TStringList);
public
  constructor Create(Aowner:TComponent); override;
  destructor Destroy; override;
  procedure action; override;
published
  property SMTP: T_SMTP read f_smtp write f_smtp;
  property Disclose_Receipts: boolean read f_disclose_receipts write f_disclose_receipts default false;
  property Recipients: TStringlist read f_receipts write SetRecipients;
  property CC: TStringlist read f_cc write SetCC;
  property BCC: TStringlist read f_bcc write SetBCC;
end;
(*@///0000000601*)
(*@///   T_News = class(T_MailNews)       // RFC 850 *)
T_News = class(T_MailNews)
protected
  f_nntp: T_NNTP;
  f_newsgroups: TStringlist;
  f_organization: string;
  procedure SetNewsgroups(Value: TStringList);
public
  constructor Create(Aowner:TComponent); override;
  destructor Destroy; override;
  procedure action; override;
published
  property NNTP: T_NNTP read f_nntp write f_nntp;
  property Newsgroups: TStringlist read f_newsgroups write SetNewsgroups;
  property Organization: string read f_organization write f_organization;
end;
(*@///0000000C14*)
(*@///   T_Attachment = class(TObject) *)
T_Attachment = class(TObject)
protected
  f_kind: string;
  f_disposition: string;
  f_data: TStream;
  f_text: TStringList;
  f_encoding: T_Encoding;
  procedure SetText(value:TStringList);
  procedure SetData(value:TStream);
public
  constructor Create;
  destructor Destroy; override;
  property Kind: string read f_kind write f_kind;
  property Disposition: string read f_disposition write f_disposition;
  property Encoding: T_Encoding read f_encoding write f_encoding;
  property Text:TStringlist read f_text write SetText;
  property Data:TStream read f_data write SetData;
end;
(*@///0000000D01*)
(*@///   T_Mime = class(TComponent)      // RFC 1521 *)
T_Mime = class(TComponent)
protected
  f_mail: T_MailNews;
  boundary: string;
  f_attachment: TList;
  function GetNumberOfAttachments: integer;
public
  constructor Create(Aowner:TComponent); override;
  destructor Destroy; override;
  function AttachFile(const filename:string):integer;
  function AttachText(text: TStringList):integer;
  procedure RemoveAllAttachments;
  procedure action;
  procedure SetMail(mail: TStringlist);
  function GetAttachment(index: integer):T_Attachment;
  procedure RemoveAttachment(index: integer);
  property Attachment[index:integer]:T_Attachment read GetAttachment;
  property NumberOfAttachments: integer read GetNumberOfAttachments;
published
  property Mail: T_MailNews read f_mail write f_mail;
end;
(*@///0000000A01*)

const
  uwm_socketevent = wm_user+$100; (* my magic message number *)

var
  lpr_count: integer;          (* the current job number *)

procedure Register;
(*@///0000003B03*)
(*@/// implementation *)
implementation

0 0

相关博文

我的热门文章

img
取 消
img