home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / UTILITY / SYSTEM / IPCA12A.ZIP / IPCA.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1991-10-10  |  6.0 KB  |  202 lines
  1. {$A-,B-,D-,E-,F-,I-,L-,N-,O-,R-,S-,V-}
  2. {$M 8192,0,0}
  3.  
  4. program ipca;
  5.  
  6. (***********************************************************************
  7.  NOTICE
  8.  ======
  9.      This program and every file distributed with it are copyright (C)
  10.  by the authors, who retain authorship both of the pre-compiled and 
  11.  compiled codes.  Their use and distribution are unrestricted, as long
  12.  as nobody gets any richer in the process.  Although these programs 
  13.  were developed to the best of the authors abilities, no guarantees
  14.  can be given as to their performance.  By using them, the user
  15.  accepts all risks and the authors decline all liability.
  16. ************************************************************************)
  17.  
  18. uses crt;
  19.  
  20. type
  21.   arrbyte = array [1..16] of byte;
  22.  
  23. var
  24.   ipcarr : arrbyte absolute $0000:$04F0;
  25.   str1, str2, str3 : string;
  26.  
  27. procedure wrtln(s: string);
  28. begin
  29.   writeln(s);
  30. end;
  31.  
  32. procedure error(e: byte);
  33. var
  34.   ch : char;
  35. begin
  36.   clrscr;
  37.   wrtln('╔═════════════════════════════════════════════════════════════════════════════╗');
  38.   wrtln('║ Program IPCA.EXE v.1.2a   April 19 1991.    Copyright (c) by José Campione. ║');
  39.   wrtln('║ The Inter Process Communication Area (IPCA) consists of 16 bytes at address ║');
  40.   wrtln('║ 0000h:04F0h to 0000h:04FFh. This program allows direct access of this area  ║');
  41.   wrtln('║ to keep strings or byte values. These can be stored and retrieved accross   ║');
  42.   wrtln('║ program, shell and subdirectory boundaries. In a way the IPCA is turned into║');
  43.   wrtln('║ a mini master environment and this program acts as a mini-SET utility...    ║');
  44.   wrtln('║ COMMAND LINES:                                                              ║');
  45.   wrtln('║ ipca 0 .......... clears the IPCA.                                          ║');
  46.   wrtln('║ ipca w .......... displays IPCA content.                                    ║');
  47.   wrtln('║ ipca e qwerty ... enters string "qwerty" starting in position 1.            ║');
  48.   wrtln('║ ipca a asdfgh ... adds "asdfgh" starting with the first available space.    ║');
  49.   wrtln('║ ipca c zxcvbn ... tests for string "zxcvbn"; if found, EL=0, if not EL=1.   ║');
  50.   wrtln('║ ipca r zxcvbn ... same as above but will display "yes!" or "no!".           ║');
  51.   wrtln('║ ipca s 10 234 ... sets byte 10 in the ipca to the value 234.                ║');
  52.   wrtln('║ ipca t 10 234 ... tests if byte 10 has value 234; if yes, EL=0, if not EL=1.║');
  53.   wrtln('║ ipca u 10 234 ... same as above but will display "yes!" or "no!".           ║');
  54.   wrtln('║ ipca b 10 ....... returns value of byte 10 in errorlevel.                   ║');
  55.   wrtln('╚═════════════════════════════════════════════════════════════════════════════╝');
  56.   if e in [1..8] then begin
  57.     inc(textattr,128);
  58.     write('>>> Error ');
  59.     dec(textattr,128);
  60.   end;
  61.   case e of
  62.     1: wrtln('1. Two parameters required in command line.');
  63.     2: wrtln('2. 1st parameter longer than one character.');
  64.     3: wrtln('3. 2nd parameter longer than 15 characters.');
  65.     4: wrtln('4. 1st parameter not in "ABCERSTUW"');
  66.     5: wrtln('5. 2nd parameter too long to fit in IPCA.');
  67.     6: wrtln('6. 2nd parameter must be in [1..16].');
  68.     7: wrtln('7. 3rd parameter is not in [0..255].');
  69.   end;
  70.   wrtln('');
  71.   write('>>> Press any key to continue... ');
  72.   repeat until keypressed;
  73.   while keypressed do ch:= readkey;
  74.   wrtln('');
  75.   halt(255);
  76. end;
  77.  
  78. procedure enterarr(stri: string);
  79. var
  80.   i : byte;
  81. begin
  82.   fillchar(ipcarr,sizeof(ipcarr),0);
  83.   for i:= 1 to ord(stri[0]) + 1 do begin
  84.     ipcarr[i]:= ord(stri[i-1]);
  85.   end;
  86.   halt(0);
  87. end;
  88.  
  89. procedure setbyte(str1, str2: string);
  90. var
  91.   i,v : integer;
  92.   c : integer;
  93. begin
  94.   val(str1,i,c);
  95.   if (c <> 0) or (i < 1) or (i > 16) then error(6);
  96.   val(str2,v,c);
  97.   if (c <> 0) or (v < 0) or (v > 255) then error(7);
  98.   ipcarr[i]:= v;
  99.   halt(0);
  100. end;
  101.  
  102. procedure retbyte(str1: string);
  103. var
  104.   i : integer;
  105.   c : integer;
  106. begin
  107.   val(str1,i,c);
  108.   if (c <> 0) or (i < 1) or (i > 16) then error(6);
  109.   halt(ipcarr[i]);
  110. end;
  111.  
  112. procedure testbyte(str1, str2: string; flag: boolean);
  113. var
  114.   i,v : byte;
  115.   c : integer;
  116. begin
  117.   val(str1,i,c);
  118.   if (c <> 0) or (i < 1) or (i > 16) then error(6);
  119.   val(str2,v,c);
  120.   if (c <> 0) or (v < 0) or (v > 255) then error(7);
  121.   if ipcarr[i] = v then begin
  122.     if flag then wrtln('yes!');
  123.     halt(0);
  124.   end else begin
  125.     if flag then wrtln('no!');
  126.     halt(1);
  127.   end;
  128. end;
  129.  
  130. procedure addarr(stri: string);
  131. var
  132.   i : byte;
  133. begin
  134.   if ipcarr[1] + ord(stri[0]) > 15 then error(5);
  135.   for i:= 1 to ord(stri[0]) do begin
  136.     ipcarr[i + ipcarr[1] + 1]:= ord(stri[i]);
  137.   end;
  138.   ipcarr[1]:= ipcarr[1] + ord(stri[0]);
  139.   halt(0);
  140. end;
  141.  
  142. procedure comparr(stri: string; flag: boolean);
  143. var
  144.   i : byte;
  145.   stry : string;
  146. begin
  147.   for i:= 1 to ipcarr[1] do begin
  148.     stry[i]:= char(ipcarr[i + 1]);
  149.   end;
  150.   stry[0]:= char(ipcarr[1]);
  151.   if pos(stri,stry) > 0 then begin
  152.   if flag then wrtln('yes!');
  153.     halt(0);
  154.   end else begin
  155.   if flag then wrtln('no!');
  156.     halt(1);
  157.   end;
  158. end;
  159.  
  160. procedure writearr;
  161. var
  162.   i : byte;
  163. begin
  164.   for i:= 1 to 16 do begin
  165.     case ipcarr[i] of
  166.       0 : write('_');
  167.       7 : write('.');
  168.       else write(char(ipcarr[i]));
  169.     end;
  170.   end;
  171.   writeln('[',ipcarr[1],']');
  172. end;
  173.  
  174. begin
  175.   str1:= paramstr(1);
  176.   if (ord(str1[0]) = 1) and (upcase(str1[1]) = 'W') then begin
  177.     writearr;
  178.     halt(0);
  179.   end;
  180.   if (ord(str1[0]) = 1) and (str1[1] = '0') then begin
  181.     fillchar(ipcarr,sizeof(ipcarr),0);
  182.     halt(0);
  183.   end;
  184.   if str1 = '' then error(0);
  185.   if paramcount < 2 then error(1);
  186.   str1:= paramstr(1);
  187.   if ord(str1[0]) <> 1 then error(2);
  188.   str2:= paramstr(2);
  189.   if ord(str2[0]) > 15 then error(3);
  190.   str3:= paramstr(3);
  191.     case upcase(str1[1]) of
  192.     'A' : addarr(str2);
  193.     'B' : retbyte(str2);
  194.     'E' : enterarr(str2);
  195.     'C' : comparr(str2,false);
  196.     'R' : comparr(str2,true);
  197.     'S' : setbyte(str2,str3);
  198.     'T' : testbyte(str2,str3,false);
  199.     'U' : testbyte(str2,str3,true);
  200.     else error(4);
  201.   end;
  202. end.