| Home | Submit | Free Hosting | Link To Us | Contacts |
Pascal PPP Pascal
 Download (.zip){DEFINE DEBUG} {DEFINE SHOWINFO} {DEFINE IPDEBUG} {DEFINE IP2DEBUG} {DEFINE TERMINAL} Unit PPP; Interface Const SEND = 0; RECEIVE = 1; _dead = 0; _lcp = 1; _ncd = 2; _open = 3; DEFAULT_PROTOCOL_OFFSET = 3; {I wouldn't change this :)} IP_Protocol = $0021; {IP Datagram} LCD_Protocol = $C021; {Link Control Data - ref: LCP} NCD_Protocol = $8021; {Network Control Data} Configure_Request = 1; {Packet Codes} Configure_ACK = 2; Configure_NAK = 3; Configure_Reject = 4; Terminate_Request = 5; Terminate_ACK = 6; Code_Reject = 7; Protocol_Reject = 8; Echo_Request = 9; Echo_Reply = 10; Discard_Request = 11; Complement = $7D; {next character after Complement nc := nc XOR $32} Flag = $7E; {Start of PPP Packet, End of PPP Packet} Address = $FF; {Address field of PPP packet} Control = $03; {Control field of PPP packet} Maximum_Receive_Unit = 1; {LCP Configuration Options} Authentication_Protocol = 3; Quality_Protocol = 4; Magic_Number = 5; Protocol_Field_Compression = 7; Address_Control_Field_Compression = 8; Max_Frame_Size = 16000; Default_Frame_Size = 1500; Type IPTYPE = array[1..4] of byte; pbyte = ^byte; proc = procedure; pFrame = ^PPP_Frame; PPP_FRAME = Record Frame_Data : pbyte; Frame_Ptr : pbyte; Frame_Size : word; Frame_Complete : Boolean; Frame_Type : word; Frame_Length : longint; Comp : boolean; Prev,Next : pFrame; end; pLCPFrame = ^LCP_Frame; LCP_Frame = Record Code : Byte; Identifier : Byte; Length : Word; Data : pbyte; data_ptr : pbyte; datasize : longint; sendorreceive : byte; {send = 0/receive = 1} prev,next : pLCPFrame; end; pNCDFrame = ^NCD_Frame; NCD_Frame = Record Code : Byte; Identifier : Byte; Length : Word; Data : pbyte; data_ptr : pbyte; datasize : longint; sendorreceive : byte; {send = 0/receive = 1} prev,next : pNCDFrame; end; pIPFrame = ^IP_Frame; IP_Frame = Record Data : pbyte; data_ptr : pbyte; datasize : longint; sendorreceive : byte; {send = 0/receive = 1} prev,next : pIPFrame; end; PPP_Object = Object Private PIP : Boolean; {Packet in Progress?} r_packetcrc : word; phase : byte; {0 - dead, 1 - LCP, 2 - NCD, 3 - Open} vj_hdrc : boolean; maxslotid, compslotid : byte; ipcp : word; userinit : boolean; initfunc : proc; First_Frame, Last_Frame, Cur_Frame : pFrame; First_LCP_Frame, Last_LCP_Frame, Cur_LCP_Frame : pLCPFrame; First_NCD_Frame, Last_NCD_Frame, Cur_NCD_Frame : pNCDFrame; First_IP_Frame, Last_IP_Frame, Cur_IP_Frame : pIPFrame; NumIPFrames : word; NumLCPFrames : word; NumNCDFrames : word; Function B(var frame:pbyte):byte; Function GetChar(var frame:pbyte):char; Function GetByte(var frame:pbyte):byte; Function GetInteger(var frame:pbyte):Integer; Function GetWord(var frame:pbyte):Word; {Function GetLongint(var frame:pbyte):Longint;} {Procedure NewIPFrame(frame:pFrame);} Procedure DisposeIPFrame(frame:pIPFrame); Function GetIPFrame:pIPFrame; Procedure NewLCPFrame(frame:pFrame); Procedure DisposeLCPFrame(frame:pLCPFrame); Function GetLCPFrame:pLCPFrame; Procedure NewNCDFrame(frame:pFrame); Procedure DisposeNCDFrame(frame:pNCDFrame); Function GetNCDFrame:pNCDFrame; Procedure Request_MRU(var frame:pLCPFrame); Procedure Set_MRU(var frame:pLCPFrame); Procedure Request_PFC(var frame:pLCPFrame); Procedure ProcessLCPFrame(frame:pLCPFrame); Procedure SendLCPFrame(Code:byte;Identifier:byte; datalength:word;data:pLCPframe); Procedure HandleLCPFrames; Procedure SendIPFrame(datalength:word;data:pIPframe); Procedure HandleIPFrames; Procedure Set_IP(var frame:pNCDFrame); Procedure Set_VJ_hdrc(var frame:pNCDFrame); Procedure ProcessNCDFrame(frame:pNCDFrame); Procedure SendNCDFrame(Code:byte;Identifier:byte; datalength:word;data:pNCDframe); Procedure HandleNCDFrames; Procedure NewFrame; Procedure AddtoFrame(bte:byte); Procedure EndFrame; Procedure DisposeFrame(frame:pFrame); Procedure SendPPP(protocol:word;data:pointer); Procedure HandleIncoming; Public use_PFC : boolean; use_ADFC : boolean; IPADDR : IPTYPE; {32-bit int form of Client IP} IPSTRING : string[16]; {000.000.000.000 form of Client IP} Terminate_OK : boolean; {OK to terminate PPP session?} Frame_Size : word; {IP Datagram MAXIMUM Size} protocol_ofs : byte; Function GetLongint(var frame:pbyte):Longint; Function MakePtr(var variable):pbyte; Procedure SendLCP(Code:byte; Identifier:byte; datalength:longint;data:pbyte); Procedure SendNCD(Code:byte; Identifier:byte; datalength:longint;data:pbyte); Procedure SendIP(datalength:longint;data:pbyte); Function Carrier:boolean; Constructor Init(comport:byte;baudrate:longint;ifunc:proc); {Initializes PPP Packet Driver} Destructor Done; {Destroys PPP Packet Driver} Procedure Terminal; Procedure Dial(username,password,phone,scriptfile:string); Procedure Packet_Driver; Procedure FormatIP (b1,b2,b3,b4:byte; var ipt:iptype); Function IPstr (ip:iptype):string; Function ValidIP (s:string):boolean; Function StoIP(s:string;var IP:iptype):boolean; Function CanWrite:Boolean; end; Var oPPP : PPP_Object; Implementation Uses MODEM, {Interface to Modem} CRT, {used for arbitrary delays} CRC16, {calculates 16-bit CRC's (cyclic redundancy check's)} IP {$IFDEF TERMINAL},vesa,win,global{$ENDIF}; {$IFDEF TERMINAL} var modem_win : longint; Procedure Modem_Window; var x1,y1,x2,y2 : integer; s : string; Begin if get_handle_dialog(modem_win)<>nil then exit; x1 := maxx shr 1 - 240; y1 := maxy shr 1 - 180; x2 := x1 + 480; y2 := y1 + 360; modem_win := unique_id; Create_Dialog(modem_win,'Modem Dialog',x1,y1,x2,y2,standard_dialog, close_button+help_button+moveable+modal+minimize_button+maximize_button+sizeable, 0,0,0,0,0,0,0,0,0); Add_ListBox(modem_win,cur_dialog,'',-2,-1,(x2-x1)-4,(y2-y1)-22,unique_id,unique_id,0,nil,0); setactive(modem_win); end; Procedure MODEMWIN(s:string); var hlb : handle_listbox; Begin if get_handle_listbox(modem_win)=nil then exit; Add_Listbox_Item(get_handle_listbox(modem_win),s,80,0); if cur_dialog=get_handle_dialog(modem_win) then Begin hlb := get_handle_listbox(modem_win); if (hlb^.numitems>hlb^.vert_sb^.curpos+22) then Begin inc(hlb^.vert_sb^.curpos,1); draw_listbox(cur_dialog,hlb,true); end else draw_listbox(cur_dialog,hlb,false); end; end; Procedure MODEMWIN2(s:string); Begin if get_handle_listbox(modem_win)=nil then exit; Add_Listbox_Item(get_handle_listbox(modem_win),s,80,0); end; Procedure MODEMWINC(c:char); var s : string; hlb : handle_listbox; Begin hlb := get_handle_listbox(modem_win); if hlb=nil then exit; if c=#10 then exit; if c=#13 then MODEMWIN('') else Begin s := hlb^.last_item^.data.pstr; s := s + c; delete_listbox_item(hlb,hlb^.last_item,false); MODEMWIN2(s); end; end; {$ENDIF} Function itos(s:byte):string; var t : string; Begin str(s,t); itos := t; end; Constructor PPP_Object.Init; Begin InitializeAsync; Setparam(comport,baudrate,FALSE,TRUE); {com baud parity 8n1} PIP := false; {Packet in Progress?} vj_hdrc := false; terminate_ok := false; initfunc := ifunc; userinit := false; phase := _dead; use_PFC := false; {use Protocol Field Compression?} use_ADFC := false; {use Address Control Field Compression} fillchar(ipaddr,sizeof(ipaddr),0); ipstring := ''; Frame_Size := Default_Frame_Size; NumIPFrames := 0; NumLCPFrames := 0; NumNCDFrames := 0; protocol_ofs := DEFAULT_PROTOCOL_OFFSET; First_Frame := nil; Last_Frame := nil; Cur_Frame := nil; First_LCP_Frame := nil; Last_LCP_Frame := nil; Cur_LCP_Frame := nil; First_NCD_Frame := nil; Last_NCD_Frame := nil; Cur_NCD_Frame := nil; First_IP_Frame := nil; Last_IP_Frame := nil; Cur_IP_Frame := nil; if carrier then Begin SendInit('+++'); delay(1000); sendinit('ATH0'#13); delay(1000); end; end; Destructor PPP_Object.Done; Begin repeat SendInit('+++'); delay(1000); sendinit('ATH0'#13); delay(1000); until not(carrier) or keypressed; Closeport; while (first_lcp_frame<>nil) do disposelcpframe(first_lcp_frame); while (first_ncd_frame<>nil) do disposencdframe(first_ncd_frame); while (first_ip_frame<>nil) do disposeipframe(first_ip_frame); while (first_frame<>nil) do disposeframe(first_frame) end; Function PPP_Object.B(var frame:pbyte):byte; Begin if frame<>nil then Begin b := frame^; inc(frame); end else b := 255; end; Function PPP_Object.GetChar(var frame:pbyte):char; Begin GetChar := chr(b(frame)); end; Function PPP_Object.GetByte(var frame:pbyte):byte; Begin GetByte := b(frame); end; Function PPP_Object.GetInteger(var frame:pbyte):Integer; var i : integer; Begin i := b(frame) shl 8; i := i + b(frame); GetInteger := i; end; Function PPP_Object.GetWord(var frame:pbyte):Word; var i : word; Begin i := b(frame) shl 8; i := i+b(frame); GetWord := i; end; Function PPP_Object.GetLongint(var frame:pbyte):Longint; var l : longint; Begin l := (getword(frame)*65536)+getword(frame); GetLongint := l; end; {$I TIMETICK.INC} Function stor(s:string):real; var r : real; e : integer; Procedure strip(var s:string;c:char); begin while pos(c,s)>0 do delete(s,pos(c,s),1); end; Begin strip(s,' '); strip(s,'$'); val(s,r,e); stor := r; end; Function Waitfor(s:string;t:real) : Boolean; var buf : string; c : char; Begin buf := ''; starttiming; repeat if numchars>0 then Begin c := getchar; buf := buf + c; write(buf[length(buf)]); if length(buf)>length(s) then Begin move(buf[2],buf[1],240); buf[0] := chr(length(s)); end; end; stoptiming; if stor(elapsed)>t then Begin waitfor := false; exit; end; {$IFDEF TERMINAL}dialogmouseroutine;{$ENDIF} until (pos(s,buf)>0); end; Procedure PPP_Object.Dial(username,password,phone,scriptfile:string); Begin clearreceivebuffer; cleartransmitbuffer; sendinit('AT&F1'#13); delay(250); sendinit('ATM0'#13); delay(250); sendinit('ATDT'+phone+#13); { repeat handlemouse; until (carrier) or (keypressed); sendinit(#13); waitfor('name>',10);sendinit(username+#13); waitfor('word>',10);sendinit(password+#13); waitfor('Dialz>>>>',10);sendinit('c ppp'#13); waitfor('session',10);} end; Function PPP_Object.Carrier:boolean; Begin if modem.carrier then carrier := true else carrier := false; end; Procedure PPP_Object.Terminal; Const PFC : Array[1..4] of byte = (7,2,8,2); var ch : char; Begin {$IFDEF TERMINAL} MODEM_WINDOW; MODEMWIN('Internet Access Port Opened'); MODEMWIN(''); {$ENDIF} ch := ' '; repeat while numchars>0 do Begin ch := modem.getchar; {if ch in ['a'..'z','A'..'Z','0'..'9',#32,'-','+','!','@','#','$','%','^','&','*','(',')',')','|','\','/','[',']', #10,#13] then write(ch);} {$IFDEF TERMINAL} MODEMWINC(ch);{$ENDIF} ch := ' '; end; if keypressed then Begin ch := readkey; if ch>=#0 then sendchar(ch); end; {$IFDEF TERMINAL}dialogmouseroutine;{$ENDIF} until (ch=#27); phase := _LCP; sendlcp(1,random(256),4,makeptr(PFC)); {$IFDEF TERMINAL} standard_close(true);{close_dialog(get_handle_dialog(modem_win));}{$ENDIF} end; Procedure PPP_Object.DisposeFrame; Begin; if frame=nil then exit; if frame=first_frame then first_frame := first_frame^.next; if frame=last_frame then last_frame := last_frame^.prev; if frame=cur_frame then cur_frame := cur_frame^.next; if cur_frame=nil then cur_frame := first_frame; if frame^.prev<>nil then frame^.prev^.next := frame^.next; if frame^.next<>nil then frame^.next^.prev := frame^.prev; if (frame^.frame_type = IP_Protocol) then dec(NumIPFrames) else if (frame^.frame_type = LCD_Protocol) then dec(NumLCPFrames) else if (frame^.frame_type = NCD_Protocol) then dec(NumNCDFrames); freemem(frame^.frame_data,frame^.frame_size); dispose(frame); end; Procedure PPP_Object.SendIPFrame(datalength:word;data:pIPFrame); var lframe : pIPFrame; Begin if datalength=0 then exit; new(lframe); lframe^.sendorreceive := send; if datalength>0 then getmem(lframe^.data,datalength) else lframe^.data := nil; lframe^.datasize := datalength; lframe^.data_ptr := lframe^.data; if datalength>0 then move(data^.data_ptr^,lframe^.data_ptr^,datalength); lframe^.data_ptr := lframe^.data; lframe^.prev := last_IP_frame; cur_ip_frame := lframe; last_ip_frame := lframe; lframe^.next := nil; if first_ip_frame=nil then first_ip_frame := lframe; if lframe^.prev<>nil then lframe^.prev^.next := lframe; end; Procedure PPP_Object.SendLCPFrame(Code:byte;Identifier:byte; datalength:word;data:pLCPFrame); var lframe : pLCPFrame; Begin new(lframe); lframe^.code := code; lframe^.identifier := identifier; lframe^.length := datalength+4; lframe^.sendorreceive := send; if datalength>0 then getmem(lframe^.data,datalength) else lframe^.data := nil; lframe^.datasize := datalength; lframe^.data_ptr := lframe^.data; if datalength>0 then move(data^.data_ptr^,lframe^.data_ptr^,datalength); lframe^.data_ptr := lframe^.data; lframe^.prev := last_LCP_frame; cur_lcp_frame := lframe; last_lcp_frame := lframe; lframe^.next := nil; if first_lcp_frame=nil then first_lcp_frame := lframe; if lframe^.prev<>nil then lframe^.prev^.next := lframe; end; Procedure PPP_Object.SendNCDFrame(Code:byte;Identifier:byte; datalength:word;data:pNCDFrame); var lframe : pNCDFrame; Begin new(lframe); lframe^.code := code; lframe^.identifier := identifier; lframe^.length := datalength+4; lframe^.sendorreceive := send; if datalength>0 then getmem(lframe^.data,datalength) else lframe^.data := nil; lframe^.datasize := datalength; lframe^.data_ptr := lframe^.data; if datalength>0 then move(data^.data_ptr^,lframe^.data^,datalength); lframe^.prev := last_NCD_frame; cur_NCD_frame := lframe; last_NCD_frame := lframe; lframe^.next := nil; if first_NCD_frame=nil then first_NCD_frame := lframe; if lframe^.prev<>nil then lframe^.prev^.next := lframe; {$IFDEF SHOWINFO} writeln('---------------[NCD FRAME]-------------'); writeln('Code : ',lframe^.code); writeln('Identifier : ',lframe^.identifier); writeln('Length : ',lframe^.length); writeln('Datasize : ',lframe^.datasize); writeln('-------------[END NCD FRAME]-----------'); {$ENDIF} end; Procedure PPP_Object.Request_MRU(var frame:pLCPFrame); var fs : word; data : pbyte; begin {$IFDEF DEBUG} writeln('Configure_Request MRU');{$ENDIF} fs := getword(frame^.data_ptr); frame^.data_ptr := frame^.data; {if (fs<=max_frame_size) then Begin} Frame_Size := fs; {$IFDEF DEBUG} {writeln('MRU : ',frame_size);}{$ENDIF} {SendLCPFrame(Configure_Ack, frame^.identifier, frame^.datasize,frame);} (*end else Begin {$IFDEF DEBUG} writeln('MRU : <NAK>');{$ENDIF} SendLCPFrame(Configure_Nak, frame^.identifier, frame^.datasize,frame); end;*) end; Procedure PPP_Object.Set_MRU(var frame:pLCPFrame); var fs : word; data : pbyte; begin {$IFDEF DEBUG} writeln('Set MRU ');{$ENDIF} fs := getword(frame^.data_ptr); {frame^.data_ptr := frame^.data;} if (fs<=max_frame_size) then Begin Frame_Size := fs; {$IFDEF DEBUG} writeln('MRU : ',frame_size);{$ENDIF} end; end; Procedure PPP_Object.Request_PFC(var frame:pLCPFrame); var data : pbyte; Begin frame^.data_ptr := frame^.data; {$IFDEF DEBUG} writeln('Configure_Request PFC : <ACK>');{$ENDIF} SendLCPFrame(Configure_ACK, frame^.identifier, frame^.datasize, frame); use_pfc := true; end; (*Procedure PPP_Object.ProcessLCPFrame(frame:pLCPFrame); var LCP : Record _type : byte; _length : byte; end; Begin if frame=nil then exit; if (frame^.datasize>=2) then Begin lcp._type := getbyte(frame^.data_ptr); lcp._length := getbyte(frame^.data_ptr); end else fillchar(lcp,2,0); {$IFDEF DEBUG} writeln('ProcessLCPFrame'); writeln('Type : ',lcp._type); writeln('Length : ',lcp._length); {$ENDIF} case (frame^.code) of Configure_Request : case lcp._type of 0 : Begin SendLCPFrame(Configure_Ack,frame^.identifier,frame^.datasize,frame); if not(userinit) then if (addr(initfunc)<>nil) then Begin initfunc; userinit := true; end; phase := _ncd; end; Maximum_Receive_Unit : Request_MRU(frame); {Authentication_Protocol : writeln('Configure_Request Authentication'); Quality_Protocol : writeln('Configure_Request Quality'); Magic_Number : writeln('Configure_Request Magic Number');} Protocol_Field_Compression : Request_PFC(frame); {Address_Control_Field_Compression : writeln('Configure_Request Control Field Compression');} else Begin {$IFDEF DEBUG} writeln('LCP_Configure_Reject : ',lcp._type); {$ENDIF} frame^.data_ptr := frame^.data; SendLCPFrame(Configure_Reject, frame^.identifier, frame^.datasize,frame); end; end; Configure_Ack : case lcp._type of {0 : SendLCPFrame(Configure_ACK,frame^.identifier,0,frame);} Protocol_Field_Compression : use_pfc := true; Maximum_Receive_Unit : Set_MRU(frame); end; {Configure_NAK : ; Configure_Reject : ;} Terminate_Request : Begin Terminate_ok := true; phase := _lcp; SendLCPFrame(Terminate_ACK, frame^.identifier, frame^.datasize,frame); {$IFDEF DEBUG} writeln ('Terminate Request Received'); {$ENDIF} end; Terminate_ACK : Begin phase := _lcp; Terminate_ok := true; {$IFDEF DEBUG} writeln('Terminate ACK Received'); {$ENDIF} end; Code_Reject : ; Protocol_Reject : ; Echo_Request : ; Echo_Reply : ; Discard_Request : ; else SendLCPFrame(CODE_REJECT, frame^.identifier, frame^.datasize,frame); end; if not(userinit) then if (addr(initfunc)<>nil) then Begin initfunc; userinit := true; end; end; *) Procedure PPP_Object.ProcesslcpFrame(frame:plcpFrame); Const CIP : Array[1..6] of byte = (3,6,0,0,0,0); var cr : byte; LCP: Record _type : byte; _length : byte; end; lcp_nak : pbyte; lcp_ptr : pbyte; pos2 : word; lcp_pos : word; x : word; pl : word; Begin if frame=nil then exit; getmem(lcp_nak,1024); lcp_ptr := lcp_nak; lcp_pos := 0; pos2 :=3; {$IFDEF DEBUG} writeln('lcp Code : ',frame^.code); {$ENDIF} pl := frame^.length-4; while (pl>0) do Begin {while (frame^.length-2>=pos2) do Begin} {$IFDEF DEBUG} writeln('Packet Length : ',frame^.length); {$ENDIF} lcp._type := getbyte(frame^.data_ptr); lcp._length := getbyte(frame^.data_ptr); dec(pl,2); {$IFDEF DEBUG} writeln('lcp Type : ',lcp._type); writeln(' Length : ',lcp._length); {$ENDIF} case (frame^.code) of Configure_ACK, Configure_Request : case (lcp._type) of Maximum_Receive_Unit : Begin Request_MRU(frame); dec(pl,2); end; Protocol_Field_Compression : Begin use_pfc := true; {inc(pos2,);} {$IFDEF DEBUG} writeln ('[ACK PFC]'); {$ENDIF} end; Address_Control_Field_Compression : Begin use_adfc := true; protocol_ofs := 1; {$IFDEF DEBUG} writeln ('[ACK ADFC]');{$ENDIF} {inc(pos2,2);} end; else Begin lcp_ptr^ := lcp._type; inc(lcp_ptr); inc(lcp_pos); lcp_ptr^ := lcp._length; inc(lcp_ptr); inc(lcp_pos); if lcp._length-2>0 then for x := 1 to (lcp._length-2) do Begin lcp_ptr^ := getbyte(frame^.data_ptr); inc(lcp_ptr); inc(lcp_pos); dec(pl);{inc(pos2);} end; end; end; Configure_NAK, Configure_Reject : Begin Sendlcp(CONFIGURE_REQUEST,random(256),0,nil); freemem(lcp_nak,1024); exit; end; Terminate_ACK : Begin freemem(lcp_nak,1024); terminate_ok := true; exit; end; Terminate_REQUEST : Begin freemem(lcp_nak,1024); terminate_ok := true; sendlcpframe(Terminate_ack,frame^.identifier,frame^.datasize,frame); exit; end; Echo_Request : Begin freemem(lcp_nak,1024); sendlcpframe(Echo_Reply,frame^.identifier,frame^.datasize,frame); exit; end; Echo_Reply : Begin freemem(lcp_nak,1024); exit; end; Protocol_Reject : Begin {$IFDEF DEBUG} writeln('Protocol Reject!!!!!!'); {$ENDIF} freemem(lcp_nak,1024); exit; end; Code_Reject : Begin {$IFDEF DEBUG} writeln('CODE Reject!!!!!!'); {$ENDIF} freemem(lcp_nak,1024); exit; end; Discard_Request : Begin freemem(lcp_nak,1024); exit; end; else Begin SendlcpFrame(CODE_REJECT, frame^.identifier, frame^.datasize,frame); freemem(lcp_nak,1024); exit; end; end; end; frame^.data_ptr := frame^.data; if (lcp_pos>0) then Begin freemem(frame^.data,frame^.datasize); getmem(frame^.data,lcp_pos); frame^.datasize := lcp_pos; frame^.data_ptr := frame^.data; lcp_ptr := lcp_nak; for x := 1 to lcp_pos do Begin frame^.data_ptr^ := lcp_ptr^; inc(frame^.data_ptr); inc(lcp_ptr); end; frame^.data_ptr := frame^.data; {$IFDEF DEBUG} writeln('Configure NAK : ',frame^.datasize); {$ENDIF} if frame^.code=CONFIGURE_REQUEST then SendlcpFrame(Configure_NAK, frame^.identifier, frame^.datasize, frame); end else Begin if frame^.code=Configure_REQUEST then Begin {$IFDEF DEBUG} writeln('Configure ACK : ',frame^.datasize); {$ENDIF} sendlcpFrame(Configure_ACK, frame^.identifier, frame^.datasize,frame); end else if frame^.code=Configure_Ack then Begin phase := _NCD; sendncd(Configure_Request,random(256),4,makeptr(CIP)); freemem(lcp_nak,1024); exit; end; end; freemem(lcp_nak,1024); end; Function PPP_Object.GetLCPFrame:pLCPFrame; var frame : pFrame; Begin GetLCPFrame := nil; if NumLCPFrames=0 then exit; frame := First_Frame; while frame<>nil do Begin if (frame^.frame_complete) and (frame^.frame_type=LCD_Protocol) then Begin newLCPFrame(frame); disposeframe(frame); GetLCPFrame := cur_LCP_Frame; exit; end; frame := frame^.next; end; end; Procedure PPP_Object.Set_IP(var frame:pNCDFrame); var x : byte; data : string[16]; begin {$IFDEF DEBUG} writeln('Set IP ');{$ENDIF} for x := 1 to 4 do ipaddr[x] := getbyte(frame^.data_ptr); {frame^.data_ptr := frame^.data;} ipstring := itos(ipaddr[1])+'.'+itos(ipaddr[2])+'.'+itos(ipaddr[3])+'.'+itos(ipaddr[4]); {$IFDEF DEBUG} writeln('IP Address : ',ipstring); {$ENDIF} end; Procedure PPP_Object.Set_VJ_hdrc(var frame:pNCDFrame); var x : byte; data : string[16]; begin {$IFDEF DEBUG} writeln('Van Jacobson TCP/IP Header Compression <ACK>');{$ENDIF} vj_hdrc := true; ipcp := getword(frame^.data_ptr); maxslotid := getbyte(frame^.data_ptr); compslotid := getbyte(frame^.data_ptr); end; Procedure PPP_Object.ProcessNCDFrame(frame:pNCDFrame); Const CIP : Array[1..6] of byte = (3,6,0,0,0,0); var NCD : Record _type : byte; _length : byte; end; ncd_nak : pbyte; ncd_ptr : pbyte; ncd_pos : word; x : word; pl : word; Begin { if (phase>_NCD) then phase := _NCD;} {if (phase<_NCD) then exit;} if frame=nil then exit; getmem(ncd_nak,1024); ncd_ptr := ncd_nak; ncd_pos := 0; {$IFDEF DEBUG} writeln('NCD Code : ',frame^.code); {$ENDIF} pl := frame^.length-4; while (pl>0) do Begin {$IFDEF DEBUG} writeln('Packet Length : ',frame^.length); {$ENDIF} NCD._type := getbyte(frame^.data_ptr); NCD._length := getbyte(frame^.data_ptr); dec(pl,2); {$IFDEF DEBUG} writeln('NCD Type : ',NCD._type); writeln(' Length : ',NCD._length); {$ENDIF} case (frame^.code) of Configure_ACK, Configure_Request : case (ncd._type) of {2 : Begin Set_VJ_hdrc(frame); dec(pl,4); end;} 3 : Begin Set_IP(frame); dec(pl,4); end; else Begin ncd_ptr^ := ncd._type; inc(ncd_ptr); inc(ncd_pos); ncd_ptr^ := ncd._length; inc(ncd_ptr); inc(ncd_pos); if ncd._length-2>0 then for x := 1 to (ncd._length-2) do Begin ncd_ptr^ := getbyte(frame^.data_ptr); inc(ncd_ptr); inc(ncd_pos); dec(pl); end; end; end; Configure_NAK : case (ncd._type) of 3 : Begin Set_IP(frame); dec(pl,4); cip[3] := ipAddr[1]; cip[4] := ipAddr[2]; cip[5] := ipAddr[3]; cip[6] := ipAddr[4]; SendNCD(CONFIGURE_REQUEST,random(256),6,makeptr(CIP)); freemem(ncd_nak,1024); exit; end; end; Configure_Reject : Begin phase := _NCD; SendNCD(CONFIGURE_REQUEST,random(256),0,nil); freemem(ncd_nak,1024); exit; end; else Begin SendNCDFrame(CODE_REJECT, frame^.identifier, frame^.datasize,frame); freemem(ncd_nak,1024); exit; end; end; end; frame^.data_ptr := frame^.data; if (ncd_pos>0) then Begin freemem(frame^.data,frame^.datasize); getmem(frame^.data,ncd_pos); frame^.datasize := ncd_pos; frame^.data_ptr := frame^.data; ncd_ptr := ncd_nak; for x := 1 to ncd_pos do Begin frame^.data_ptr^ := ncd_ptr^; inc(frame^.data_ptr); inc(ncd_ptr); end; frame^.data_ptr := frame^.data; {$IFDEF DEBUG} writeln('Configure NAK : ',frame^.datasize); {$ENDIF} phase := _NCD; {if frame^.code=CONFIGURE_REQUEST then} SendNCDFrame(Configure_NAK, frame^.identifier, frame^.datasize, frame); end else Begin if (frame^.code=Configure_REQUEST) {or (frame^.code=CONFIGURE_NAK)} then Begin {$IFDEF DEBUG} writeln('NCD Configure ACK : ',frame^.datasize,' ',frame^.code); {$ENDIF} phase := _OPEN; sendNCDFrame(Configure_ACK, frame^.identifier, frame^.datasize,frame); end; end; freemem(ncd_nak,1024); end; Function PPP_Object.GetNCDFrame:pNCDFrame; var frame : pFrame; Begin GetNCDFrame := nil; if NumNCDFrames=0 then exit; frame := First_Frame; while frame<>nil do Begin if (frame^.frame_complete) and (frame^.frame_type=NCD_Protocol) then Begin newNCDFrame(frame); disposeframe(frame); GetNCDFrame := cur_NCD_Frame; exit; end; frame := frame^.next; end; end; Function PPP_Object.GetIPFrame:pIPFrame; var frame : pFrame; Begin GetIPFrame := nil; if NumIPFrames=0 then exit; frame := First_Frame; while frame<>nil do Begin if (frame^.frame_complete) and (frame^.frame_type=IP_Protocol) then Begin oIP.AddIPFrame(frame); {$IFDEF SHOWINFO} delay(1000); {$ENDIF} disposeframe(frame); GetIPFrame := cur_IP_Frame; exit; end; frame := frame^.next; end; end; Procedure PPP_Object.AddtoFrame; Begin if cur_frame=nil then Begin {$IFDEF DEBUG} writeln('[Attemting to Write to a NIL FRAME!]'); {$ENDIF} PIP := false; exit; end; if (bte=complement) and not(cur_frame^.comp) then cur_frame^.comp := true else Begin inc(cur_frame^.frame_ptr); if cur_frame^.comp then Begin bte := bte xor $20; cur_frame^.comp := false; end; cur_frame^.frame_ptr^ := bte; inc(cur_frame^.frame_length); r_packetcrc := updatecrc(r_packetcrc,bte); {$IFDEF SHOWINFO} write(bte:3,'/'); {$ENDIF} end; end; Procedure PPP_Object.DisposeLCPFrame(frame:pLCPFrame); Begin if frame=nil then exit; if frame=first_lcp_frame then first_lcp_frame := first_lcp_frame^.next; if frame=last_lcp_frame then last_lcp_frame := last_lcp_frame^.prev; if frame=cur_lcp_frame then cur_lcp_frame := cur_lcp_frame^.next; if frame^.prev<>nil then frame^.prev^.next := frame^.next; if frame^.next<>nil then frame^.next^.prev := frame^.prev; if frame^.datasize>0 then freemem(frame^.data,frame^.datasize); dispose(frame); end; Procedure PPP_Object.DisposeNCDFrame(frame:pNCDFrame); Begin if frame=nil then exit; if frame=first_ncd_frame then first_ncd_frame := first_ncd_frame^.next; if frame=last_ncd_frame then last_ncd_frame := last_ncd_frame^.prev; if frame=cur_ncd_frame then cur_ncd_frame := cur_ncd_frame^.next; if frame^.prev<>nil then frame^.prev^.next := frame^.next; if frame^.next<>nil then frame^.next^.prev := frame^.prev; if frame^.datasize>0 then freemem(frame^.data,frame^.datasize); dispose(frame); end; Procedure PPP_Object.DisposeIPFrame(frame:pIPFrame); Begin if frame=nil then exit; if frame=first_ip_frame then first_ip_frame := first_ip_frame^.next; if frame=last_ip_frame then last_ip_frame := last_ip_frame^.prev; if frame=cur_ip_frame then cur_ip_frame := cur_ip_frame^.next; if frame^.prev<>nil then frame^.prev^.next := frame^.next; if frame^.next<>nil then frame^.next^.prev := frame^.prev; if frame^.datasize>0 then freemem(frame^.data,frame^.datasize); dispose(frame); end; Procedure PPP_Object.NewLCPFrame(frame:Pframe); var lframe : pLCPFrame; Begin new(lframe); lframe^.code := getbyte(frame^.frame_ptr); lframe^.identifier := getbyte(frame^.frame_ptr); lframe^.length := getword(frame^.frame_ptr); lframe^.sendorreceive := receive; lframe^.data := nil; if (lframe^.length-4)>0 then Begin getmem(lframe^.data,lframe^.length-4); move(frame^.frame_ptr^,lframe^.data^,lframe^.length-4); end; lframe^.datasize := lframe^.length-4; lframe^.data_ptr := lframe^.data; lframe^.prev := last_LCP_frame; last_lcp_frame := lframe; cur_lcp_frame := lframe; lframe^.next := nil; if first_lcp_frame=nil then first_lcp_frame := lframe; if lframe^.prev<>nil then lframe^.prev^.next := lframe; cur_lcp_frame := lframe; end; {Procedure PPP_Object.NewIPFrame(frame:Pframe); var lframe : pIPFrame; Begin if frame^.frame_length-(Protocol_ofs+4)<1 then exit; new(lframe); lframe^.datasize := frame^.frame_length-(Protocol_Ofs+4); lframe^.sendorreceive := receive; lframe^.data := nil; getmem(lframe^.data,lframe^.datasize); move(frame^.frame_ptr^,lframe^.data^,lframe^.datasize); lframe^.data_ptr := lframe^.data; lframe^.prev := last_IP_frame; last_ip_frame := lframe; cur_ip_frame := lframe; lframe^.next := nil; if first_ip_frame=nil then first_ip_frame := lframe; if lframe^.prev<>nil then lframe^.prev^.next := lframe; cur_ip_frame := lframe; end; } Procedure PPP_Object.NewNCDFrame(frame:Pframe); var lframe : pNCDFrame; Begin new(lframe); {if phase<_NCD then phase := _NCD;} lframe^.code := getbyte(frame^.frame_ptr); lframe^.identifier := getbyte(frame^.frame_ptr); lframe^.length := getword(frame^.frame_ptr); lframe^.sendorreceive := receive; lframe^.data := nil; if (lframe^.length-4)>0 then Begin getmem(lframe^.data,lframe^.length-4); move(frame^.frame_ptr^,lframe^.data^,lframe^.length-4); end; lframe^.datasize := lframe^.length-4; lframe^.data_ptr := lframe^.data; lframe^.prev := last_NCD_frame; last_ncd_frame := lframe; cur_ncd_frame := lframe; lframe^.next := nil; if first_ncd_frame=nil then first_ncd_frame := lframe; if lframe^.prev<>nil then lframe^.prev^.next := lframe; cur_ncd_frame := lframe; end; Procedure PPP_Object.HandleLCPFrames; var frame : pLCPFrame; x : word; Begin {if (phase<_LCP) then exit;} frame := First_LCP_Frame; while (frame<>nil) do Begin if (frame^.sendorreceive=send) then Begin SendPPP(LCD_Protocol,frame); DisposeLCPFrame(frame); exit; end else Begin ProcessLCPFrame(frame); DisposeLCPFrame(frame); exit; end; frame := frame^.next; end; end; Procedure PPP_Object.HandleIPFrames; var frame : pIPFrame; x : word; Begin {if (phase<_OPEN) then exit;} frame := First_IP_Frame; while (frame<>nil) do Begin if (frame^.sendorreceive=send) then Begin SendPPP(IP_Protocol,frame); DisposeIPFrame(frame); exit; end; frame := frame^.next; end; end; Procedure PPP_Object.HandleNCDFrames; var frame : pNCDFrame; x : word; Begin {if (phase<_NCD) then exit;} frame := First_NCD_Frame; while (frame<>nil) do Begin if (frame^.sendorreceive=send) then Begin SendPPP(NCD_Protocol,frame); DisposeNCDFrame(frame); exit; end else Begin ProcessNCDFrame(frame); DisposeNCDFrame(frame); exit; end; frame := frame^.next; end; end; Procedure PPP_Object.NewFrame; var frame : pFrame; Begin pip := true; r_packetcrc := $ffff; new(frame); frame^.frame_complete := false; frame^.frame_size := Frame_Size; frame^.frame_type := 0; frame^.frame_length := 0; frame^.comp := false; getmem(frame^.frame_data,frame^.frame_size); frame^.frame_ptr := frame^.frame_data; frame^.frame_ptr^ := Flag; frame^.prev := last_frame; last_frame := frame; cur_frame := frame; frame^.next := nil; if first_frame=nil then first_frame := frame; if cur_frame=nil then cur_frame := frame; if frame^.prev<>nil then frame^.prev^.next := frame; {$IFDEF SHOWINFO} writeln;writeln('[FRAME]'); {$ENDIF} end; Procedure PPP_Object.EndFrame; var pfc : word; b1,b2 : byte; Begin pip := false; inc(Cur_Frame^.frame_ptr); Cur_frame^.frame_ptr^ := Flag; cur_frame^.frame_complete := true; {$IFDEF SHOWINFO} writeln;{$ENDIF} if not(r_packetcrc=$f0b8) then Begin disposeframe(cur_frame); {$IFDEF DEBUG} writeln('Invalid CRC in Packet!'); {$ENDIF} end else Begin cur_frame^.frame_ptr := cur_frame^.frame_data; inc(cur_frame^.frame_ptr,protocol_ofs); if (use_pfc) then Begin b1 := getbyte(cur_frame^.frame_ptr); b2 := getbyte(cur_frame^.frame_ptr); if (b1=address) and (b2=control) then Begin b1 := getbyte(cur_frame^.frame_ptr); b2 := getbyte(cur_frame^.frame_ptr); end; if (b1 and 1)=1 then Begin {$IFDEF SHOWINFO} writeln('[CPF Frame Received!]');{$ENDIF} cur_frame^.frame_type := b1; dec(cur_frame^.frame_ptr); end else cur_frame^.frame_type := b1 shl 8 + b2; end else Begin cur_frame^.frame_type := getword(cur_frame^.frame_ptr); if cur_frame^.frame_Type = address shl 8 + control then cur_frame^.frame_type := getword(cur_frame^.frame_ptr); end; {$IFDEF SHOWINFO} writeln('Frame Type : ',cur_frame^.frame_type); {$ENDIF} if (cur_frame^.frame_type = IP_Protocol) then inc(NumIPFrames) else if (cur_frame^.frame_type = LCD_Protocol) then inc(NumLCPFrames) else if (cur_frame^.frame_type = NCD_Protocol) then inc(NumNCDFrames); end; {$IFDEF SHOWINFO} {sound(500); delay(5); nosound;} writeln;writeln('[FRAME END]');{$ENDIF} end; Procedure PPP_Object.SendPPP; var lcp_frame : pLCPFrame; ncd_frame : pNCDFRAME; ip_frame : pIPFrame; packetcrc : word; pc : word; x : word; Begin packetcrc := $ffff; {$IFDEF SHOWINFO2} writeln; writeln('----------------- [ Send Packet ] -------------------'); writeln('PFC : ',use_pfc,' ADFC : ',use_adfc,' VANJ : ',vj_hdrc); writeln; case protocol of IP_Protocol : Writeln('IP Datagram'); NCD_Protocol : Writeln('NCD Packet'); LCD_Protocol : Writeln('LCP Packet'); else writeln('*INVALID PROTOCOL*'); end; {$ENDIF} sendchar(chr(flag)); {PPP Header Flag} if ((use_adfc) and (not(protocol=IP_PROTOCOL))) or (not(use_adfc)) then Begin sendbyte(address); packetcrc := updatecrc(packetcrc,address); sendbyte(control); packetcrc := updatecrc(packetcrc,control); end; if protocol=LCD_Protocol then Begin {$IFDEF DEBUG} writeln('Sending LCP Frame'); {$ENDIF} lcp_frame := pLCPFrame(data); lcp_frame^.data_ptr := lcp_frame^.data; sendword(lcd_protocol); packetcrc := updatecrc(packetcrc,lcd_protocol shr 8); packetcrc := updatecrc(packetcrc,lcd_protocol and $00ff); sendbyte(lcp_frame^.code); packetcrc := updatecrc(packetcrc,lcp_frame^.code); sendbyte(lcp_frame^.identifier); packetcrc := updatecrc(packetcrc,lcp_frame^.identifier); sendword(lcp_frame^.length); packetcrc := updatecrc(packetcrc,lcp_frame^.length shr 8); packetcrc := updatecrc(packetcrc,lcp_frame^.length and $00ff); for x := 1 to lcp_frame^.datasize do Begin packetcrc := updatecrc(packetcrc,lcp_frame^.data_ptr^); sendbyte(lcp_frame^.data_ptr^); {$IFDEF DEBUG} write (lcp_frame^.data_ptr^,'/'); {$ENDIF} inc(lcp_frame^.data_ptr); end; lcp_frame^.data_ptr := lcp_frame^.data; end else if protocol=NCD_Protocol then Begin {$IFDEF DEBUG} writeln('Sending NCD Frame'); {$ENDIF} ncd_frame := pNCDFrame(data); ncd_frame^.data_ptr := ncd_frame^.data; sendword(ncd_protocol); packetcrc := updatecrc(packetcrc,ncd_protocol shr 8); packetcrc := updatecrc(packetcrc,ncd_protocol and $00ff); sendbyte(ncd_frame^.code); packetcrc := updatecrc(packetcrc,ncd_frame^.code); sendbyte(ncd_frame^.identifier); packetcrc := updatecrc(packetcrc,ncd_frame^.identifier); sendword(ncd_frame^.length); packetcrc := updatecrc(packetcrc,ncd_frame^.length shr 8); packetcrc := updatecrc(packetcrc,ncd_frame^.length and $00ff); for x := 1 to ncd_frame^.datasize do Begin sendbyte(ncd_frame^.data_ptr^); packetcrc := updatecrc(packetcrc,ncd_frame^.data_ptr^); {$IFDEF DEBUG} write('[',ncd_frame^.data_ptr^,']');{$ENDIF} inc(ncd_frame^.data_ptr); end; ncd_frame^.data_ptr := ncd_frame^.data; end else if protocol=IP_Protocol then Begin {$IFDEF DEBUG} writeln; writeln('[Sending IP Frame]'); {$ENDIF} ip_frame := pIPFrame(data); ip_frame^.data_ptr := ip_frame^.data; if not(use_pfc) then Begin sendword(ip_protocol); packetcrc := updatecrc(packetcrc,ip_protocol shr 8); packetcrc := updatecrc(packetcrc,ip_protocol and $00ff); end else Begin sendbyte(ip_protocol and $00ff); packetcrc := updatecrc(packetcrc,ip_protocol and $00ff); end; for x := 1 to ip_frame^.datasize do Begin sendbyte(ip_frame^.data_ptr^); packetcrc := updatecrc(packetcrc,ip_frame^.data_ptr^); {$IFDEF IP2DEBUG} write(ip_frame^.data_ptr^,'³');{$ENDIF} inc(ip_frame^.data_ptr); end; ip_frame^.data_ptr := ip_frame^.data; end; packetcrc := finalcrc(packetcrc); sendword(packetcrc); sendchar(chr(flag)); end; Procedure PPP_Object.HandleIncoming; var bte : byte; Begin while numchars>0 do Begin bte := ord(modem.getchar); case bte of Flag : If (PIP) then Begin if (cur_frame^.frame_ptr<>cur_frame^.frame_data) then EndFrame end else NewFrame; else AddtoFrame(bte); end; end; end; Procedure PPP_Object.Packet_Driver; Begin HandleIncoming; {Handles ALL Incoming Data} GetLCPFrame; {Loads LCP Frames into pLCPFRAME} GetNCDFrame; {Loads NCD Frames into pNCDFRAME} GetIPFrame; {Loads IP Frames into pIPFRAME} HandleLCPFrames; {Processes all LCP Frames} HandleNCDFrames; {Processes all NCD Frames} if (transmitbufferused<defaultbuffersize-2048) then HandleIPFrames; {Processes all OUTGOING IP Frames} oIP.ProcessIPFrames; {Processes IP Packets} end; Function PPP_Object.MakePtr(var variable):pbyte; Begin Makeptr := addr(variable){ptr(seg(variable),ofs(variable))}; end; Procedure PPP_Object.SendLCP(Code:byte; Identifier:byte; datalength:longint;data:pbyte); var lframe : pLCPFrame; x : byte; Begin new(lframe); lframe^.code := code; lframe^.identifier := identifier; lframe^.length := datalength+4; lframe^.sendorreceive := send; if datalength>0 then getmem(lframe^.data,datalength) else lframe^.data := nil; lframe^.datasize := datalength; lframe^.data_ptr := lframe^.data; if datalength>0 then move(data^,lframe^.data_ptr^,datalength); lframe^.prev := last_LCP_frame; cur_lcp_frame := lframe; last_lcp_frame := lframe; lframe^.next := nil; if first_lcp_frame=nil then first_lcp_frame := lframe; if lframe^.prev<>nil then lframe^.prev^.next := lframe; end; Procedure PPP_Object.SendNCD(Code:byte; Identifier:byte; datalength:longint;data:pbyte); var lframe : pNCDFrame; x : byte; Begin new(lframe); lframe^.code := code; lframe^.identifier := identifier; lframe^.length := datalength+4; lframe^.sendorreceive := send; if datalength>0 then getmem(lframe^.data,datalength) else lframe^.data := nil; lframe^.datasize := datalength; lframe^.data_ptr := lframe^.data; if (datalength>0) then move(data^,lframe^.data_ptr^,datalength); lframe^.prev := last_NCD_frame; cur_ncd_frame := lframe; last_ncd_frame := lframe; lframe^.next := nil; if first_ncd_frame=nil then first_ncd_frame := lframe; if lframe^.prev<>nil then lframe^.prev^.next := lframe; end; Procedure PPP_Object.SendIP(datalength:longint;data:pbyte); var lframe : pIPFrame; x : byte; Begin if datalength=0 then exit; new(lframe); lframe^.sendorreceive := send; if datalength>0 then getmem(lframe^.data,datalength) else lframe^.data := nil; lframe^.datasize := datalength; lframe^.data_ptr := lframe^.data; if (datalength>0) then move(data^,lframe^.data_ptr^,datalength); lframe^.prev := last_IP_frame; cur_IP_frame := lframe; last_IP_frame := lframe; lframe^.next := nil; if first_IP_frame=nil then first_IP_frame := lframe; if lframe^.prev<>nil then lframe^.prev^.next := lframe; end; Procedure PPP_Object.FormatIP (b1,b2,b3,b4:byte; var ipt:iptype); Begin ipt[1] := b1; ipt[2] := b2; ipt[3] := b3; ipt[4] := b4; end; Function PPP_Object.IPstr (ip:iptype):string; var s : string; x : integer; Begin s := ''; for x := 1 to 4 do Begin s := s + itos(ip[x]); if x<4 then s := s +'.'; end; ipstr := s; end; Function PPP_Object.ValidIP (s:string):boolean; var z : byte; Begin validIP := false; z := 0; while (pos('.',s)>0) do Begin inc(z); s[pos('.',s)] := ' '; end; if z=3 then ValidIP := true; end; Function PPP_Object.StoIP(s:string;var IP:iptype):boolean; var x,y : byte; ts : string; Function stoi(s:string):byte; var x : byte; e : integer; Begin val(s,x,e); stoi := x; end; Begin stoip := false; if not(validip(s)) then exit; for y := 1 to 4 do Begin ts := ''; for x := 1 to pos('.',s)-1 do ts := ts + s[x]; ip[y] := stoi(ts); delete(s,1,pos('.',s)); end; stoip := true; end; Function PPP_Object.CanWrite:Boolean; Begin CanWrite := TransmitBufferUsed=0; end; end.
|
