An IBM VM/CMS like LOGON screen for DOS

logon.pas

{$M $4000,0,0}
{$G+}
uses xstr,crt,dos;

const

  statusx = 64;

  log : array[1..9] of string[20] =
('     GGG  GGGG','  GGGGGG  G   GGG',' GGGGGGG  G      G',
 'GGGGGGGG  G','GGGGGGGG  G  GGGGGG','GGGGGGGG  G     GGG',
 ' GGGGGGG  G     GG','  GGGGGG  G    GG','     GGG  GGGGG');

procedure Beep;
begin
  sound(4000);delay(250);nosound;
end;

procedure Upper(var s:string);
var
  b:byte;
begin
  for b:=1 to length(s) do s[b] := upcase(s[b]);
end;

procedure local(enable:boolean);
begin
  if enable then window(1,1,80,22)
            else window(1,1,80,25);
end;

procedure NOSH(Flags, CS, IP, AX, BX, CX, DX, SI, DI, DS, ES, BP: Word);interrupt;
begin
  write(char(lo(ax)));
end;

procedure writemessage(s:string);
var
  ox,oy:byte;
begin
  ox := Wherex;
  oy := wherey;
  local(false);
  gotoxy(1,25);
  write(s);
  local(true);
  gotoxy(ox,oy);
end;

procedure cursoff;near;assembler;
asm
  mov ah,1
  mov ch,1
  mov cl,0
  int 10h
end;

procedure curson;near;assembler;
asm
  mov ah,1
  mov ch,14
  mov cl,15
  int 10h
end;

procedure JumpDos;
begin
  SetIntVec($29,@NOSH);
  curson;
  Keep(0);
end;

procedure getstring(var s:string);
var
  x,y:byte;
  c:char;
const
  curcar = '_';
  procedure xw(cx:char);near;
  begin
    gotoxy(x,y);
    write(cx);
  end;
begin
  s := '';
  x := wherex;
  y := wherey;
  xw(curcar);
  repeat
    c := readkey;
    case c of
      #13 : begin
              xw(#32);
              writeln;
              upper(s);
              exit;
            end;
      #8  : if s <> '' then begin
              xw(#32);
              dec(x);
              dec(byte(s[0]));
              xw(curcar);
            end;
      #27..#255 : if x < 80 then begin
                    xw(c);
                    inc(x);
                    inc(byte(s[0]));
                    s[length(s)] := c;
                    xw(curcar);
                  end;
    end; {case}
  until false;
end;

procedure status(s:string);
var
  ox,oy:byte;
begin
  ox := wherex;
  oy := wherey;
  local(false);
  gotoxy(statusx,23);
  write(s);
  local(true);
  gotoxy(ox,oy);
end;

procedure Wait;
begin
  writemessage('SYSTEM X');
  status('RUNNING');
end;

procedure Idle;
begin
  writemessage('                             ');
  status('VM READ');
end;

procedure prompt(msg:string;var s:string);
begin
  Idle;
  write(msg);
  getstring(s);
  Upper(s);
  Wait;
end;

procedure Init;
var
  b:byte;
  basey:byte;
  userid,password,command:string;
begin
  clrscr;
  cursoff;
  beep;
  gotoxy(1,24);
  write(duplicate('Ä',80));
  gotoxy(statusx,23);
  write('RUNNING TRGENVM1');
  gotoxy(1,1);
  writeln('VIRTUAL MACHINE/SSG EDITION');
  for b:=1 to 9 do begin
    gotoxy(30,b+2);
    writeln(log[b]);
  end;
  writeln;
  writeln;
  writeln;
  writeln(' Enter your userid and password');
  writeln(' (Your password will not appear when you type it)');
  writeln;
  writeln;
  basey := wherey;
  writeln(' USERID   ====>');
  writeln(' PASSWORD ====>');
  writeln;
  writeln(' COMMAND  ====>');
  gotoxy(17,basey);
  prompt('',userid);
  gotoxy(17,basey+1);
  prompt('',password);
  gotoxy(17,basey+3);
  prompt('',command);
  clrscr;
end;

begin
  Init;
  JumpDos;
end.