Power-Programmierung/CD1.mdf/pascal/library/dos/communic/tp55/snd&rec.pas

Pascal/Delphi Source File | 1993-08-23 | 22.0 KB | 994 lines

program send_and_receive;

uses   dos,crt;

const  max_buffer  =4096;  { Grösse der Sende- und Empfangspuffer }
       timeout_len = 900;  { 50 sek ist die TIMEOUT Zeit }

       intctrl     = $21;
       rs8259      = $20;

       enable_IRQ4 = $EF;
       enable_IRQ3 = $F7;

       ACK         = ^F;
       NAK         = ^U;
       XON         = ^Q;
       XOFF        = ^S;

       ESC         = #27;
       CR          = #13;
       LF          = #10;
       TAB         = #9;
       BEL         = #7;
       BLANK       = #32;
       CARET       = #94;

       PROGID      = 'SND&REC V1.01 (c) 1992-1993  Peter Sieg';

type   buff_type   = array[0..max_buffer] of char;

var    time_out                                  : boolean;
       com_open                                  : boolean;
       intr_pointer                              : pointer;
       send_buffer,receive_buffer                : buff_type;
       filvar,protfil                            : text;
       int_enable_reg,modem_read_i,
       line_cntr_reg,modem_cntr_reg,pzeiger,
       pkopf,dataport,modem_line_status          : word;

       int_com                                   : byte;
       com_IRQ,com_BASE,com_INTR                 : array[1..2] of word;
       timer                                     : longint absolute $0:$46C;
       ch,ch1                                    : char;
       PARFILE                                   : string;
       EDITOR                                    : string;
       filename                                  : string;
       line                                      : string;
       answer                                    : string;
       c                                         : char;
       b                                         : byte absolute c;
       COMPORT,BAUDRATE,PARITY,DATABITS,STOPBITS : word;
       BITMASK,EIGHTBIT,CR_CRLF                  : word;
       PROTOKOL                                  : word;

{ ------------------------ datei --------------------------- }

function datei(name : string) : boolean;

var filvar  : text;
    ioerror : word;

begin
  assign(filvar,name);
  {$I-};
  reset(filvar);
  {$I+};
  ioerror:=ioresult;
  datei:=(ioerror=0);
  if ioerror=0 then close(filvar);
end;

{ --------- clear_receive_buffer --------- }

procedure clear_receive_buffer;

begin
  pzeiger:=0; pkopf:=0;
end;

{ ----------- send_com_buffer -------------- }

{ Sende Puffer ab einer bestimmten Position }

procedure send_com_buffer(ab : word);

var  start_time : longint;

begin
  repeat
    { Teste ob gesendet werden kann }
    start_time:=timer; time_out:=false;
    repeat
    until ((port[modem_line_status] and $20)=$20) or (timer-start_time>timeout_len);

    if timer-start_time<timeout_len then
      port[dataport]:=ord(send_buffer[ab])
    else
      time_out:=true;

    inc(ab);
  until (ab>max_buffer) or (send_buffer[ab]=#0) or time_out;
end;

{ --------- send_string ---------- }

procedure send_string(zk : string);

{ Sende einen String }

var len : byte;

begin
  len:=length(zk);
  time_out:=false;
  move(zk[1],send_buffer[1],len);
  send_buffer[len+1]:=#0;
  send_com_buffer(1);
end;

{ ------------ put_chr ----------- }

{ Lege ein Zeichen im Puffer ab }

procedure put_chr;

var wert : char;

begin
  wert:=chr(port[dataport]);  { Hole Zeichen }

  { Lege Zeichen in Puffer ab }

  receive_buffer[pkopf]:=wert;
  inc(pkopf);
  if pkopf>max_buffer then pkopf:=0;
end;

{ ---------- getchar --------- }

{ Hole ein Zeichen aus dem Empfangspuffer }

function getchar : char;

begin
  if pzeiger<>pkopf then
    begin
      getchar:=receive_buffer[pzeiger];
      inc(pzeiger);
      if pzeiger>max_buffer then pzeiger:=0;
    end
  else
    getchar:=#0;
end;

{ -------- charready -------- }

function charready : boolean;

{ Ist ein neues Zeichen im Puffer ? }

begin
  charready:=pkopf<>pzeiger;
end;

{ ------- receive_string ------- }

function receive_string : string;

var ch         : char;
    start_time : longint;
    answer     : string;

begin
  answer:='';
  time_out:=false; start_time:=timer;
  repeat
    ch:=getchar;

    if ch>#31 then
      begin
        answer:=answer+ch;
        start_time:=timer;
      end;
    if timer-start_time>timeout_len then time_out:=true;

  until (ch=CR) or time_out;
  receive_string:=answer;
end;

{ ------- wait_string_until ------- }

function wait_string_until(c : char) : string;

var ch         : char;
    start_time : longint;
    answer     : string;

begin
  answer:='';
  time_out:=false; start_time:=timer;
  repeat
    ch:=getchar;

    if ch>#31 then
      begin
        answer:=answer+ch;
        start_time:=timer;
      end;
    if timer-start_time>timeout_len then time_out:=true;

  until (ch=c) or (ch=CR) or time_out or keypressed;
  wait_string_until:=answer;
end;

{ ------------------ Interrupt-Handler ----------------------- }

procedure inthandler; interrupt;

begin
  inline($fb); { Gebe Interrupts frei }
  put_chr;
  port[rs8259]:=$20;
  inline($fa); { Sperre Interupts }
end;

{ -------- close_com ------- }

procedure close_com;

begin
  if com_open = false then exit;

  { Stelle alten Interruptvektor von com wieder her }

  inline($FA);

  port[modem_cntr_reg]:=0;
  port[intctrl]:=port[intctrl] or $18;
  port[int_enable_reg]:=0;
  (* clear pending interupts *)
  while (port[modem_read_i] and 1) = 0 do
  begin
    b:=port[modem_line_status];
    b:=port[dataport+6];
    b:=port[dataport];
    port[rs8259]:=$20;
  end;

  setintvec(int_com,intr_pointer);
  inline($FB);
  (*
  { Interrupts an 8259 freigeben }
  port[rs8259]:=$20;
  *)
  com_open := false;
end;

{ ------- Initialisiere Schnittstelle -------- }

procedure open_com(com_nr,baud,parity,databits,stopbits,bitmask : word);

var  wert,enable_IRQ   : byte;
     zeiger            : pointer;
     base              : word;

procedure com_init(baud,parity,databits,stopbits,bitmask : word);

{ Einen COM Anschluss initialisieren }

begin
  case baud of
     600 : baud:=192;
    1200 : baud:=96;
    2400 : baud:=48;
    4800 : baud:=24;
    9600 : baud:=12;
   19200 : baud:=6;
  end;

  port[line_cntr_reg]:=$80; { DLAB = 1 }
  port[dataport]:=baud;

  { DLAB = 0 }

  port[line_cntr_reg]:=databits-5+(stopbits-1)*4+byte((parity>0))*8+byte(parity=2)*16;
end;

begin
  if com_open = true then close_com;

  { Setze Pufferzeiger auf Anfang }

  pzeiger:=0; pkopf:=0;

  base:=com_BASE[com_nr];
  int_com:=com_INTR[com_nr];

  if com_IRQ[com_nr]=4 then
    enable_IRQ:=enable_IRQ4
  else
    enable_IRQ:=enable_IRQ3;

  { Setze Variablen auf }

  dataport         :=base;
  int_enable_reg   :=base+1;
  modem_read_i     :=base+2;
  line_cntr_reg    :=base+3;
  modem_cntr_reg   :=base+4;
  modem_line_status:=base+5;

  com_init(baud,parity,databits,stopbits,bitmask);

  { Initialisiere 8250 }

  inline($FA);

  wert:=port[intctrl];
  port[intctrl]:=wert and enable_IRQ;

  { 'Data ready' Interrupt auf 8250 einschalten }

  port[int_enable_reg]:=1;        { Data-Ready einschalten }
  port[modem_cntr_reg]:=bitmask;  { RTS,DTR & OUT2 einschalten }
  port[modem_line_status]:=$60;
  port[base+7]:=15;

  { Interrupt einhängen für com }

  getintvec(int_com,intr_pointer);
  zeiger:=@inthandler;
  setintvec(int_com,zeiger);
  inline($FB);

  com_open:=true;
end;

{ ---------- wait_for_ack --------- }

procedure wait_for_ack;

var start_time : longint;

begin
  start_time:=timer;
  repeat
  until (getchar=ACK) or (timer-start_time>timeout_len);

  if timer-start_time>timeout_len then time_out:=true;
end;

{ -------- name_file ------- }

procedure name_file;

begin
  writeln;
  write('Input Name : ');
  readln(filename);
  writeln(^J);
end;

{ -------- send_file ------- }

procedure send_file;

var ch         : char;
    sendfil    : text;
    line       : string;
    line_count : word;

begin
  line_count:=0; time_out:=false;
  if filename<>'' then
    if not datei(filename) then
      begin
        writeln('File ',filename,' not found !!');
        ch:=readkey;
      end
    else
      begin
        assign(sendfil,filename);
        reset(sendfil);

        repeat
          readln(sendfil,line);
          send_string(line+CR);
          inc(line_count);
          write('Send Line : ',line_count:5,^M);
          delay(100);
          clear_receive_buffer;
        until eof(sendfil) or time_out or keypressed;

        close(sendfil);
        if keypressed then ch:=readkey;
      end;
end;


{ -------- terminal mode --------- }

procedure terminal_mode;

begin
  time_out:=false;
  clear_receive_buffer;
  line:='';
  repeat
    while charready do
    begin
      c:=getchar;
      if EIGHTBIT=0 then b:=b and $7F;
      if not (c in [XON,XOFF]) then
      begin
        write(c);
        if PROTOKOL<>0 then write(protfil,c);
        if (CR_CRLF<>0) and (c=CR) then write(LF);
      end;
    end;
    c:=CR;
    if keypressed then
    begin
      c:=readkey;
      if c=CR then
      begin
        send_string(line+CR);
        line:='';
      end
      else
      begin
        line:=line+c;
      end;
      if c<>ESC then write(c);
    end;
  until c=ESC;
end;


{ -------- metec mode --------- }

procedure metec_mode;

var delay_ms : word;

begin
  writeln;
  writeln('Connect the Metec M-3650 CR Digital Multimeter to your serial');
  writeln('interface and select the range you want. To end press any key.');
  writeln;
  write  ('Enter the delay time between two data transmissions (ms): ');
  readln(delay_ms);
  writeln;

  time_out:=false;
  clear_receive_buffer;

  repeat
    while charready do
    begin
      c:=getchar;
      if EIGHTBIT=0 then b:=b and $7F;
      if not (c in [XON,XOFF]) then
      begin
        write(c);
        if PROTOKOL<>0 then write(protfil,c);
        if (CR_CRLF<>0) and (c=CR) then write(LF);
      end;
    end;
    send_string('D'+CR);
    delay(delay_ms);
  until keypressed;
  while keypressed do c:=readkey;
end;


{ -------- download_tsm ------- }

procedure download_tsm;

var ch         : char;
    downfil    : text;
    line       : string;
    line_count : word;
    InWord     : boolean;

begin
  line_count:=0; time_out:=false; InWord:=false;
  if filename<>'' then
    if not datei(filename) then
      begin
        writeln('File ',filename,' not found !!');
        ch:=readkey;
      end
    else
      begin
        assign(downfil,filename);
        reset(downfil);

        repeat
          readln(downfil,line);
          send_string(line+CR);
          inc(line_count);
          write('Send Line : ',line_count:5,^M);
          answer:=receive_string;
          if pos(':',line) > 0 then InWord:=true;
          if pos(';',line) > 0 then InWord:=false;
          if
             (pos('END-DEFINE',line) > 0) or
             (pos('CONSTANT',line) > 0) or
             (pos('LABEL',line) > 0) or
             ((pos(':=',line) > 0) and not InWord) or
             (pos(';',line) > 0)
          then
          begin
            if pos('OK',answer) = 0 then
            begin
              writeln(^J,line,answer);
              exit;
            end;
          end;
        until eof(downfil) or time_out;

        close(downfil);
      end;
end;


{ -------- edit_file ------- }

procedure edit_file;

var  filvar     : text;

begin
  if filename<>'' then
      begin
        exec(EDITOR,filename);
      end;
end;


{ -------- exec_command ------- }

procedure exec_command;

var  filvar     : text;
     name       : string;
     line       : string;

begin
  write('Input complete path and name: ');
  readln(name);
  if name<>'' then
      begin
        write('Input command line parameter: ');
        readln(line);
        exec(name,line);
      end;
end;

{ -------- read_parameter ------- }

procedure read_parameter;

var ch         : char;
    filvar     : text;
    line       : string;
    status     : integer;

begin
    if not datei(PARFILE) then
      begin
        writeln('File ',PARFILE,' not found !!');
        ch:=readkey;
      end
    else
      begin
        assign(filvar,PARFILE);
        reset(filvar);

        readln(filvar,line);
        if line <> PROGID then
          begin
            writeln('File ',PARFILE,' wrong program id!!');
            ch:=readkey;
            exit;
          end;

        readln(filvar,line);
        val(line,COMPORT,status);

        readln(filvar,line);
        val(line,BAUDRATE,status);

        readln(filvar,line);
        val(line,PARITY,status);

        readln(filvar,line);
        val(line,DATABITS,status);

        readln(filvar,line);
        val(line,STOPBITS,status);

        readln(filvar,line);
        val(line,BITMASK,status);

        readln(filvar,line);
        val(line,EIGHTBIT,status);

        readln(filvar,line);
        val(line,CR_CRLF,status);

        readln(filvar,EDITOR);

        readln(filvar,filename);

        close(filvar);

        close_com;
        open_com(COMPORT,BAUDRATE,PARITY,DATABITS,STOPBITS,BITMASK);

      end;
end;


{ -------- save_parameter ------- }

procedure save_parameter;

var   filvar     : text;

begin
        assign(filvar,PARFILE);
        rewrite(filvar);

        writeln(filvar,PROGID);
        writeln(filvar,COMPORT);
        writeln(filvar,BAUDRATE);
        writeln(filvar,PARITY);
        writeln(filvar,DATABITS);
        writeln(filvar,STOPBITS);
        writeln(filvar,BITMASK);
        writeln(filvar,EIGHTBIT);
        writeln(filvar,CR_CRLF);
        writeln(filvar,EDITOR);
        writeln(filvar,filename);

        close(filvar);
end;


{ -------- edit_parameter ------- }

procedure edit_parameter;

begin
        writeln;
        write('COMPORT : '); readln(COMPORT);
        write('BAUDRATE: '); readln(BAUDRATE);
        write('PARITY  :   (0=N/1=E)',CR,'PARITY  : '); readln(PARITY);
        write('DATABITS: '); readln(DATABITS);
        write('STOPBITS: '); readln(STOPBITS);
        write('BITMASK :   (11/9)',CR,'BITMASK : '); readln(BITMASK);
        write('EIGHTBIT: '); readln(EIGHTBIT);
        write('CR->CRLF: '); readln(CR_CRLF);
        write('EDITOR  : '); readln(EDITOR);
        close_com;
        open_com(COMPORT,BAUDRATE,PARITY,DATABITS,STOPBITS,BITMASK);
end;

{ -------- Parameter -------- }

procedure parameter;

var ch         : char;
    line       : string;

begin
  repeat
    writeln;
    write  ('s. Save Parameter (');
    write  (PARFILE,',',COMPORT,',',BAUDRATE,',',PARITY,',',DATABITS,',',STOPBITS,',');
    writeln(BITMASK,',',EIGHTBIT,',',CR_CRLF,',',EDITOR,')');
    writeln('e. Edit Parameter');
    writeln('r. Read Parameter');
    writeln('n. Name Parm-File (',PARFILE,')');
    writeln;
    writeln('0. Exit Parameter');

    ch:=readkey;

    case ch of
     's' : save_parameter;
     'e' : edit_parameter;
     'r' : read_parameter;
     'n' : begin
             line:=filename;
             name_file;
             if filename<>'' then PARFILE:=filename;
             filename:=line;
           end;
    end;

  until ch in ['0',ESC];
end;

{ -------- protokoll ------- }

procedure protokoll;

var ch         : char;

begin
  if PROTOKOL=0 then
  begin
    if filename<>'' then
    begin
      (*
      if datei(filename) then
        begin
          writeln('File ',filename,' already exist !!');
          writeln('Press <ESC> to cancel.');
          ch:=readkey;
          if ch=ESC then exit;
        end;
      *)
      assign(protfil,filename);
      rewrite(protfil);
      PROTOKOL:=1;
    end;
  end
  else
  begin
    close(protfil);
    PROTOKOL:=0;
  end;
end;

{ -------- exec_script -------- }

procedure exec_script;

var  thiscode   : char;
     linkcode   : char;
     thisline   : string;
     answer     : string;
     filvar     : text;
     ch         : char;
     waittime   : integer;
     n          : integer;

begin
  time_out:=false;
  clear_receive_buffer;
  if filename<>'' then
    if not datei(filename) then
      begin
        writeln('File ',filename,' not found !!');
        ch:=readkey;
      end
    else
      begin
        assign(filvar,filename);
        reset(filvar);
        repeat
          readln(filvar,thisline);
          thiscode:=thisline[1];
          linkcode:=thisline[2];
          delete(thisline,1,2);
          writeln(thiscode,linkcode:1,thisline);

          case thiscode of
            '#' : begin end; (* Only comment *)
            'n' : if (thisline<>'') then filename:=thisline
                  else name_file;
            'P' : protokoll;
            'p' : begin
                    PARFILE:=thisline;
                    read_parameter;
                  end;
            'd' : download_tsm;
            's' : send_file;
            '<' : begin
                    if (linkcode=CARET)
                      then thisline:=chr(ord(upcase(thisline[1]))-64);
                    n:=pos('???',thisline);
                    if n>0 then
                    begin
                      delete(thisline,n,3);
                      insert(filename,thisline,n);
                    end;
                    send_string(thisline+CR)
                  end;
            'w' : begin
                    val(thisline,waittime,n);
                    delay(waittime);
                    clear_receive_buffer;
                  end;
            '>' : repeat
                    if linkcode=BLANK then linkcode:=CR;
                    answer:=wait_string_until(linkcode);
                    if PROTOKOL<>0 then writeln(protfil,answer);
                    writeln('= ',answer);
                  until (pos(thisline,answer)>0) or time_out or keypressed;
          end;
        until eof(filvar) or time_out or keypressed;
        close(filvar);
        if keypressed then ch:=readkey;
      end;
end;


{ -------- MasterMind -------- }

procedure mastermind;

var
i,j,
Zahl,
Versuch                  :  integer;
Taste                    :  char;
MeineZahl,DeineZahl      :  string(.4.);


function ZufallsZiffer   :  integer;
(*
Gibt eine zufaellige Ziffer zwischen 1 und 9 zurueck
*)

var
x                        :  integer;

begin
  x                      := random(9);
  x                      := succ(x);
  ZufallsZiffer          := x;
end;

function ZufallsZahl     :  integer;
(*
Gibt eine vierstellige Zufallszahl ohne Nullen und doppelte Ziffern zurueck
*)

var
Ziffer1,Ziffer2,
Ziffer3,Ziffer4          :  integer;

begin
  Ziffer1                := ZufallsZiffer;

  repeat
    Ziffer2              := ZufallsZiffer;
  until Ziffer2 <> Ziffer1;

  repeat
    Ziffer3              := ZufallsZiffer;
  until ((Ziffer3 <> Ziffer2) and (Ziffer3 <> Ziffer1));

  repeat
    Ziffer4              := ZufallsZiffer;
  until ((Ziffer4 <> Ziffer3) and (Ziffer4 <> Ziffer2)
                              and (Ziffer4 <> Ziffer1));
  ZufallsZahl            := Ziffer4*1000+Ziffer3*100+Ziffer2*10+Ziffer1;

end;


begin
  close_com;
  repeat
    writeln;
    writeln('MasterMind: Guess my 4-digit #.');
    writeln('(+ = right digit but wrong pos.; # = right digit and position)');
    randomize;

    Zahl                 := ZufallsZahl;

    str(Zahl:4,MeineZahl);

    Versuch              := 1;
    repeat
      (*$i-*)
      repeat
        writeln; clreol;
        write  (Versuch:3,' : ');
        read   (Zahl);
      until ((Zahl > 1222) and (Zahl < 9888) and (ioresult = 0));
      (*$i+*)

      str(Zahl:4,DeineZahl);

      for i              := 1 to 4 do
      begin
        if DeineZahl[i] = MeineZahl[i] then write  ('# ')
        else
        begin
          for j          := 1 to 4 do
          begin
            if DeineZahl[j] = MeineZahl[i] then write  ('+ ');
          end;
        end;
      end;

      Versuch            := succ(Versuch);

    until DeineZahl = MeineZahl;

    writeln;
    writeln(BEL);
    writeln('You made it. Again ?');
    repeat
      repeat
      until keypressed;
      Taste              := readkey;
      Taste              := upcase(Taste);
    until (Taste in ['Y','N']);

  until Taste = 'N';
  open_com(COMPORT,BAUDRATE,PARITY,DATABITS,STOPBITS,BITMASK);
end;


{ -------- Hauptprogramm ------- }

begin
  DirectVideo:=False;

  com_open:=false;
  com_IRQ[1]:=4;     com_IRQ[2]:=3;
  com_BASE[1]:=$3F8; com_BASE[2]:=$2F8;
  com_INTR[1]:=$0C;  com_INTR[2]:=$0B;
  COMPORT:=1;
  BAUDRATE:=9600;
  PARITY:=0;
  DATABITS:=8;
  STOPBITS:=1;
  BITMASK :=$0B;
  EIGHTBIT:=0;
  CR_CRLF :=1;
  PROTOKOL:=0;
  PARFILE:='SND&REC.PAR';
  EDITOR:='TED.COM';
  filename:='';

  read_parameter;

  repeat
    time_out:=false;

    writeln;
    write  ('p. Parameter (');
    write  (PARFILE,',',COMPORT,',',BAUDRATE,',',PARITY,',',DATABITS,',',STOPBITS,',');
    writeln(BITMASK,',',EIGHTBIT,',',CR_CRLF,',',EDITOR,')');
    writeln('P. Protokol  (',PROTOKOL,' --> ',filename,')');
    writeln('t. Terminal Mode');
    writeln('d. Download TSM');
    writeln('m. Metec 3650CR Mode');
    writeln('s. Send ASCII File');
    writeln('x. Execute Script');
    writeln('e. Edit File');
    writeln('X. Execute Command');
    writeln('n. Name File (',filename,')');
    writeln('M. MasterMind');
    writeln;
    writeln('0. Exit Program');

    ch:=readkey;

    case ch of
     'p' : parameter;
     'P' : protokoll;
     't' : terminal_mode;
     'd' : download_tsm;
     'm' : metec_mode;
     's' : send_file;
     'x' : exec_script;
     'e' : edit_file;
     'n' : name_file;
     'X' : exec_command;
     'M' : mastermind;
    end;

    if time_out then
      begin
        writeln(^J^M,'Timeout occured !!');
        ch1:=readkey;
      end;

  until ch = '0';
  close_com;
  PARFILE:='SND&REC.PAR';
  save_parameter;
end.