home *** CD-ROM | disk | FTP | other *** search
/ Source Code 1992 March / Source_Code_CD-ROM_Walnut_Creek_March_1992.iso / msdos / microcrn / issue_31.arc / MSTRANS.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1979-12-31  |  9.9 KB  |  334 lines
  1. {             File Transfer Program: MS-DOS to CP/M
  2.                Created 4/4/86 -- last edit 5/5/86
  3.              Copyright (c) 1986 by Gregory C. Flothe
  4.                        All Rights Reserved
  5.              Permission granted to copy for academic
  6.                  and educational purposes only.
  7. }
  8.  
  9. PROGRAM Transfer;
  10.  
  11. CONST
  12. BaudCode300=     2;
  13. BaudCode1200=    4;
  14. BaudCode4800=    6;
  15. BaudCode9600=    7;
  16. SOH=             1;
  17. RecSize=         128;
  18.  
  19. TYPE
  20. ModeType=        (send,receive);
  21. regpack =   RECORD
  22.               ax,bx,cx,dx,bp,si,di,ds,es,flags: integer;
  23.             END;
  24.  
  25. VAR
  26. Mode:            ModeType;
  27. Source, Dest:    File;
  28. Response:        Char;
  29. RemBlks:         String[5];
  30. FileName:        String[14];
  31. Buffer:          ARRAY[1 .. RecSize] OF Byte;
  32. PrintEnable,
  33. OK,PrintOn:      Boolean;
  34. Baud, Bytecount,
  35. NewChar,
  36. HighRem,StatWord,
  37. Remaining:       Integer;
  38. recpack:         regpack;
  39. BaudByte,
  40.   ah,al:         byte;
  41.  
  42. PROCEDURE LogOn;
  43. BEGIN
  44.   ClrScr;
  45.   writeln('File Transfer Utility Program -- Version 1.0');
  46.   writeln('for Zenith Z-130 and IBM PC-Compatibles');
  47.   writeln('running under MS-DOS 3.1');
  48.   writeln;
  49.   writeln('Copyright (c) 1986 by Greg C. Flothe');
  50.   writeln('All Rights Reserved');
  51.   Delay(3000);
  52. END;  {LogOn}
  53.  
  54. PROCEDURE InitPort;           {BaudByte contains current 3-bit Baud code}
  55. BEGIN
  56.   ah:= 0;                     {Init. port code -- '0' -- to high byte of AX}
  57.   al:= BaudByte shl 5 + $03;  {Baud code, no parity, 1 stop bit, 8-bit char}
  58.   WITH recpack DO
  59.     BEGIN
  60.       ax:= ah shl 8 + al;    {combine codes into AX register}
  61.       dx:= 0;                {DX contains serial port number}
  62.     END;
  63.   intr($14, recpack);        {interrupt & change serial port parameters}
  64.   writeln('Serial Port Ready');
  65. END;
  66.  
  67. PROCEDURE BaudRate;          {establish serial port speed with code}
  68. VAR Baudtype: integer;
  69. BEGIN
  70.   writeln('Baud Rate currently at ', Baud);
  71.   write('Change rate? '); readln(Response);
  72.   IF UpCase(Response) = 'Y' THEN
  73.     BEGIN
  74.       write('Enter 1>300  2>1200  3>4800  4>9600: ');
  75.       readln(BaudType);
  76.       CASE BaudType OF
  77.        1: BEGIN               {Assign baud code constant by 1 .. 4}
  78.             Baud:= 300;
  79.             BaudByte:= BaudCode300;
  80.           END;
  81.        2: BEGIN
  82.             Baud:= 1200;
  83.             BaudByte:= BaudCode1200;
  84.           END;
  85.        3: BEGIN
  86.             Baud:= 4800;
  87.             BaudByte:= BaudCode4800;
  88.           END;
  89.        4: BEGIN
  90.             Baud:= 9600;
  91.             BaudByte:= BaudCode9600;
  92.           END;
  93.       END;
  94.     END;  {if}
  95.     initport;         {send Baud code to serial port}
  96.     writeln('Baud Rate set to ',Baud,' BPS.');
  97.  
  98. END; {BaudRate}
  99.  
  100. PROCEDURE SetUpIO;     {Set Input/Output speed, flow}
  101. BEGIN
  102.   ClrScr;
  103.   BaudRate;
  104.   writeln; write('I/O MODE - ');
  105.   CASE Mode OF
  106.     send:     writeln('TRANSMIT');
  107.     receive:  writeln('RECEIVE');
  108.   END;
  109.   writeln; write('Change Mode (Y/N)? ');
  110.   readln(Response);
  111.   IF UpCase(Response) = 'Y' THEN
  112.     BEGIN
  113.       write('THIS terminal in SEND or RECEIVE mode? ');
  114.       REPEAT
  115.         readln(Response);
  116.       UNTIL UpCase(Response) IN ['R','S'];
  117.       CASE UpCase(Response) OF
  118.          'R':  Mode:= receive;
  119.          'S':  Mode:= send;
  120.       END;
  121.     END;
  122.   writeln;
  123. END;  {SetUpIO}
  124.  
  125. PROCEDURE TestPort(VAR StatWord: integer);
  126. BEGIN
  127.   REPEAT
  128.   ah:= 3;               {high AX = 03 -- test status code}
  129.   WITH recpack DO
  130.     BEGIN
  131.       ax:= ah shl 8;
  132.       dx:=0;            {DX register contains port number ('0' for COM1)}
  133.     END;
  134.   intr($14, recpack);
  135.   WITH recpack DO
  136.     OK:= (ax AND StatWord > 0);
  137.   UNTIL KeyPressed OR OK;
  138. END;  {testport}
  139.  
  140. PROCEDURE OutChar(VAR NewChar: integer);
  141. BEGIN
  142.   StatWord:=$2000;             {wait for xmit holding register to clear}
  143.   TestPort(StatWord);
  144.   ah:= 1;                      {out char. code -- '1' -- to high AX}
  145.   al:= NewChar;                {New Character in low AX byte}
  146.     WITH recpack DO
  147.        ax:= ah shl 8 + al;     {combine code with char. in AX register}
  148.   intr($14, recpack);          {interrupt and send character to port}
  149. END;   {outchar}
  150.  
  151. PROCEDURE InChar(VAR NewChar: Integer);
  152. BEGIN
  153.   StatWord:= $100;            {wait for data ready = true}
  154.   TestPort(StatWord);
  155.   {get char when OK}
  156.   ah:= 2;                     {in char. code -- '2' -- to high AX}
  157.   WITH recpack DO
  158.     BEGIN
  159.       ax:= ah shl 8;
  160.       dx:= 0;
  161.     END;
  162.   intr($14, recpack);         {interrupt for serial port service}
  163.   WITH recpack DO
  164.      NewChar:= Lo(ax);        {New Char. returned in low AX byte}
  165. END;
  166.  
  167. PROCEDURE GetHeader;
  168. BEGIN
  169.    REPEAT                {wait for Start Of Header 'SOH' char.}
  170.       InChar(NewChar);
  171.    UNTIL KeyPressed OR (NewChar = SOH);
  172.    OutChar(NewChar);    {echo SOH flag}
  173.    InChar(NewChar);     {read low block count byte}
  174.    Remaining:= NewChar;     {save lower byte}
  175.    OutChar(Remaining);      {echo for confirmation}
  176.    InChar(NewChar);         {get high block count}
  177.    HighRem:=NewChar;        {save it}
  178.    OutChar(NewChar);        {echo high count byte}
  179.    Remaining:= HighRem shl 8  + Remaining;  {restore Remaining}
  180. END;  {GetHeader}
  181.  
  182. PROCEDURE InBlock;
  183. BEGIN
  184.   Bytecount:= 1;
  185.     WHILE Bytecount <= RecSize DO     {read a block from port}
  186.       BEGIN
  187.         InChar(NewChar);                 {get char}
  188.         Buffer[Bytecount]:= NewChar;     {store it}
  189.         OutChar(NewChar);                {echo char}
  190.           IF PrintOn THEN
  191.             BEGIN
  192.               IF ((Remaining = 1) AND (NewChar = 26)) THEN
  193.                 PrintOn:= false     {search for ^Z (EOF) to halt output}
  194.                   ELSE
  195.                     write(Char(NewChar));
  196.             END;
  197.         Bytecount:= succ(Bytecount);
  198.      END; {while Bytecount}
  199. END;  {InBlock}
  200.  
  201. PROCEDURE ReceiveFile;        {get a file from ser. port & store it}
  202. BEGIN
  203.   writeln; write('Name of file to be received? ');
  204.   readln(FileName);
  205.   writeln;
  206.   IF FileName <> '' THEN
  207.   BEGIN
  208.     Assign(Dest, FileName);   {open file for write}
  209.     Rewrite(Dest);
  210.     writeln;
  211.     write('Incoming File Ready (Y/N)? ');   {wait for cue}
  212.     readln(Response);
  213.     IF UpCase(Response) = 'Y' THEN
  214.       BEGIN
  215.         GetHeader;
  216.         writeln;
  217.         Str(Remaining:5,RemBlks);    {turn Remaining into a string}
  218.         writeln('Blocks to be transferred: ', RemBlks);  {print it}
  219.         writeln;
  220.         PrintOn:= PrintEnable;         {send copy to screen if desired}
  221.         WHILE Remaining > 0 DO
  222.          BEGIN                    {Remaining is # of blocks to be read}
  223.             InBlock;
  224.             BlockWrite(Dest,Buffer,1);    {save complete record to disk}
  225.             Remaining:= pred(Remaining);
  226.          END;  {while Remaining}
  227.        close(Dest);
  228.        writeln;
  229.        writeln; writeln('File ',FileName,' written to disk.');
  230.      END;  {if Response}
  231.    END  {if FileName <> ''}
  232.     ELSE writeln('Aborting RECEIVE procedure.');
  233. END;  {ReceiveFile}
  234.  
  235. PROCEDURE SendHeader;
  236. BEGIN
  237.   NewChar:= SOH;
  238.   OutChar(NewChar);          {Send Start-Of-Header char.}
  239.   REPEAT
  240.     InChar(NewChar);
  241.   UNTIL KeyPressed OR (NewChar = SOH);    {wait for echo}
  242.   NewChar:= Lo(Remaining);
  243.   OutChar(NewChar);          {Send low-order byte of Remaining}
  244.   REPEAT
  245.     InChar(NewChar);
  246.   UNTIL KeyPressed OR (NewChar = Lo(Remaining));  {wait for confirm.}
  247.   NewChar:= Hi(Remaining);
  248.   OutChar(NewChar);          {High-order byte to serial port}
  249.   REPEAT
  250.     InChar(newChar);
  251.   UNTIL KeyPressed OR (NewChar = Hi(Remaining));  {wait for confirm.}
  252. END;  {SendHeader}
  253.  
  254. PROCEDURE OutBlock;                {Send a block to serial port}
  255. BEGIN
  256.   Bytecount:= 1;
  257.   WHILE Bytecount <= RecSize DO
  258.       BEGIN
  259.         NewChar:= Buffer[Bytecount];
  260.         OutChar(NewChar);
  261.         IF PrintOn THEN
  262.            BEGIN
  263.              IF ((Remaining = 1) AND (NewChar = 26)) THEN
  264.                PrintOn:= false
  265.                ELSE
  266.                  write(Char(NewChar));
  267.            END;
  268.         InChar(NewChar);
  269.         Bytecount:= succ(Bytecount);
  270.       END;
  271. END; {OutBlock}
  272.  
  273. PROCEDURE SendFile;    {get an MS-DOS file and transfer it}
  274. BEGIN
  275.   writeln;
  276.   REPEAT
  277.     writeln;
  278.     write('Transfer from file name: ');
  279.     readln(FileName);
  280.     assign(Source, FileName);
  281.         {$I-} reset(Source) {$I+};
  282.           OK:= (IOresult=0);
  283.           IF NOT OK THEN
  284.               writeln('Cannot find file ',FileName);
  285.   UNTIL (OK = true) OR (FileName = '');
  286.   IF OK THEN
  287.     BEGIN
  288.       Remaining:= FileSize(Source);
  289.       writeln; writeln('File ',FileName,' contains ',Remaining,' records.');
  290.       writeln;
  291.       SendHeader;
  292.       PrintOn:= PrintEnable;
  293.       WHILE Remaining > 0 DO    {send 1 block at a time until done}
  294.             BEGIN
  295.               BlockRead(Source, Buffer, 1);
  296.               OutBlock;
  297.               Remaining:=pred(Remaining);
  298.             END;
  299.       writeln;
  300.       writeln; writeln('File ',FileName,' transferred.');
  301.       close(Source);
  302.     END  {if}
  303.       ELSE
  304.         writeln('Aborting SEND procedure.');
  305. END; {SendFile}
  306.  
  307. BEGIN  {Transfer}            {main program begins here}
  308.   LogOn;
  309.   Baud:=1200;        {set up default parameters -- 1200 Baud, Receive Mode}
  310.   BaudByte:=BaudCode1200;
  311.   Mode:= receive;
  312.   REPEAT
  313.     SetUpIo;
  314.       REPEAT
  315.         writeln('If this is a TEXT file, would you like the file');
  316.         write('displayed on the screen? ');
  317.         readln(Response);
  318.         IF UpCase(Response) = 'N' THEN
  319.         PrintEnable:= false           {disable/enable screen output}
  320.           ELSE
  321.             PrintEnable:= true;
  322.        IF Mode = send THEN
  323.           SendFile
  324.            ELSE ReceiveFile;
  325.         writeln;
  326.         write('Transfer another file (Y/N)? ');
  327.         readln(Response);
  328.       UNTIL UpCase(Response) = 'N';
  329.       write('Change Parameters, (<N> to exit)? ');
  330.       readln(Response);
  331.   UNTIL UpCase(Response) = 'N';
  332.   writeln;writeln('TRANSFER program done.');
  333. END. {Transfer}
  334. σσσσσσσσσσσσσσσσσσσσ