home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / tsr / tsrunit / demo.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1989-11-08  |  8.2 KB  |  222 lines
  1. PROGRAM TSRdemo;
  2.  
  3. {$M $0800,0,0}
  4.  
  5. USES crt,dos,tsr;
  6.  
  7. CONST DemoPgmName : string[16] = 'TSR Demo Program';
  8.  
  9. VAR
  10.    lst               :text;
  11.    textfile          :text;
  12.    InsStr            :string;
  13.  
  14. FUNCTION ioerror :boolean;
  15.  
  16. VAR      i:word;
  17. BEGIN
  18.      i:=ioresult;
  19.      ioerror:=false;
  20.      if i<>0 then begin
  21.         writeln('I/O Error No. ',i);
  22.         ioerror:=true;
  23.      end;
  24. end;
  25.  
  26. {$F+} FUNCTION DemoTasks : word; {$F-}
  27. const
  28.      filename : string[14] = ' :\TSRDemo.Dat';
  29.      endpos = 40;
  30.      wx1 = 15; wy1 = 2; wx2 = 65; wy2 = 23;
  31. VAR
  32.    key,drv             : char;
  33.    done,ioerr          : boolean;
  34.    inputpos,rownumb    : integer;
  35.    dosver              : word;
  36.    inputstring         : string;
  37.  
  38.    procedure clearline;
  39.    begin
  40.         inputstring:='';inputpos:=1;
  41.         gotoxy(1,whereY);clreol;
  42.    end;
  43.  
  44. begin
  45.      demotasks:=0;
  46.      window(wx1,wy1,wx2,wy2);
  47.      textcolor(black);
  48.      textbackground(lightgray);
  49.      lowvideo;
  50.      clrscr;
  51.      writeln;
  52.      writeln(' Example Terminate & Stay-Resident (TSR) program');
  53.      writeln(' --written with Turbo Pascal 5.5 and uses TSRUnit.');
  54.      window(wx1+1,wy1+4,wx2-1,wy1+12);
  55.      textcolor(lightgray);
  56.      textbackground(black);
  57.      clrscr;
  58.      writeln;
  59.      writeln('    Function Key Definitions:');
  60.      writeln('        [F1]  Write message to TSRDEMO.DAT');
  61.      writeln('        [F2]  Write message to printer.');
  62.      writeln('        [F3]  Read from saved screen.');
  63.      writeln('        [F8]  Exit and insert text.');
  64.      writeln('        [F10] Exit from TSR and keep it.');
  65.      write(  '        or simply echo your input.');
  66.  
  67.      window(wx1+1,wy1+14,wx2-1,wy2-1);
  68.      clrscr;
  69.      writeln('TSRUnit Version: ',hi(TSRVersion):8,'.',lo(tsrversion):2);
  70.      writeln('Video Mode, Page:',tsrmode:4,tsrpage:4);
  71.      writeln('Cursor Row, Col.:',tsrrow:4,tsrcolumn:4);
  72.  
  73.      dosver := dosversion;
  74.      writeln('DOS Version:     ',lo(dosver):8,'.',hi(dosver):2);
  75.  
  76.      inputstring :='';
  77.      inputpos    :=1;
  78.      done        :=false;
  79.  
  80.      REPEAT
  81.            gotoxy(inputpos,wherey);
  82.            key:=readkey;
  83.            if key=#0 then begin
  84.               key:=readkey;
  85.               case key of
  86.  
  87.               #71: inputpos:=1;
  88.               #75: if inputpos>1 then dec(inputpos);
  89.               #77: if (inputpos < length(inputstring))
  90.                       or ((inputpos = length(inputstring))
  91.                          and (inputpos<endpos)) then inc(inputpos);
  92.               #79: begin
  93.                          inputpos:=succ(length(inputstring));
  94.                          if inputpos>endpos then inputpos:=endpos;
  95.                      end;
  96.  
  97.               #83: begin
  98.                         delete(inputstring, inputpos, 1);
  99.                         write(copy(inputstring,inputpos,endpos), ' ');
  100.                     end;
  101.  
  102.               #59: begin
  103.                         clearline;
  104.                         repeat
  105.                               write('Enter disk drive:  ',filename[1]);
  106.                               drv:=upcase(readkey);writeln;
  107.                               if drv<>#13 then filename[1]:=drv;
  108.                               writeln('Specifying an invalid drive will cause your ');
  109.                               write('system to crash. Use drive ',filename[1],':? [y/N] ');
  110.                               key:=upcase(readkey);writeln(key);
  111.                         until key = 'Y';
  112.                         writeln('Writing to ',filename);
  113.                         {$I-}
  114.                         assign(textfile,filename);
  115.                         if not ioerror then begin
  116.                            rewrite(textfile);
  117.                            if not ioerror then begin
  118.                               writeln(textfile,'File was written by TSRDemo.');
  119.                            ioerr:=ioerror;
  120.                            close(textfile);
  121.                            ioerr:=ioerror;
  122.                         end;
  123.                     end;
  124.                     {$I+}
  125.                     writeln('Completed file operation.');
  126.                    end;
  127.  
  128.               #60: begin
  129.                         clearline;
  130.                         writeln('Check printer status, then print if okay.');
  131.                         if printerokay then begin
  132.                            assign(lst,'LPT1');
  133.                            rewrite(lst);
  134.                            writeln(lst,'Printing performed from TSRDemo');
  135.                            close(lst);
  136.                         end
  137.                         else writeln('Printer is not ready.');
  138.                         writeln('Completed print operation.');
  139.                     end;
  140.  
  141.               #61: begin
  142.                         clearline;
  143.                         case tsrmode of
  144.                              0..3,
  145.                              7:begin
  146.                                     {$I-}
  147.                                     repeat
  148.                                           writeln('Enter row number [1-25] from');
  149.                                           write('which to copy characters:  ');
  150.                                           readln(rownumb);
  151.                                     until not ioerror;
  152.                                     {$I+}
  153.                                     if rownumb<=0 then rownumb:=1;
  154.                                     if rownumb>25 then rownumb:=25;
  155.                                     writeln(screenlinestr(rownumb));
  156.                              end;
  157.                         else writeln('Not valid for graphics modes.');
  158.                         end;
  159.                     end;
  160.               #66: begin
  161.                         clearline;
  162.                         writeln('Enter characters to insert.');
  163.                         writeln('Up to 255 characters may be inserted.');
  164.                         writeln('Terminate input string by pressing [F8].');
  165.                         insstr:='';
  166.                         repeat
  167.                               key:=readkey;
  168.                               if key=#0 then begin
  169.                               key:=readkey;
  170.                               if key=#66 then done:=true;
  171.                           end
  172.                           else begin
  173.                                     if length(insstr)<pred(sizeof(insstr)) then
  174.                                     begin
  175.                                          if key=#13 then writeln
  176.                                          else write(key);
  177.                                          insstr:=insstr+key;
  178.                                     end
  179.                                     else done:=true
  180.                                 end;
  181.                           until done;
  182.                           demotasks:=length(insstr);
  183.                           tsrchrptr:=@Insstr[1];
  184.                       end;
  185.               #68: done:=true;
  186.  
  187.               end;
  188.            end
  189.            else begin
  190.                      case key of
  191.  
  192.                           #08: begin
  193.                                     if inputpos>1 then begin
  194.                                     dec(inputpos);
  195.                                     delete(inputstring,inputpos,1);
  196.                                     gotoxy(inputpos,wherey);
  197.                                     write(copy(inputstring,inputpos,endpos),' ');
  198.                                 end;
  199.                             end;
  200.                           #13: begin
  201.                                     writeln;
  202.                                     inputstring:='';
  203.                                     inputpos:=1;
  204.                                 end;
  205.                           #27: clearline
  206.                      else
  207.                          if length(inputstring)>=endpos then
  208.                          delete(inputstring,endpos,1);
  209.                          insert(key,inputstring,inputpos);
  210.                          write(copy(inputstring,inputpos,endpos));
  211.                          if inputpos<endpos then
  212.                          inc(inputpos);
  213.                          end;
  214.                      end;
  215.                      until done;
  216.            end;
  217.  
  218.            begin
  219.                 tsrinstall(demopgmname,demotasks,altkey,'E');
  220.            end.
  221.  
  222.