program iodemo(inp,output,infile,outfile);
type
    string15=packed array[1..15]of char;
    ptr63   =^string63;
    string63=packed array[0..63]of char;
    string31=packed array[1..31]of char;
var
    infile,outfile,inp:text;
procedure pprompt(s:string15);extern;
procedure pdefine(k:integer;p:ptr63);extern;

procedure define_files;
var filename:string31;length:integer;first_try,ok:boolean;

function get_name(prompt:string15;
                  var l:integer;
                  var name:string31;
                  write_to:boolean):boolean;
var ok:boolean;temp:integer;

function fnok(s:string31;write_to:boolean):boolean;
var i,dot,sub:integer;fail,ftype:packed array[0..4]of boolean;done:boolean;

function my_file(s:string31):boolean;
const
  userad=2359296;{str6}
type
  str6=packed array[0..6]of char;
     cheat=record
         dummyi:integer;
         case boolean of
            true:(addr:integer);
            false:(ptr:^str6)
         end;
  var peeker:cheat;me,owner:str6;i:integer;
  begin
     peeker.addr:=userad;
     me:=peeker.ptr^;
     owner[0]:=chr(6);
     for i:=1 to 6 do owner[i]:=s[i];
{     writeln('OWNER=',owner,'    ME=',me,'     result=',me=owner);            }
     my_file:=owner=me;
  end;


function alphabetical(ch:char):boolean;
begin
alphabetical:=((ord('A')<=ord(ch))and(ord(ch)<=ord('Z')));
end;

function alphanumeric(ch:char):boolean;
begin
alphanumeric:=((ord('0')<=ord(ch))and(ord(ch)<=ord('9')))or alphabetical(ch);
end;

begin
for i:=0 to 4 do begin ftype[i]:=false;fail[i]:=false; end;
dot:=0;sub:=0;
for i:=1 to 31 do if s[i]='.' then dot:=i;
for i:=31 downto 1 do if s[i]='_' then sub:=i;
fail[1]:=((dot<>0)and(dot<>7))or((sub<>0)and(dot+1>=sub));
if dot<>0 then if not fail[1] then for i:=1 to 6 do fail[1]:=fail[1] or not
                                        alphanumeric(s[i]);
ftype[1]:=not fail[1] and (dot<>0);
fail[0]:=fail[1];
if not fail[0] then begin
   i:=dot+1;fail[2]:=not alphabetical(s[i]);
   repeat
      i:=i+1;done:=(s[i]=' ')or(s[i]='_');
      fail[2]:=not (alphanumeric(s[i])or(s[i]='#')or done)or fail[2];
   until done or fail[2] or (i=dot+12);
   fail[2]:=fail[2] or not done;
end;
fail[0]:=fail[1] or fail[2];
if not fail[0] then begin
   ftype[3]:=sub<>0;
   if ftype[3] then begin
       i:=sub+1;
       fail[3]:=not alphabetical(s[i]);
{       repeat                                                                 }
{          done:=s[i]=' ';                                                     }
{          fail[3]:=NOT DONE AND(fail[3] or not (alphanumeric(s[i])));         }
{          i:=i+1;                                                             }
{       until done or fail[3] or (i=sub+12);                                   }
       while not (fail[3] or done or (i=sub+12))do begin
           i:=i+1;done:=s[i]=' ';
           fail[3]:=not done and not alphanumeric(s[i]);
       end;
       fail[3]:=fail[3] or not done;
    end;

end;
fail[0]:=fail[1] or fail[2] or fail[3];
if fail[0] then begin
    write('Invalid ');
    if fail[1] then write('username ') else
        if fail[2] then write('filename ') else
            if fail[3] then write('member name ');
    writeln(s);
end else begin
  if write_to then begin
      if ftype[1] and not my_file(s) then  begin
            writeln('Invalid access - you can''t write to another user''s file');
            fail[4]:=true;
       end else begin
           if ftype[3] then begin
    writeln('Invalid access - you can''t write to a partitioned file member ');
         fail[4]:=true;
            end;
       end;
    end;
end;
fnok:=not(fail[1] or fail[2] or fail[3] or fail[4]);
end;

begin
if first_try then begin pprompt(prompt);reset(inp);first_try:=false;end
             else begin pprompt(prompt);
end;
while inp^=' ' do get(inp);
for l:=1 to 31 do name[l]:=' ';
l:=1;
while (inp^<>' ') and not(eoln(inp)) and (l<31) do begin
      name[l]:=inp^;get(inp);l:=l+1;end;
for l:=l downto 1 do 
      if ('a'<=name[l])and(name[l]<='z')then 
           name[l]:=chr(ord(name[l])-ord('a')+ord('A'));
l:=31;while (name[l]=' ') and (l>0) do l:=l-1;
ok:=(l>0)and(inp^=' ');
if not ok and (l>0) then writeln('Invalid filename ',name);
if not ok then while (inp^<>' ') and not(eof(inp)) do get(inp);
get_name:=ok and fnok(name,write_to);
end;{of get_name}

procedure call_pdefine(pas_len:integer;pas_file:string15;
                       emas_len:integer;emas_file:string31);
const magic=402653312;
var p63:ptr63;i,j:integer;param:string63;
begin
for i:=0 to 63 do param[i]:=' ';
for i:=1 to pas_len do param[i]:=pas_file[i];
param[i]:=',';j:=i;
for i:=1 to emas_len do param[i+j]:=emas_file[i];
{writeln('Command:pdefine',param);}
{writeln('len=',i+j-1:1);}
param[0]:=chr(i+j-1);
new(p63);
p63^:=param;
pdefine(magic,p63);
dispose(p63);
end;{of call_define}

begin {define_files}
first_try:=true;
writeln('Please give the name of the input file to be used:');
call_pdefine(3,'INP............',3,'.IN............................');
repeat; ok:=get_name('Input file:    ',length,filename,false);until ok;
call_pdefine(6,'INFILE.........',length,filename);
writeln('Please give the name of the output file to be used:');
repeat; ok:=get_name('Output file:   ',length,filename,true);until ok;
call_pdefine(7,'OUTFILE........',length,filename);
end;{ of define_files}

begin {main program}
writeln('This demonstration program shows how to avoid that "Data:" prompt');
writeln('that appears when you run a program. I askes for the names of two');
writeln('files and copies the input file to the output file               ');
writeln('File names must be no more than 31 characters long');
writeln;
define_files;
reset(infile);
rewrite(outfile);
while not eof(infile) do begin
   while not eoln(infile)do begin
      outfile^:=infile^;get(infile);put(outfile);
   end;
   writeln(outfile);
   if not eof(infile) then get(infile);
end;
end.