TCPIP 使网络连接驱向简单化

    技术2022-05-11  14

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

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

    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)