home *** CD-ROM | disk | FTP | other *** search
/ RBBS in a Box Volume 1 #3.1 / RBBSIABOX31.cdr / trac / tpinst1.pas < prev    next >
Pascal/Delphi Source File  |  1985-11-17  |  5KB  |  216 lines
  1.      
  2. program turbo_install;
  3.  
  4. {TINSTALL.PAS
  5.  Turbo Pascal Ver. 2.0
  6.  PC-DOS Version
  7.  Copyright 1985 by David W. Carroll
  8.  All commercial rights reserved.
  9.  Date: 6-22-85
  10.  Version 5
  11.  
  12.  As published in Micro/Systems Journal 1-4
  13.                  September/October, 1985
  14.  
  15.  This program will change the start-up display
  16.  mode of pre-compiled Turbo Pascal 2.0 and 3.0
  17.  PC/MS-DOS '.COM' programs.
  18.  
  19.  This program and 300+ other Turbo Pascal programs 
  20.  are available on the High Sierra RBBS-PC at
  21.  209/296-3534 - 300/1200 - 24 hours 
  22. }
  23.  
  24. const
  25.   ASCII_offset = $30;
  26.   logo_byte1 = $07;
  27.   type_byte1 = $55;
  28.   mode_byte  = $6D;
  29.   type_data  : array[0..5,1..21] of char =
  30.              (#$14'Default display mode',
  31.              #$12'Monochrome display'#000#000,
  32.              #$13'Color display 80x25'#000,
  33.              #$13'Color display 40x25'#000,
  34.              #$13'b/w   display 80x25'#000,
  35.              #$13'b/w   display 40x25'#000);
  36.   mode_data  : array[0..5] of byte =
  37.              ($FF,$07,$03,$01,$02,$00);
  38.   logo       : array[1..30] of char =
  39.              'Copyright (C) 198X BORLAND Inc';
  40.  
  41. type
  42.   fil      = file of byte;
  43.   datstr   = string[20];
  44.  
  45. var
  46.   infile              : fil;
  47.   display_type, prog  : byte;
  48.   quit, bad_logo      : boolean;
  49.  
  50. procedure uppercase (var Str : datstr);
  51. var
  52.   indx, len   : byte;
  53.  
  54. begin
  55.   len := length(str);
  56.   for indx := 1 to len do
  57.     str[indx] := UpCase(str[indx])
  58. end;   {procedure  uppercase}
  59.  
  60.  
  61. procedure title;
  62. begin
  63.   ClrScr;
  64.   Writeln('Turbo Pascal Install Program');
  65.   Writeln('Copyright 1985 by David W. Carroll');
  66.   Writeln;
  67.   Writeln('Display Installation for Compiled Turbo Pascal Programs');
  68.   Writeln;
  69.   Delay(3000);
  70.   writeln;
  71.   writeln;
  72. end;   {procedure title}
  73.  
  74. procedure open_file;
  75. var
  76.   goodfile : boolean;
  77.   infname  : string[20];
  78.  
  79. begin
  80.   window(1,6,80,25);    {PC-DOS}
  81.   repeat
  82.     ClrScr;             {PC-DOS}
  83.     write ('Program filename  -->  ');
  84.     readln (infname);
  85.     writeln;
  86.     uppercase(infname);
  87.     if (pos('.COM',infname)=0) then
  88.     begin
  89.       goodfile := false;
  90.       writeln('Must be .COM filetype!'^G);
  91.       delay(3000);
  92.     end
  93.     else
  94.     begin
  95.       assign(infile,infname);
  96.       {$I-} reset(infile) {$I+};
  97.       goodfile := (IOresult = 0);
  98.       if not goodfile then
  99.       begin
  100.         writeln (^G'FILE ',infname,' NOT FOUND');
  101.         delay(3000)
  102.       end;
  103.     end;
  104.   until goodfile;
  105. end;   {procedure open_file}
  106.  
  107. procedure logo_test;
  108. var
  109.   indx : byte;
  110.   test_byte : byte;
  111.  
  112. begin
  113.   bad_logo := false;
  114.   seek(infile,logo_byte1);
  115.   for indx := 1 to 30 do
  116.   begin
  117.     read(infile,test_byte);
  118.     if indx <> 18 then          {ignore units digit of year in logo}
  119.       if (chr(test_byte) <> logo[indx]) then bad_logo := true;
  120.   end;
  121. end;   {procedure logo_test}
  122.  
  123. procedure type_test;
  124.  
  125. var
  126.   indx,dat    : byte;
  127.   display_str : string[20];
  128.  
  129. begin
  130.   seek(infile,type_byte1);
  131.   for indx := 0 to 20 do
  132.   begin
  133.     read(infile,dat);
  134.     display_str[indx] := chr(dat);
  135.   end;
  136.   writeln;
  137.   write('Installed display type = ');
  138.   writeln(display_str);
  139.   writeln;
  140. end;   {procedure type_test}
  141.  
  142. procedure select_display;
  143. var
  144.   display_indx, char_indx : byte;
  145.   ans : char;
  146.  
  147. begin
  148.   writeln;
  149.   window(1,8,80,25);  {PC-DOS}
  150.   ans := ' ';
  151.   ClrScr;             {PC-DOS}
  152.   type_test;
  153.   Writeln('Choose one of the following displays:');
  154.   Writeln;
  155.   for display_indx := 0 to 5 do
  156.   begin
  157.     write('  ',display_indx:2,'.  ');
  158.     for char_indx := 2 to 21 do
  159.       write(type_data[display_indx,char_indx]);
  160.     writeln;
  161.   end;
  162.   writeln;
  163.   Write('Which display? (Enter no. or ^Q to exit):');
  164.   while not (UpCase(ans) in ['0'..'5',^Q,'Q']) do
  165.     Read(kbd,ans);
  166.   writeln;
  167.   writeln;
  168.   if (UpCase(ans) in ['Q',^Q]) then
  169.     quit := true
  170.   else
  171.     display_type := ord(ans) - ASCII_offset;
  172. end;   {procedure select_display}
  173.  
  174. procedure write_data;
  175. var
  176.   char_indx, data_byte : byte;
  177.  
  178. begin
  179.   seek(infile,type_byte1);
  180.   for char_indx := 1 to 21 do
  181.   begin
  182.     data_byte := ord(type_data[display_type,char_indx]);
  183.     write(infile,data_byte);
  184.   end;
  185.   seek(infile,mode_byte);
  186.   write(infile,mode_data[display_type]);
  187.   flush(infile);
  188.   close(infile);
  189.   writeln('Installation completed.');
  190. end;   {procedure write_data}
  191.  
  192. procedure exit1;
  193. begin
  194.   close(infile);
  195.   writeln;
  196.   if quit then
  197.     writeln('Program aborted.'^G)
  198.   else
  199.     writeln('Bad logo - not a Turbo Pascal compiled program'^G^G^G);
  200. end;     {procedure exit1}
  201.  
  202. begin  {main module TINSTALL}
  203.   quit := false;
  204.   title;
  205.   open_file;
  206.   logo_test;
  207.   if not bad_logo then select_display;
  208.  
  209.   if (not bad_logo) and (not quit) then
  210.     write_data
  211.   else
  212.     exit1;
  213. end.   {main module TINSTALL}
  214.  
  215.  
  216.