&ACMODE DOCENTSAM PAS$8@EXEC PAS=86FLDINP PASu"9MODEM PASRANGEC PAS The following information is presented for advanced users of Turbo Pascal under MS-DOS or PC-DOS. Turbo Pascal version 3 uses MS-DOS file handles to open files. Function call 2DH is used. One of the parameters to this call is the 'open mode', which tells DOS information about how you intend to access the file and what access to give to other processes (in a networking or future multitasking environment). Turbo normally uses an open mode byte of 2, which means Compatability Mode with Read/Write Access and Inheritance by child processes. By changing the value of this byte to 0, you may open Read-only files. There may also be other applications for this, especially in a network. The open mode byte for overlays, Chain, and Execute is normally 0, Compatability Mode with Read Access. The addresses for these mode bytes is not given but can be found by searching the runtime library for the bytes 00 3D. The first occurrence is the one used for overlays, and the second is used for Chain and Execute. Open mode byte for Reset & Rewrite for Turbo 3.00x (PC-DOS): TURBO.COM CSEG:$248D TURBO-87.COM CSEG:$1F3C TURBOBCD.COM CSEG:$2393 Open mode byte for Reset & Rewrite for Turbo 3.00x (MS-DOS): TURBO.COM CSEG:$2182 TURBO-87.COM CSEG:$1C31 TURBOBCD.COM CSEG:$2088 Open mode byte for Reset & Rewrite for Turbo 3.01x (PC-DOS): TURBO.COM CSEG:$24FC TURBO-87.COM CSEG:$1FAB TURBOBCD.COM CSEG:$2402 Open mode byte for Reset & Rewrite for Turbo 3.01x (MS-DOS): TURBO.COM CSEG:$21D4 TURBO-87.COM CSEG:$1C83 TURBOBCD.COM CSEG:$20DA The best way to use this information is to create an absolute variable pointing to the byte: Var OpenModeByte: Byte Absolute CSeg:$248D; { For TURBO.COM PC-DOS } Be sure that the version of the compiler that you are using matches the ones listed here (PC or MS-DOS version 3.00x or 3.01x. Addresses should not change for changes in the version letter, since they are patches rather than re-assemblies). For additional safety, check that the value of the byte is actually 2 before changing it. And remember to change it back to 2 if you intend to do normal file opens intermixed with opens of Read-only or shared files. - Bela Lubkin Program EntrySample; var Field : String[10]; LowEnd,HighEnd : Real; Result,Value, Place,FieldSize,Times : Integer; Cursor,Ch : Char; RangeOK : Boolean; procedure InputField; label Bypass; begin Field := ''; Place := 0; Repeat Read(Kbd,Ch); If Length(Field)<=FieldSize then begin Case Ch of #8 : begin {BackSpace key} If Place=0 then begin {avoid backspacing beyond} Write(Trm,Chr(8)); {beginning of field } Write(' '); end else begin Delete(Field,Place,1); {destructive backspace} Place := Place-1; Write(Trm,Chr(8)); Write(Cursor); Write(Trm,Chr(8)); end; end; #127 : begin; {Delete Key} If Place=0 then begin {avoid backspacing beyond} Write(Trm,Chr(8)); {beginning of field again} Write(' '); end else begin Delete(Field,Place,1); {destructive backspace} Place := Place-1; Write(Trm,Chr(8)); Write(Cursor); Write(Trm,Chr(8)); end; end; #13 : begin {Carraige Return--End of input} GoTo Bypass; {for this field } end; else If Length(Field) Chr(13) then Write(Chr(7)); {Ring bell at terminal if at end of} end; {field and no RETURN key pressed } ByPass: end; end; Until Ch=Chr(13); end; procedure StripBlanks; {don't use on Alpha-numeric fields...} {blanks there may be valid } begin Repeat Place := Pos(' ',Field); Delete(Field,Place,1); Place := Pos(' ',Field); Until Place=0; end; procedure RangeCheck; begin Result := 0; {initialize error code} StripBlanks; {from FLDINPUT.PAS - pull out blanks} Val(Field,Value,Result); {convert Field to a Number} If Result <> 0 then begin {look for non-numeric characters} Result := 0; {reset result code} RangeOK := False; Write(Chr(7)); GoToXY(1,23); ClrEol; WriteLn('Input must be numeric. '); Write('Press any key to continue... '); Read(Kbd,Ch); GoToXY(1,23); ClrEol; GoToXY(1,24); ClrEol; end else begin If (Value < LowEnd) or (Value > HighEnd) then begin Write(Chr(7)); RangeOK := False; GoToXY(1,23); ClrEol; WriteLn('Value not in allowable range. '); Write('Press any key to continue... '); Read(Kbd,Ch); GoToXY(1,23); ClrEol; GoToXY(1,24); ClrEol; end else begin RangeOK := True; end; {checking range} end; {checking result code} end; {of RangeCheck} begin {little sample program} ClrScr; Write('What do you use to delineate fields? (e.g., "_") :'); Read(Cursor); ClrScr; GoToXY(30,4); Write('Entry Test'); GoToXY(1,6); Write('Alpha Data: '); FieldSize := 8; GoToXY(20,6); For Place := 1 to FieldSize do begin Write(Cursor); end; GoToXY(20,6); InputField; GoToXY(20,6); ClrEol; WriteLn(Field); Field := ''; Repeat GoToXY(1,8); Write('Enter a number between 1 and 1000 : '); FieldSize := 4; LowEnd := 1; HighEnd := 1000; GoToXY(40,8); For Place := 1 to FieldSize do begin Write(Cursor); end; GoToXY(40,8); InputField; StripBlanks; RangeCheck; Until RangeOK; Field := ''; GoToXy(20,1); Write('Press any key to continue...'); Read(Kbd,Ch); ClrScr; end. { EXEC.PAS version 1.3 This file contains 2 functions for Turbo Pascal that allow you to run other programs from within a Turbo program. The first function, SubProcess, actually calls up a different program using MS-DOS call 4BH, EXEC. The second function, GetComSpec, returns the path name of the command interpreter, which is necessary to do certain operations. There is also a main program that allows you to test the functions. Revision history ---------------- Version 1.3 works with MS-DOS 2.0 and up, TURBO PASCAL version 1.0 and up. Version 1.2 had a subtle but dangerous bug: I set a variable that was addressed relative to BP, using a destroyed BP! Version 1.1 didn't work with Turbo 2.0 because I used Turbo 3.0 features Version 1.0 only worked with DOS 3.0 due to a subtle bug in DOS 2.x - Bela Lubkin Borland International Technical Support CompuServe 71016,1573 } Type Str66=String[66]; Str255=String[255]; Function SubProcess(CommandLine: Str255): Integer; { Pass this function a string of the form 'D:\FULL\PATH\NAME\OF\FILE.TYP parameter1 parameter2 ...' For example, 'C:\SYSTEM\CHKDSK.COM' 'A:\WS.COM DOCUMENT.1' 'C:\DOS\LINK.EXE TEST;' 'C:\COMMAND.COM /C COPY *.* B:\BACKUP >FILESCOP.IED' The third example shows several things. To do any of the following, you must invoke the command processor and let it do the work: redirection; piping; path searching; searching for the extension of a program (.COM, .EXE, or .BAT); batch files; and internal DOS commands. The name of the command processor file is stored in the DOS environment. The function GetComSpec in this file returns the path name of the command processor. Also note that you must use the /C parameter or COMMAND will not work correctly. You can also call COMMAND with no parameters. This will allow the user to use the DOS prompt to run anything (as long as there is enough memory). To get back to your program, he can type the command EXIT. Actual example: I:=SubProcess(GetComSpec+' /C COPY *.* B:\BACKUP >FILESCOP.IED'); The value returned is the result returned by DOS after the EXEC call. The most common values are: 0: Success 1: Invalid function (should never happen with this routine) 2: File/path not found 8: Not enough memory to load program 10: Bad environment (greater than 32K) 11: Illegal .EXE file format If you get any other result, consult an MS-DOS Technical Reference manual. VERY IMPORTANT NOTE: you MUST use the Options menu of Turbo Pascal to restrict the amount of free dynamic memory used by your program. Only the memory that is not used by the heap is available for use by other programs. } Const SSSave: Integer=0; SPSave: Integer=0; Var Regs: Record Case Integer Of 1: (AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags: Integer); 2: (AL,AH,BL,BH,CL,CH,DL,DH: Byte); End; FCB1,FCB2: Array [0..36] Of Byte; PathName: Str66; CommandTail: Str255; ParmTable: Record EnvSeg: Integer; ComLin: ^Integer; FCB1Pr: ^Integer; FCB2Pr: ^Integer; End; I,RegsFlags: Integer; Begin If Pos(' ',CommandLine)=0 Then Begin PathName:=CommandLine+#0; CommandTail:=^M; End Else Begin PathName:=Copy(CommandLine,1,Pos(' ',CommandLine)-1)+#0; CommandTail:=Copy(CommandLine,Pos(' ',CommandLine),255)+^M; End; CommandTail[0]:=Pred(CommandTail[0]); With Regs Do Begin FillChar(FCB1,Sizeof(FCB1),0); AX:=$2901; DS:=Seg(CommandTail[1]); SI:=Ofs(CommandTail[1]); ES:=Seg(FCB1); DI:=Ofs(FCB1); MsDos(Regs); { Create FCB 1 } FillChar(FCB2,Sizeof(FCB2),0); AX:=$2901; ES:=Seg(FCB2); DI:=Ofs(FCB2); MsDos(Regs); { Create FCB 2 } ES:=CSeg; BX:=SSeg-CSeg+MemW[CSeg:MemW[CSeg:$0101]+$112]; AH:=$4A; MsDos(Regs); { Deallocate unused memory } With ParmTable Do Begin EnvSeg:=MemW[CSeg:$002C]; ComLin:=Addr(CommandTail); FCB1Pr:=Addr(FCB1); FCB2Pr:=Addr(FCB2); End; InLine($8D/$96/ PathName /$42/ { :=Ofs(PathName[1]); } $8D/$9E/ ParmTable / { :=Ofs(ParmTable); } $B8/$00/$4B/ { :=$4B00; } $1E/$55/ { Save , } $16/$1F/ { :=Seg(PathName[1]); } $16/$07/ { :=Seg(ParmTable); } $2E/$8C/$16/ SSSave / { Save in SSSave } $2E/$89/$26/ SPSave / { Save in SPSave } $FA/ { Disable interrupts } $CD/$21/ { Call MS-DOS } $FA/ { Disable interrupts } $2E/$8B/$26/ SPSave / { Restore } $2E/$8E/$16/ SSSave / { Restore } $FB/ { Enable interrupts } $5D/$1F/ { Restore , } $9C/$8F/$86/ RegsFlags / { Flags:= } $89/$86/ Regs ); { Regs.AX:=; } { The messing around with SS and SP is necessary because under DOS 2.x, after returning from an EXEC call, ALL registers are destroyed except CS and IP! I wish I'd known that before I released this package the first time... } If (RegsFlags And 1)<>0 Then SubProcess:=AX Else SubProcess:=0; End; End; Function GetComSpec: Str66; Type Env=Array [0..32767] Of Char; Var EPtr: ^Env; EStr: Str255; Done: Boolean; I: Integer; Begin EPtr:=Ptr(MemW[CSeg:$002C],0); I:=0; Done:=False; EStr:=''; Repeat If EPtr^[I]=#0 Then Begin If EPtr^[I+1]=#0 Then Done:=True; If Copy(EStr,1,8)='COMSPEC=' Then Begin GetComSpec:=Copy(EStr,9,100); Done:=True; End; EStr:=''; End Else EStr:=EStr+EPtr^[I]; I:=I+1; Until Done; End; { Example program. Set both mInimum and mAximum free dynamic memory to 100 and compile this to a .COM file. Delete the next line to enable: } (* Var Command: Str255; I: Integer; Begin WriteLn('Enter a * to quit; put a * before a command to use COMMAND.COM.'); Repeat Write('=->'); ReadLn(Command); If Command='*' Then Halt; If Command<>'' Then Begin If Command[1]='*' Then Command:=GetComSpec+' /C '+Copy(Command,2,255); I:=SubProcess(Command); If I<>0 Then WriteLn('Error - ',I); End; Until False; End. *) {The two procedures which are included are intended to allow you to place the cursor on a field, specify the field's size, and obtain its input. This is written for MS-DOS and PC-DOS systems, but may also work in CP/M environments. Variables to be declared are: Field : String[n] Where n = maximum field size to be input; Place,FieldSize : Integer; (Place points to where you are in the field) Result : Integer; (Indicates error in numeric conversion) Ch : Char; Cursor : Char; (an underscore (_) for example) Note that you can include error conditions in I/O checking by passing the value of Result to your Error Trapping routines. You will need to set FieldSize prior to calling InputField, and you should reset Field to '' after assigning it to your input variable. StripBlanks is used if you are getting Numeric input. These procedures should be handy if you are using formatted screen input, such as invoice forms, time sheets, etc. written by Ken McClure 75156,2641 } Program Input; var Field : String[10]; FieldSize : Integer; Ch : Char; TestFieldOne : String[8]; TestFieldTwo : Integer; Result : Integer; Place : Integer; Cursor : Char; procedure InputField; label Bypass; begin Field := ''; Place := 0; Repeat Read(Kbd,Ch); If Length(Field)<=FieldSize then begin Case Ch of #8 : begin {BackSpace key} If Place=0 then begin {avoid backspacing beyond} Write(Trm,Chr(8)); {beginning of field } Write(' '); end else begin Delete(Field,Place,1); {destructive backspace} Place := Place-1; Write(Trm,Chr(8)); Write(Cursor); Write(Trm,Chr(8)); end; end; #127 : begin; {Delete Key} If Place=0 then begin {avoid backspacing beyond} Write(Trm,Chr(8)); {beginning of field again} Write(' '); end else begin Delete(Field,Place,1); {destructive backspace} Place := Place-1; Write(Trm,Chr(8)); Write(Cursor); Write(Trm,Chr(8)); end; end; #13 : begin {Carraige Return--End of input} GoTo Bypass; {for this field } end; else If Length(Field) Chr(13) then Write(Chr(7)); {Ring bell at terminal if at end of} end; {field and no RETURN key pressed } ByPass: end; end; Until Ch=Chr(13); end; procedure StripBlanks; {don't use on Alpha-numeric fields...} {blanks there may be valid } begin Repeat Place := Pos(' ',Field); Delete(Field,Place,1); Place := Pos(' ',Field); Until Place=0; end; begin {little sample program} ClrScr; Write('What do you use to delineate fields? (e.g., "_") :'); Read(Cursor); GoToXY(30,4); Write('Test Input'); GoToXY(10,6); Write('Alpha Data: '); GoToXY(30,6); FieldSize := 8; For Place := 1 to FieldSize do begin Write(Cursor); end; GoToXY(30,6); InputField; TestFieldOne := Field; Field := ''; GoToXY(10,8); Write('Numeric Data: '); GoToXY(30,8); FieldSize := 4; For Place := 1 to FieldSize do begin Write(Cursor); end; GoToXY(30,8); InputField; StripBlanks; Val(Field,TestFieldTwo,Result); Field := ''; end.{The following routine is an addition to the original FLDINPUT.PAS file submitted earlier. Once again, this a data-entry type function de- signed to help in the creation of data-entry routines. This procedure will do range checking on numeric entries. New variables to be declared here are: LowEnd : Real; (Lower limit in a range - for range checking) HighEnd : Real; (Upper limit in a range) Value : Real; (Converted value of 'FIELD' entered) RangeOK : Boolean; (Passed Range Check? (True or False)) Prior to calling this routines, you will need to set values for LowEnd and HighEnd, to establish the valid range for checking. A complete sample using functions from FLDINPUT.PAS and RANGECHK.PAS is included in the file ENTSAMPL.PAS. Ken McClure 75156,2641 } procedure RangeCheck; begin Result := 0; {initialize error code} StripBlanks; {from FLDINPUT.PAS - pull out blanks} Val(Field,Value,Result); {convert Field to a Number} If Result <> 0 then begin {look for non-numeric characters} Result := 0; {reset result code} RangeOK := False; Write(Chr(7); GoToXY(1,23); ClrEol; WriteLn('Input must be numeric. '); Write('Press any key to continue... '); Read(Kbd,Ch); GoToXY(1,23); ClrEol; GoToXY(1,24); ClrEol; end else begin If (Value < LowEnd) or (Value > HighEnd) then begin Write(Chr(7); {see if value entered is within range} RangeOK := False; GoToXY(1,23); ClrEol; WriteLn('Value not in allowable range. '); Write('Press any key to continue... '); Read(Kbd,Ch); GoToXY(1,23); ClrEol; GoToXY(1,24); ClrEol; end else begin RangeOK := True; end; {checking range} end; {checking result code} end; {of RangeCheck} {$C-} {no user interrupts} {$U-} {$K-} {no stack checking - program works} program Modem; { Written by Jack M. Wierda Chicago Illinois Modified by Steve Freeman LANGUAGE: TURBO Pascal This program is in the public domain. This program is basically a re-write in PASCAL of Ward Christensen's Modem Program which was distributed in CP/M User's Group Volume 25. Identical and compatible options are provided to allow this program to work directly with XMODEM running under CP/M. } const Version = '12-Nov-84'; FredsPhone = '7-5038'; SignOnLine = 'ACGM10,RLIP,PSSWD'; MaxPhoneNums = 26; COMport = 1; NUL = 00; SOH = #$01; EOT = #$04; ACK = #$06; TAB = 09; LF = #$0A; CR = #$0D; NAK = #$15; Space = ' '; DELete = $7F; lastbyte = 127; timeout = 256; errormax = 5; retrymax = 5; loopspersec = 6500; Intseg: integer = 0; {filled with interrupt segment address} type maxstr = string[255]; PhoneEntry = string[32]; PhoneStr = string[20]; BytePointer = ^byte; var COMbase: integer; {this will point to the Communications base} WorkFile: file; PhoneFile: text; PhoneList: array[1..MaxPhoneNums] of PhoneEntry; option, hangup, return, mode, baudrate : char; sector : array[0..lastbyte] of byte; base, N_Phones: integer; { interrupt vectors and pointers to them } newvec, oldvec: BytePointer; INT3: BytePointer absolute $0000:$002C; {for COM2:} INT4: BytePointer absolute $0000:$0030; {for COM1:} rcvbuf: array[0..127] of byte; inptr, outptr: integer; datardy: boolean; {.pa} type hexstr = string[4]; function hex(num: integer): hexstr; var i, j: integer; h: string[16]; str: hexstr; begin str := '0000'; h := '0123456789ABCDEF'; j := num; for i:=4 downto 1 do begin str[i] := h[(j and 15)+1]; j := j shr 4; end; hex := str; end; {.cp10} function GetYN: char; var c: char; begin repeat read(kbd,c); c := upcase(c); until c in ['Y','N']; writeln(c); GetYN := c end; {.cp4} procedure SetDTR; begin port[base+4] := $09; {DTR on and INT enabled} end; {.cp4} procedure HangUpPhone; {hang up by terminating the line} begin port[base+4] := 0; end; {.cp7} function status: integer; var st: integer; begin st := port[base+5]; st := st shl 8 + port[base+6]; status := st; end; {.cp6} procedure send(ch: char); var s: byte; begin repeat s := port[base+5] and $20 until (s=$20); port[base] := ord(ch); end; {.cp6} function get_rcv_char: char; begin get_rcv_char := chr(rcvbuf[outptr]); outptr := (outptr + 1) and $7F; if inptr=outptr then datardy := false; end; {.cp5} function receive: char; begin repeat until datardy; receive := get_rcv_char; end; {.cp9} function ReadLine(seconds:integer): integer; var j : integer; begin j := loopspersec * seconds; repeat j := j-1 until datardy or (j = 0); if j = 0 then readline := timeout else readline := ord(get_rcv_char); end; {.cp8} procedure PurgeLine; {purge the receive register} var c: char; begin repeat if datardy then c := get_rcv_char; delay(35); { 300 baud time period for received char } until not(datardy) end; {.cp42} procedure Set_RS232_Vector; procedure Int_Handler; { This routine buffers all incoming received data } begin inline($50/$52/$57/$1E/ {save registers} $2E/ {CS:} $8E/$1E/Intseg/ {MOV DS,[Intseg]} {get data segment pointer} $BA/$FD/$03/ {MOV DX,$3FD} {is character ready?} $EC/ {IN AL,DX} $24/$01/ {AND AL,01} $74/$19/ {JZ here} { no, skip entry} $BA/$F8/$03/ {MOV DX,$3F8} { yes, get pointer} $A1/inptr/ {MOV AX,[inptr]} {get index to buffer} $97/ {XCHG DI,AX} $EC/ {IN AL,DX} {get data from receiver} $88/$85/rcvbuf/ {MOV [DI+rcvbuf],AL} {put data into buffer} $97/ {XCHG DI,AX} {increment pointer} $40/ {INC AX} $24/$7F/ {AND AL,$7F} $A3/inptr/ {MOV [inptr],AX} $B8/$01/$00/ {MOV AX,1} {show data is ready} $A2/datardy/ {MOV [datardy],AX} {here} $B0/$64/ {MOV AL,64} {EOI, level 4 on 8259} $E6/$20/ {OUT 20,AL} $1F/$5F/$5A/$58/$CF); {restore and return} end; begin Intseg := Dseg; COMbase := $0400 + 2 * (COMport - 1); oldvec := INT4; newvec := ptr(cseg,ofs(Int_Handler)+7+5); INT4 := newvec; inline($BA/$3F8/ {MOV DX,BASE} $EC/$EC/$EC/$EC/ {IN AL,DX} $BA/$3FD/$EC/ {MOV DX,BASE+5 ! IN AL,DX} $BA/$3FE/$EC); {MOV DX,BASE+6 ! IN AL,DX} datardy := false; inptr := 0; outptr := inptr; inline($E4/$21/$24/$EF/$E6/$21); {turn off IRQ mask bit - enabled} end; {.cp16} procedure Setup(md, brc: char); var al: integer; begin base := memw[0:COMbase]; port[base+3] := $83; {access baud rate divisor and sets 8 data, no parity, 1 stop} if md='O' then mode:=' ' else mode:='R'; baudrate := brc; if baudrate='1' then portw[base] := $0060 {1200 baud} else portw[base] := $0180; { 300 baud} port[base+3] := $03; {set access for xmt/rcv} port[base+1] := $01; {enable receiver interrupts} SetDTR; {put station on-line} return := 'N'; end; {.cp16} procedure Initialize; var mode, baudrate: char; begin repeat write('Mode : A(nswer), O(riginate) ? '); read(kbd,mode); mode := upcase(mode); until mode in ['A','O']; writeln(mode); repeat write('Baud rate : 3(00), 1(200) ? '); read(kbd,baudrate); until baudrate in ['1','3']; writeln(baudrate); Setup(mode,baudrate); end; {.cp19} procedure terminal; var s, t: byte; c: char; begin {$I-} {no I/O checking here} writeln('Use ctrl-E to exit terminal mode.'); repeat s := port[base+5]; {get status} if datardy then begin t := ord(get_rcv_char); t := t and $7F; if t<>$7F then write(chr(t)); end; if keypressed and ((s and $20) = $20) then begin read(kbd,c); port[base] := ord(c); end; until (c = ^E); end; {$I+} {.cp5} procedure sendtext(str: maxstr); var i: integer; begin for i:=1 to length(str) do send(str[i]); end; {.cp20} function Dial(PhoneNumber: PhoneStr): char; var c, kc: char; t: integer; begin HangUpPhone; write(cr,lf,'Dialing: ',PhoneNumber); delay(250); SetDTR; delay(250); sendtext(cr); delay(1000); sendtext('AT '+mode+'M1V0DT'+PhoneNumber+cr); delay(2000); c := receive; c := chr(0); repeat c := get_rcv_char until (c=cr); write(', Waiting for carrier ...'); t := 60 * loopspersec; repeat t := t - 1; if datardy then c := get_rcv_char; if keypressed then read(kbd,kc); until (c in ['0'..'5']) or (t=0) or (kc=^E); if c='1' then writeln(' connected.') else if (t=0) or (kc=^E) then c := '9'; Dial := c end; {.cp15} procedure SignOn; var i: integer; c: char; begin write('Signing on ... '); delay(2000); for i:=1 to 7 do begin send('8'); delay(333); end; sendtext('('+cr); delay(2500); sendtext(SignOnLine+cr); writeln('all set !'); end; {.pa} procedure SendFile; var j, sectornum, counter, checksum : integer; filename : string[20]; c: char; procedure SendIt; begin sectornum := 1; repeat counter := 0; blockread(WorkFile,sector,1); repeat write(cr,'Sending sector ', sectornum); send(SOH); send(chr(sectornum)); send(chr(-sectornum-1)); checksum := 0; for j:=0 to lastbyte do begin send(chr(sector[j])); checksum := (checksum + sector[j]) mod 256 end; send(chr(checksum)); purgeline; counter := counter + 1; until (readline(10) = ord(ack)) or (counter = retrymax); sectornum := sectornum + 1 until (eof(WorkFile)) or (counter = retrymax); if counter = retrymax then writeln(cr,lf,'No ACK on sector') else begin counter := 0; repeat send(EOT); counter := counter + 1 until (readline(10)=ord(ack)) or (counter=retrymax); if counter = retrymax then writeln(cr,lf,'No ACK on EOT') else writeln(cr,lf,'Transfer complete'); end; end; begin write('Filename.Ext ? '); readln(filename); if length(filename)>0 then begin assign(WorkFile,filename); reset(WorkFile); SendIt; close(WorkFile) end; end; {.pa} procedure readfile; var j, firstchar, sectornum,sectorcurrent, sectorcomp, errors, checksum : integer; errorflag : boolean; filename : string[20]; procedure ReceiveIt; begin sectornum := 0; errors := 0; send(nak); send(nak); { send ready characters } repeat errorflag := false; repeat firstchar := readline(20) until firstchar in [ord(SOH),ord(EOT),timeout]; if firstchar = timeout then writeln(cr,lf,'Error - No starting SOH'); if firstchar = ord(SOH) then begin sectorcurrent := readline(1); {real sector number} sectorcomp := readline(1); {+ inverse of above} if (sectorcurrent+sectorcomp)=255 {<-- becomes this #} then begin if (sectorcurrent=sectornum+1) then begin checksum := 0; for j := 0 to lastbyte do begin sector[j] := readline(1); checksum := (checksum+sector[j]) and $00FF end; if checksum=readline(1) then begin blockwrite(WorkFile,sector,1); errors := 0; sectornum := sectorcurrent; write(cr,'Received sector ',sectorcurrent); send(ack) end else begin writeln(cr,lf,'Checksum error'); errorflag := true end end else if (sectorcurrent=sectornum) then begin repeat until readline(1)=timeout; writeln(cr,lf,'Received duplicate sector ', sectorcurrent); send(ack) end else begin writeln(cr,lf,'Synchronization error'); errorflag := true end end else begin writeln(cr,lf,'Sector number error'); errorflag := true end end; if errorflag then begin errors := errors+1; repeat until readline(1)=timeout; send(nak) end; until (firstchar in [ord(EOT),timeout]) or (errors = errormax); if (firstchar=ord(EOT)) and (errors0 then begin assign(WorkFile,filename); rewrite(WorkFile); ReceiveIt; close(WorkFile); end; end; {.cp17} function ReadPhoneList: integer; var index: integer; begin assign(PhoneFile,'MODEM.PHN'); index := 0; {$I-} reset(PhoneFile); {$I+} if IOresult=0 then begin while (not eof(PhoneFile)) and (index<26) do begin index := index + 1; readln(PhoneFile,PhoneList[index]); end; close(PhoneFile); end; ReadPhoneList := index; end; {.cp41} procedure Call; var rc: char; selection, i, j, k: integer; PhoneNo: PhoneStr; begin if N_Phones>0 then begin clrscr; writeln; for i:=1 to N_Phones do begin if (i mod 2)=0 then write(' ') else writeln; write(chr(i+64),' - ',PhoneList[i]); end; writeln; writeln; write('Enter selection letter: '); repeat repeat until keypressed; read(kbd,rc); rc := upcase(rc); selection := ord(rc) - ord('@'); until (selection in [1..N_Phones]); writeln(rc); mode := PhoneList[selection][31]; baudrate := PhoneList[selection][32]; Setup(mode,baudrate); j := 30; PhoneNo := ''; while PhoneList[selection][j]<>'.' do j:=j-1; for k:=j+1 to 30 do PhoneNo := PhoneNo + PhoneList[selection][k]; rc := Dial(PhoneNo); end else rc := Dial(FredsPhone); if rc='1' then begin if N_Phones=0 then SignOn else if selection=1 then Signon; terminal; end else HangUpPhone; end; {.cp22} procedure GetOption; begin clrscr; writeln('Modem, ',Version); gotoxy(7,4); writeln('Options:'); writeln; writeln(' R - receive a file'); writeln(' S - send a file'); writeln(' T - terminal mode'); writeln; writeln(' C - place a call'); writeln(' H - hang up the phone'); writeln(' O - option configuration'); writeln(' X - exit to system'); writeln; write('which ? '); repeat read(kbd,option); option := upcase(option); until option IN ['O','C','R','S','T','H','X']; writeln(option); end; {.cp16} begin {Modem} Set_RS232_Vector; N_Phones := ReadPhoneList; Setup('O','1'); { default of Originate/1200 baud } repeat GetOption; case option of 'T': Terminal; 'R': ReadFile; 'S': SendFile; 'O': Initialize; 'C': Call; 'H': HangUpPhone; 'X': return := 'Y'; end; until return='Y'; inline($E4/$21/$0C/$10/$E6/$21); {turn on IRQ mask bit - disabled} (* INT4 := oldvec; {restore the old RS232 vector} *) end.