program mailuaf(input,output);

const
  nofile = '%MAILUAF-F-NOFILE, Cannot open mail file';
  nouser = '%MAILUAF-E-NOUSER, Username not found';
  nopriv = '%MAILUAF-E-NOPRIV, No priviledge for attempted operation';
  nomod = '%MAILUAF-E-NOMOD, No modification is requested';
  dupuser = '%MAILUAF-E-DUPUSER, Username already present';
  nouserspec = '%MAILUAF-E-NOUSERSPEC, No username specified';

type
  byte = -128..127;
  user_type = packed array [1..31] of char;
  string = varying [512] of char;
  mailuaf_rec = record case integer of
    1 : (s:string);
    2 : (r:record
      filler : [word] byte;
      username : user_type;
      flag, unused, new_count : [byte] byte;
      unknown : user_type;
      dir_len, mname_len, forward_len : [byte] byte;
      var_len_data : packed array [1..255] of char;
    end)
  end;
  p_string = packed array [1..80] of char;

var
  mailfile : file of string;
  muaf : mailuaf_rec;
  i,j : integer;
  stat : integer;
  open_flag, for_flag, stop_flag : boolean;
  command : p_string;
  prompt : packed array [1..9] of char;
  mail_commands : [external] integer;
  str$_match, rms$_eof, cli$_present, cli$_negated : [external,value] integer;

function lib$put_output(s1 : [class_s] packed array [l..h:integer] of char)
  : integer ; external;

function lib$get_input(s1 : [class_s] p_string;
  s2 : [class_s] packed array [l..h:integer] of char)
  : integer;external;

function lib$get_foreign(s1 : [class_s] p_string) : integer;external;

function lbr$output_help(%immed [unbound]
    function put_out(s:[class_s] packed array [l..h:integer] of char): integer;
  out_width : integer := %immed 0;
  s1 : [class_s] p_string;
  s2 : [class_s] packed array [l..h:integer] of char;
  flags : unsigned := %immed 0;
  %immed [unbound]
    function get_in(gs1 : [class_s] p_string;
      gs2 : [class_s] packed array [l..h:integer] of char) : integer)
  : integer;external;

function cli$dcl_parse(s1 : [class_s] p_string; itable:integer) : integer;
  external;

function cli$present(s1 : [class_s] packed array [l..h:integer] of char)
  : integer; external;

function cli$get_value(s1 : [class_s] packed array [l..h:integer] of char;
  s2 : [class_s] p_string) : integer; external;

function str$match_wild(s1,s2 : [class_s] user_type) : integer; external;

function cli$dispatch : integer; external;

procedure lib$stop(istat : [immediate] integer); external;

function Upcase(s : string) : string;
type
  ubyte = 0..255;

var
  temp : record case integer of
    1 : (s1:string);
    2 : (s2:record
      len : [word] ubyte;
      ch : packed array [1..254] of char;
    end)
  end;

begin
  temp.s1 := s;
  for i := 1 to temp.s2.len do begin
    if temp.s2.ch[i] in ['a'..'z']
            then temp.s2.ch[i] := chr(ord(temp.s2.ch[i]) - 32);
  end;
  Upcase := temp.s1;
end;

procedure Open_file;
begin
  open_flag := false;
  open(file_variable := mailfile,
       file_name := 'sys$system:vmsmail.dat',
       history := old,
       sharing := readwrite,
       access_method := keyed,
       error := continue);
  if status(mailfile) = 0 then begin
    resetk(mailfile,0);
    open_flag := true;
  end;
end;

procedure Get_mail_record(user:string; full,all : boolean);
var
  dir, mname, forward : string;
  uname : user_type;
  fflag, wild : boolean;
begin
  dir := '';
  mname := '';
  forward := '';
  readv(user,muaf.r.username);
  uname := muaf.r.username;
  if (index(user,'*') > 0) or (index(user,'%') > 0) then wild := true
  else wild := false;
  if all or wild then get(mailfile) else findk(mailfile,0,muaf.r.username,eql);
  muaf.s := mailfile^;
  fflag := false;
  if not(UFB(mailfile)) then repeat
    if all or (str$match_wild(muaf.r.username,uname) = str$_match) then begin
      fflag := true;
      writeln(output,muaf.r.username);
      if full then with muaf.r do begin
        if new_count > 0 then writeln(output,'  New mail count : ',new_count);
        if dir_len > 0 then begin
          dir := substr(var_len_data,forward_len+mname_len+1,dir_len);
          writeln(output,'  Directory : ',dir);
        end;
        if mname_len > 0 then begin
          mname := substr(var_len_data,forward_len+1,mname_len);
          writeln(output,'  Mail name : ',mname);
        end;
        if forward_len > 0 then begin
          forward := substr(var_len_data,1,forward_len);
          writeln(output,'  Forward to : ',forward);
        end;
      end;
    end;
    get(mailfile);
    muaf.s := mailfile^;
  until eof(mailfile) or (not(all) and not(wild));
  if not(fflag) then writeln(output,nouser);
end;

[global] procedure Add_routine;
const
  cli_name = 'UNAME';
  forward_name = 'FORWARD_NAME';
  mail_name = 'MAIL_NAME';
  dir_name = 'DIR_NAME';
var
  fname, dname, mname, name : p_string;
  f_name, d_name, m_name : varying [255] of char;
  user : string;
  l, rec_len : integer;
  temp : mailuaf_rec;

begin
  with temp.r do begin
    new_count := 0;
    unused := 0;
    flag := 0;
    for i := 1 to 31 do unknown[i] := chr(0);
    var_len_data := ' ';
  end;
  f_name := '';
  m_name := '';
  d_name := '';
  if cli$present(cli_name) = cli$_present then begin
    stat := cli$get_value(cli_name, name);
    user := substr(Upcase(name),1,index(name,' ')-1);
    readv(user,muaf.r.username);
    temp.r.username := muaf.r.username;
    findk(mailfile,0,muaf.r.username,eql);
    if UFB(mailfile) then begin
      if cli$present(forward_name) = cli$_present then begin
        stat := cli$get_value(forward_name, fname);
        l := index(fname,' ') - 1;
        f_name := pad(f_name,' ',l);
        for i := 1 to l do f_name[i] := fname[i];
        temp.r.forward_len := l;
      end
      else temp.r.forward_len := 0;
      if cli$present(mail_name) = cli$_present then begin
        stat := cli$get_value(mail_name, mname);
        l := index(mname,' ') - 1;
        m_name := pad(m_name,' ',l);
        for i := 1 to l do m_name[i] := mname[i];
        temp.r.mname_len := l;
      end
      else temp.r.mname_len := 0;
      if cli$present(dir_name) = cli$_present then begin
        stat := cli$get_value(dir_name, dname);
        l := index(dname,' ') - 1;
        d_name := pad(d_name,' ',l);
        for i := 1 to l do d_name[i] := dname[i];
        temp.r.dir_len := l;
      end
      else temp.r.dir_len := 0;
      muaf.s := '';
      writev(muaf.s,temp.r.username,chr(temp.r.flag),chr(temp.r.unused),
                    chr(temp.r.new_count),temp.r.unknown,chr(temp.r.dir_len),
                    chr(temp.r.mname_len),chr(temp.r.forward_len),
                    f_name,m_name,d_name);
      write(mailfile,muaf.s,error:=continue);
      if status(mailfile) <> 0 then writeln(output,nopriv);
    end
    else writeln(output,dupuser);
  end
  else writeln(output,nouserspec);
  writeln(output);
end;

[global] procedure Modify_routine;
const
  cli_name = 'UNAME';
  forward_name = 'FORWARD_NAME';
  mail_name = 'MAIL_NAME';
  dir_name = 'DIR_NAME';
var
  fname, dname, mname, name : p_string;
  f_name, d_name, m_name : varying [255] of char;
  user : string;
  l, cstat : integer;
  temp : mailuaf_rec;
  switch_flag : boolean;

begin
  f_name := '';
  m_name := '';
  d_name := '';
  if cli$present(cli_name) = cli$_present then begin
    stat := cli$get_value(cli_name, name);
    user := substr(Upcase(name),1,index(name,' ')-1);
    readv(user,muaf.r.username);
    temp.r.username := muaf.r.username;
    findk(mailfile,0,muaf.r.username,eql);
    if not(UFB(mailfile)) then begin
      temp.s := mailfile^;
      with temp.r do begin
        if forward_len > 0 then begin
          f_name := pad(f_name,' ',forward_len);
          for i := 1 to forward_len do f_name[i] := var_len_data[i];
        end;
        if mname_len > 0 then begin
          m_name := pad(m_name,' ',mname_len);
          for i := 1 to mname_len do m_name[i] := var_len_data[i+forward_len];
        end;
        if dir_len > 0 then begin
          d_name := pad(d_name,' ',dir_len);
          for i := 1 to dir_len
              do d_name[i] := var_len_data[i+forward_len+mname_len];
        end;
      end;
      switch_flag := false;
      cstat := cli$present(forward_name);
      if cstat = cli$_present then begin
        switch_flag := true;
        stat := cli$get_value(forward_name, fname);
        l := index(fname,' ') - 1;
        f_name := '';
        f_name := pad(f_name,' ',l);
        for i := 1 to l do f_name[i] := fname[i];
        temp.r.forward_len := l;
      end
      else if cstat = cli$_negated then begin
        switch_flag := true;
        temp.r.forward_len := 0;
        f_name := '';
      end;
      cstat := cli$present(mail_name);
      if cstat = cli$_present then begin
        switch_flag := true;
        stat := cli$get_value(mail_name, mname);
        l := 80;
        while (l>0) and (mname[l] = ' ') do l := pred(l);
        m_name := '';
        m_name := pad(m_name,' ',l);
        for i := 1 to l do m_name[i] := mname[i];
        temp.r.mname_len := l;
      end
      else if cstat = cli$_negated then begin
        switch_flag := true;
        temp.r.mname_len := 0;
        m_name := '';
      end;
      cstat := cli$present(dir_name);
      if cstat = cli$_present then begin
        switch_flag := true;
        stat := cli$get_value(dir_name, dname);
        l := index(dname,' ') - 1;
        d_name := '';
        d_name := pad(d_name,' ',l);
        for i := 1 to l do d_name[i] := dname[i];
        temp.r.dir_len := l;
      end
      else if cstat = cli$_negated then begin
        switch_flag := true;
        temp.r.dir_len := 0;
        d_name := '';
      end;
      if switch_flag then begin
        muaf.s := '';
        writev(muaf.s,temp.r.username,chr(temp.r.flag),chr(temp.r.unused),
                    chr(temp.r.new_count),temp.r.unknown,chr(temp.r.dir_len),
                    chr(temp.r.mname_len),chr(temp.r.forward_len),
                    f_name,m_name,d_name);
        mailfile^ := muaf.s;
        update(mailfile,error:=continue);
        if status(mailfile) <> 0 then writeln(output,nopriv);
      end
      else writeln(output,nomod);
    end
    else writeln(output,nouser);
  end
  else writeln(output,nouserspec);
  writeln(output);
end;

[global] procedure Exit_routine;
begin
  stop_flag := true;
end;

[global] procedure Reset_routine;
var
  cli_name : packed array [1..5] of char;
  name : p_string;
  user : string;
begin
  cli_name := 'UNAME';
  if (cli$present(cli_name) = cli$_present) then begin
    stat := cli$get_value(cli_name, name);
    user := substr(Upcase(name),1,index(name,' ')-1);
    readv(user,muaf.r.username);
    findk(mailfile,0,muaf.r.username,eql);
    if ufb(mailfile) then writeln(output,nouser)
    else begin
      muaf.s := mailfile^;
      muaf.r.new_count := 0;
      mailfile^ := muaf.s;
      update(mailfile,error:=continue);
      if status(mailfile) = 0 then writeln(output,user,' reset')
      else writeln(output,nopriv);
    end;
  end
  else writeln(output,nouserspec);
  writeln(output);
end;

[global] procedure Show_routine;
var
  name : p_string;
  cli_name : packed array [1..5] of char;
  all_qual : packed array [1..3] of char;
  full_qual : packed array [1..4] of char;
  user : string;
  all, full : boolean;

begin
  cli_name := 'UNAME';
  all_qual := 'ALL';
  full_qual := 'FULL';
  all := false;
  full := false;
  if cli$present(all_qual) = cli$_present then all := true;
  if cli$present(full_qual) = cli$_present then full := true;
  if not(all) and (cli$present(cli_name) = cli$_present) then begin
    stat := cli$get_value(cli_name, name);
    user := substr(Upcase(name),1,index(name,' ')-1);
    if user <> '' then Get_mail_record(user,full,all);
  end
  else if all then Get_mail_record(user,full,all)
  else writeln(output,nouserspec);
  writeln(output);
end;

[global] procedure Delete_routine;
var
  cli_name : packed array [1..5] of char;
  name, answer : p_string;
  user : string;
  confirm : packed array [1..44] of char;
  vstring : string;
begin
  cli_name := 'UNAME';
  if (cli$present(cli_name) = cli$_present) then begin
    stat := cli$get_value(cli_name, name);
    user := substr(Upcase(name),1,index(name,' ')-1);
    readv(user,muaf.r.username);
    findk(mailfile,0,muaf.r.username,eql);
    if ufb(mailfile) then writeln(output,nouser)
    else begin
      muaf.s := mailfile^;
      writev(vstring,'Delete ',muaf.r.username,'? <N> ');
      readv(vstring,confirm);
      stat := lib$get_input(answer,confirm);
      if answer[1] in ['y','Y'] then begin
        delete(mailfile,error:=continue);
        if status(mailfile) = 0 then writeln(output,user,' deleted')
        else writeln(output,nopriv);
      end;
    end;
  end
  else writeln(output,nouserspec);
  writeln(output);
end;

[global] procedure Help_routine;
const
  help_topic = 'HELP_TOPIC';
  help_lib = 'MAILUAF.HLB';
var
  help_key : p_string;
begin
  if cli$present(help_topic) = cli$_present then
                   stat := cli$get_value(help_topic,help_key)
  else help_key := ' ';
  stat := lbr$output_help(lib$put_output,,help_key,help_lib,,lib$get_input);
end;

begin
  stop_flag := false;
  Open_file;
  if open_flag then begin
    for_flag := false;
    prompt := 'MAILUAF> ';
    stat := lib$get_foreign(command);
    if command <> ' ' then begin
      for_flag := true;
      stop_flag := true;
    end;
    repeat
      stat := 1;
      if not(for_flag) then stat := lib$get_input(command,prompt);
      if stat = rms$_eof then stop_flag := true
      else begin
        if not(odd(stat)) then lib$stop(stat);
        stat := cli$dcl_parse(command,mail_commands);
        if odd(stat) then stat := cli$dispatch;
      end;
      resetk(mailfile,0);
    until stop_flag;
    close(mailfile);
  end
  else writeln(output,nofile);
end.