Programmer 7500/MAX_PROGRAMMERS.iso/INFO/TURBOPAS/TPINST1.ZIP/TPINST1.PAS

Pascal/Delphi Source File | 1985-12-28 | 4.7 KB | 213 lines

program turbo_install;

{TINSTALL.PAS
 Turbo Pascal Ver. 2.0
 PC-DOS Version
 Copyright 1985 by David W. Carroll
 All commercial rights reserved.
 Date: 6-22-85
 Version 5

 As published in Micro/Systems Journal 1-4
                 September/October, 1985

 This program will change the start-up display
 mode of pre-compiled Turbo Pascal 2.0 and 3.0
 PC/MS-DOS '.COM' programs.

 This program and 300+ other Turbo Pascal programs
 are available on the High Sierra RBBS-PC at
 209/296-3534 - 300/1200 - 24 hours
}

const
  ASCII_offset = $30;
  logo_byte1 = $07;
  type_byte1 = $55;
  mode_byte  = $6D;
  type_data  : array[0..5,1..21] of char =
             (#$14'Default display mode',
             #$12'Monochrome display'#000#000,
             #$13'Color display 80x25'#000,
             #$13'Color display 40x25'#000,
             #$13'b/w   display 80x25'#000,
             #$13'b/w   display 40x25'#000);
  mode_data  : array[0..5] of byte =
             ($FF,$07,$03,$01,$02,$00);
  logo       : array[1..30] of char =
             'Copyright (C) 198X BORLAND Inc';

type
  fil      = file of byte;
  datstr   = string[20];

var
  infile              : fil;
  display_type, prog  : byte;
  quit, bad_logo      : boolean;

procedure uppercase (var Str : datstr);
var
  indx, len   : byte;

begin
  len := length(str);
  for indx := 1 to len do
    str[indx] := UpCase(str[indx])
end;   {procedure  uppercase}


procedure title;
begin
  ClrScr;
  Writeln('Turbo Pascal Install Program');
  Writeln('Copyright 1985 by David W. Carroll');
  Writeln;
  Writeln('Display Installation for Compiled Turbo Pascal Programs');
  Writeln;
  Delay(3000);
  writeln;
  writeln;
end;   {procedure title}

procedure open_file;
var
  goodfile : boolean;
  infname  : string[20];

begin
  window(1,6,80,25);    {PC-DOS}
  repeat
    ClrScr;             {PC-DOS}
    write ('Program filename  -->  ');
    readln (infname);
    writeln;
    uppercase(infname);
    if (pos('.COM',infname)=0) then
    begin
      goodfile := false;
      writeln('Must be .COM filetype!'^G);
      delay(3000);
    end
    else
    begin
      assign(infile,infname);
      {$I-} reset(infile) {$I+};
      goodfile := (IOresult = 0);
      if not goodfile then
      begin
        writeln (^G'FILE ',infname,' NOT FOUND');
        delay(3000)
      end;
    end;
  until goodfile;
end;   {procedure open_file}

procedure logo_test;
var
  indx : byte;
  test_byte : byte;

begin
  bad_logo := false;
  seek(infile,logo_byte1);
  for indx := 1 to 30 do
  begin
    read(infile,test_byte);
    if indx <> 18 then          {ignore units digit of year in logo}
      if (chr(test_byte) <> logo[indx]) then bad_logo := true;
  end;
end;   {procedure logo_test}

procedure type_test;

var
  indx,dat    : byte;
  display_str : string[20];

begin
  seek(infile,type_byte1);
  for indx := 0 to 20 do
  begin
    read(infile,dat);
    display_str[indx] := chr(dat);
  end;
  writeln;
  write('Installed display type = ');
  writeln(display_str);
  writeln;
end;   {procedure type_test}

procedure select_display;
var
  display_indx, char_indx : byte;
  ans : char;

begin
  writeln;
  window(1,8,80,25);  {PC-DOS}
  ans := ' ';
  ClrScr;             {PC-DOS}
  type_test;
  Writeln('Choose one of the following displays:');
  Writeln;
  for display_indx := 0 to 5 do
  begin
    write('  ',display_indx:2,'.  ');
    for char_indx := 2 to 21 do
      write(type_data[display_indx,char_indx]);
    writeln;
  end;
  writeln;
  Write('Which display? (Enter no. or ^Q to exit):');
  while not (UpCase(ans) in ['0'..'5',^Q,'Q']) do
    Read(kbd,ans);
  writeln;
  writeln;
  if (UpCase(ans) in ['Q',^Q]) then
    quit := true
  else
    display_type := ord(ans) - ASCII_offset;
end;   {procedure select_display}

procedure write_data;
var
  char_indx, data_byte : byte;

begin
  seek(infile,type_byte1);
  for char_indx := 1 to 21 do
  begin
    data_byte := ord(type_data[display_type,char_indx]);
    write(infile,data_byte);
  end;
  seek(infile,mode_byte);
  write(infile,mode_data[display_type]);
  flush(infile);
  close(infile);
  writeln('Installation completed.');
end;   {procedure write_data}

procedure exit1;
begin
  close(infile);
  writeln;
  if quit then
    writeln('Program aborted.'^G)
  else
    writeln('Bad logo - not a Turbo Pascal compiled program'^G^G^G);
end;     {procedure exit1}

begin  {main module TINSTALL}
  quit := false;
  title;
  open_file;
  logo_test;
  if not bad_logo then select_display;

  if (not bad_logo) and (not quit) then
    write_data
  else
    exit1;
end.   {main module TINSTALL}