program conference (output);

(* --------------------------------------------------------------

              ----  C O N F E R E N C E  ----

   --------------------------------------------------------------

   CONFERENCE is the DCL interface to the multi-terminal talk program.
   It runs as an installed image under VMS. It should be installed 
   with the following privileges: 

       BYPASS   ,  CMRKNL   ,  EXQUOTA   , GROUP   , GRPNAM   ,
       OPER     ,  PRMMBX   ,  SYSNAM    , WORLD   , DETACH

   CONFERENCE does not need the above privliges however the created
   process to run the conference does. That conference must be under
   the following file SYS$SYSMGR:CONFEREXE. A detached process is 
   created for each conference. It is given the name _CONFXXXXXXX where
   XXXXXX is the entered name for the conference. A mailbox is also 
   created with the name CONF_XXXXXXX and CONFEREXE reads that mailbox 
   at startup to get the host member's process name. 

   ------------------------------------------------------------------- *)
const 
    esc             =  27 ;

    dt$_vt52        =  64 ;    dt$_vt100      =   96 ;

    io$_sensemode  =   39 ;    io$_writelblk  =   32 ;
    io$m_now        =  64 ;

    jpi$_pid        = 793 ;    jpi$_prcnam    =  796 ;
    jpi$_username   = 514 ;    jpi$_terminal  =  797 ;
    jpi$_prib       = 777 ;    jpi$_uic       =  772 ;

    pql$_astlm      =   1 ;    pql$_biolm     =    2 ;
    pql$_diolm      =   5 ;    pql$_fillm     =    6 ;
    pql$_listend    =   0 ;

    ss$_normal      =   1 ;    ss$_nopriv     =   36 ;
    ss$_suspended   = 932 ;    ss$_nomoreproc = 2472 ;

    string_size     =   80 ;    prompt_size    =   20 ;
    max_members     =   10 ;    max_name_size  =    7 ;

    join_prompt    = ' (                  ';
    join_prompt_1  = ' ) wants to join the';
    join_prompt_2  = ' conference.     ';
    main_prompt    = 'Conference>         ';
    name_prompt    = '_conference name>   ';
    talker_image   = 'SYS$SYSMGR:CONFEREXE';
    talker_error   = 'NL:                 ';
    talker_output  = 'NL:                 ';
    talker_prcnam  = '_CONF               ';
    mail_box_name  = 'CONF_               ';
(* *)
type 

    iosb_type      = array [1..2] of integer ;
    alpha8         = packed array [1..8]           of char ;
    prompt_type    = packed array [1..prompt_size] of char ;
    line_buffer    = array [1..string_size] of char ;
    line_pointer   = ^line_buffer ;

    string         = record 
       length      : integer ;
       buffer      : ^line_buffer 
       end;

    pid_type       = record 
      length       : integer ;
      jpi_val      : ^integer
      end;
 
    quota_list     = packed array [1..10] of packed record 
       pql_com     : 0..255 ;
       pql_val     : integer
       end;

    jpi_list       = record 
       prcname     : string ; prcname_len : ^integer ;
       usrname     : string ; usrname_len : ^integer ;
       terminal    : string ; term_length : ^integer ;
       pid         : pid_type ; pid_len  : ^integer ;
       uic         : pid_type ; uic_len  : ^integer ;
       prib        : pid_type ; prib_len : ^integer ;
       terminator  : integer
       end;

var 
     jpi          : jpi_list      ;     (* jpi for process information *)
     my_pid       : integer       ;     (* my own pid                  *)
     my_uic       : integer       ;     (* my own uic                  *)
     my_prib      : integer       ;     (* my base priority            *)
     my_name      : string        ;     (* name of my process          *)
     my_usrname   : string        ;     (* my user name                *)
     terminator   : set of char   ;     (* string terminator for parse *)
     cmd          : string        ;     (* command input string        *)
     charcount    : integer       ;     (* position in cmd for parse   *)
     prompt       : string        ;     (* global prompt string        *)
     command      : string        ;     (* global command string       *)
     cre_input    : string        ;     (* create process input file   *)
     cre_output   : string        ;     (* create process output file  *)
     cre_error    : string        ;     (* create process error file   *)
     mail_box     : string        ;     (* mail box name for create    *)
     mail_box_chan: integer       ;     (* channel for mail box        *)
     mail_box_iosb: iosb_type     ;     (* status block for mail box   *)
(* *)
procedure lib$get_input  (var getstr : string    ;
                     var      prompt  : string    ;
                     var      inlen   : integer   ); extern ;

procedure lib$get_foreign (var getstr : string    ;
                     var      prompt  : string    ;
                     var      inlen   : integer   ); extern ;

procedure lib$stop  (%immed   condit  : integer   ); extern ;

function sys$assign (var      devname : string    ;
                     var      channel : integer   ;
                     %immed   acmode  : integer   ;
                     %immed   mbxnam  : integer   ): integer ; extern ;

function sys$crembx (%immed   prmflg  : integer   ;
                     var      channel : integer   ;
                     %immed   maxmsg  : integer   ;
                     %immed   bufquo  : integer   ;
                     %immed   promsk  : integer   ;
                     %immed   acmode  : integer   ;
                     var      lognam  : string    ): integer ; extern ;

function sys$creprc (var      pidadr  : integer   ;
                     var      image   : string    ;
                     var      input   : string    ;
                     var      output  : string    ;
                     var      error   : string    ;
                     %immed   prvadr  : integer   ;
                     var      quota   : quota_list;
                     var      prcnam  : string    ;
                     %immed   baspri  : integer   ;
                     %immed   uic     : integer   ;
                     %immed   mbxunt  : integer   ;
                     %immed   stsflg  : integer   ): integer ; extern ;

function sys$dassgn (%immed   channel : integer   ): integer ; extern ;

function sys$delmbx (%immed   channel : integer   ): integer ; extern ;

function sys$getjpi (%immed   efn     : integer   ;
                     var      pidadr  : integer   ;
                     %immed   prcnam  : integer   ;
                     var      itmlst  : jpi_list  ;
                     %immed   iosb    : integer   ;
                     %immed   procabc : integer   ;(* no ast for wait info *)
                              astprm  : integer   ): integer ; extern ;

function sys$qiow   (%immed   efn     : integer   ;
                     %immed   channel : integer   ;
                     %immed   func    : integer   ;
                     var      iosb    : iosb_type ;
                     %immed   procabc : integer   ;(* no ast for wait io*)
                              astprm  : integer   ;
                     var      bufadr  : char      ;
                     %immed   bufsiz  : integer   ;
                     %immed   p3,p4   : integer   ;
                     %immed   p5      : line_pointer;
                     %immed   p6      : integer   ): integer ; extern ;

function sys$trnlog (var      lognam  : string    ;
                     var      rsllen  : integer   ;
                     var      rslbuf  : string    ;
                     var      table   : integer   ;
                     var      acmode  : integer   ;
                     %immed   dsbmsk  : integer   ): integer ; extern ;

function sys$waitfr (%immed   efn     : integer   ): integer ; extern ;

function translate (s1:string; var s2:string): integer ; 
var status , i , table , rslen , acmode : integer ;
begin 
  repeat 
    s2.length := string_size;
    status := sys$trnlog (s1 , rslen , s2 , table , acmode , 0);
    s2.length := rslen ;
    if (s2.buffer^[1]=chr(esc)) and (s2.buffer^[2]=chr(0)) then begin
      for i := 5 to s2.length do 
         s2.buffer^[i-4] := s2.buffer^[i];
      s2.length := s2.length - 4;
      end;
    s1.length := s2.length ;
    for i := 1 to s1.length do 
      s1.buffer^[i] := s2.buffer^[i];
    until (status <> ss$_normal);
  translate := status;
  end;
(* *)
function upper (ch:char) : char ; 
begin 
  if (ch >= 'a') and (ch <= 'z') then 
    upper := chr (ord(ch)+ord('A')-ord('a'))
  else 
    upper := ch ;
  end;

procedure clr_string (var str:string);
var i : integer ;
begin 
  str.length := 0;
  for i := 1 to string_size do str.buffer^[i] := ' ';
  end;

procedure new_string (var str:string);
begin 
  new (str.buffer);
  clr_string (str);
  end;

procedure clr_jpi(var jpi:jpi_list);
begin 
  clr_string(jpi.prcname) ; 
  jpi.prcname.length := string_size + (jpi$_prcnam*65536);
  clr_string(jpi.usrname);
  jpi.usrname.length := string_size +(jpi$_username*65536);
  clr_string(jpi.terminal);
  jpi.terminal.length:= string_size + (jpi$_terminal*65536);
  jpi.pid.length     :=          4 + (jpi$_pid*65536);
  jpi.uic.length     :=          4 + (jpi$_uic*65536);
  jpi.prib.length    :=          4 + (jpi$_prib*65536);
  jpi.prcname_len^ := 0;
  jpi.usrname_len^ := 0;
  jpi.term_length^ := 0;
  jpi.terminator := 0;
  end;

procedure new_jpi (var jpi : jpi_list);
begin 
  new (jpi.prcname.buffer) ; new(jpi.usrname.buffer);
  new (jpi.prcname_len)    ; new(jpi.usrname_len)   ;
  new (jpi.terminal.buffer); new(jpi.term_length)   ;
  new (jpi.pid.jpi_val)    ; jpi.pid_len := nil     ;
  new (jpi.uic.jpi_val)    ; jpi.uic_len := nil     ;
  new (jpi.prib.jpi_val)   ; jpi.prib_len:= nil     ;
  clr_jpi (jpi);
  end;
(* *)
procedure add_char (var s:string ; c:char);
begin 
  s.buffer^[s.length+1] := c;
  s.length := s.length + 1;
  end; 

procedure add_string (var s1,s2:string); 
var i,j:integer ;
begin 
  j := s2.length ; 
  while (j > 1) and (s2.buffer^[j] = ' ') do j := j - 1;
  for i := 1 to j do add_char ( s1 , s2.buffer^[i]);
  end;

procedure add_packed (var s:string ; p:prompt_type); 
var i,j:integer ;
begin 
  j := prompt_size ;
  while (p[j]=' ') and (j>1) do j := j-1;
  for i := 1 to j do 
    add_char (s , p[i]);
  end; 

procedure write_string (var str:string);
var i:integer;
begin
  for i := 1 to str.length do write (str.buffer^[i]);
  end;

function match_strings (var s1,s2:string): boolean ;
var i : integer; done:boolean;
begin 
  if (s1.length <> s2.length) then 
    match_strings := false 
  else begin 
    match_strings := true ;
    for i := 1 to s1.length do 
      if (s1.buffer^[i] <> s2.buffer^[i]) then 
        match_strings := false ;
    end;
  end;
(* *)
function is_conference( var str:string; header:prompt_type): boolean ;
var i,j:integer ; temp:boolean ; 
begin 
  i := 1;
  temp := true ;
  while (temp) and (header[i]<> ' ') do begin 
    temp := (str.buffer^[i] = header[i]);
    i := i + 1;
    end; 
  is_conference := (temp) and (str.length > i);
  for j := 1 to (str.length-i+1) do 
    str.buffer^[j] := str.buffer^[j+i-1] ;
  str.length := str.length - i + 1;
  end;

function find_confer (var str:string) : boolean ;
label 1;
var i,status,status_2,jpi_count : integer ;
begin 
  find_confer := false ;
  jpi_count := -1;
  status := ss$_normal ;
  while (odd(status)) and (status<> ss$_nomoreproc) do begin 
    clr_jpi (jpi);
    status := sys$getjpi ( 1 , jpi_count , 0 , jpi , 0 , 0 , 0);
    if odd(status) then begin 
       status_2 := sys$waitfr ( 1 );
       jpi.prcname.length := jpi.prcname_len^ ;
       if (is_conference (jpi.prcname,talker_prcnam)) then 
          if match_strings (jpi.prcname , str) then begin
             find_confer := true ;
             goto 1;
             end;
       end;
    end;
  1:
  end;
(* *)
procedure get_command (var sh:string; prompt_in:prompt_type ); 
var i,j,status : integer ;
begin 
  repeat
    if (charcount < 1) or (charcount >= cmd.length) then begin
       i := prompt_size ;
       while (i > 1) and (prompt_in[i] = ' ') do i:= i-1;
       for j := 1 to i do 
         prompt.buffer^[j] := prompt_in[j] ;
       prompt.length := i;
       add_char (prompt , ' ');
       cmd.length    := string_size ;
       if (charcount < 1) then lib$get_foreign (cmd , prompt , i) 
       else                    lib$get_input   (cmd , prompt , i);
       cmd.length := i;
       charcount  := 1;
       end;
    while (cmd.buffer^[charcount] = ' ') and (charcount < cmd.length) do 
       charcount := charcount + 1;
    until (charcount > 0) and (charcount < cmd.length);

    clr_string(sh);

    if (cmd.buffer^[charcount] = '/') then begin 
      add_char(sh , '/');
      charcount := charcount + 1;
      end;

    while (charcount <= cmd.length)
      and ( not (cmd.buffer^[charcount] in terminator)) do begin 
      add_char(sh , upper(cmd.buffer^[charcount])); 
      charcount := charcount + 1;
      end;

    end;


function match ( var sh:string; ch:alpha8; matchlength:integer): boolean ;
var done : boolean ; i:integer ;
begin 
  i := 1; 
  repeat 
    done := (sh.buffer^[i] = ch[i]);
    i := i + 1;
    until (not done) or (i > sh.length) or (i>matchlength);
  if done then begin 
    while (done) and (i<8) and (sh.buffer^[i]<>' ') and (i<sh.length) do begin
      done := (sh.buffer^[i] = ch[i]);
      i := i + 1;
      end;
    end;
  match := done ;
  end;
(* *)
procedure list_confer ; 
var i,status,status_2,jpi_count : integer ;
begin 
  writeln ;
  writeln (' VAX/VMS Conference List ');
  writeln (' ----------------------- ');
  writeln ;
  jpi_count := -1;
  status := ss$_normal ;
  while (odd(status)) and (status<> ss$_nomoreproc) do begin 
    clr_jpi (jpi);
    status := sys$getjpi ( 1 , jpi_count , 0 , jpi , 0 , 0 , 0);
    if odd(status) then begin 
       status_2 := sys$waitfr ( 1 );
       jpi.prcname.length := jpi.prcname_len^ ;
       jpi.usrname.length := jpi.usrname_len^ ;
       jpi.terminal.length:= jpi.term_length^ ;
       if (is_conference (jpi.prcname,talker_prcnam)) then begin 
         write_string (jpi.prcname);
         for i := jpi.prcname.length to 15 do write (' ');
         write ('(Host = ');
         write_string (jpi.usrname); writeln(')');
         end;
       end;
     end;
  end;
(* *)
procedure create_confer ;
var image,cre_error,cre_input,cre_output,prcnam:string ;
    i,status     : integer       ;
    cre_status   : integer       ;
    pidadr       : integer       ;     (* created process pid         *)
    quota        : quota_list    ;     (* quotas for create process   *)
    valid_char   : set of char   ;     (* valid characters for name   *)
    all_valid    : boolean       ;     (* test boolean for valid name *)
begin
  get_command (command , name_prompt);

  valid_char := ['A','B','C','D','E','F','G','H','I','J','K','L','M'
                ,'N','O','P','Q','R','S','T','U','V','W','X','Y','Z'
                ,'0','1','2','3','4','5','6','7','8','9'];
  if (command.length > max_name_size) then 
     command.length := max_name_size;

  all_valid := true;
  for i := 1 to command.length do  
    if not (command.buffer^[i] in valid_char) then all_valid := false;
    
  if (not all_valid) then begin 
     write ('Invalid characters in conference name ');
     write_string(command); writeln('.');
     end
  else if (find_confer (command)) then begin 
    write ('The conference '); write_string (command);
    writeln (' already exists.');
    end
  else begin 
    new_string (image);           new_string (cre_error);
    new_string (cre_input);       new_string (cre_output);
    new_string (prcnam);
  
    add_packed (image      , talker_image);
    add_packed (cre_error  , talker_error);
    add_packed (cre_input  , mail_box_name);
    add_string (cre_input  , command);
    add_packed (cre_output , talker_output);
    add_packed (prcnam     , talker_prcnam);
    add_string (prcnam     , command);

    clr_string (mail_box) ;
    add_packed (mail_box , mail_box_name);
    add_string (mail_box , command);

    quota[1].pql_com := pql$_astlm ;
    quota[1].pql_val := max_members*3 + 2 ;
    
    quota[2].pql_com := pql$_biolm ;
    quota[2].pql_val := max_members*3 + 2 ;
  
    quota[3].pql_com := pql$_diolm ;
    quota[3].pql_val := max_members*3 + 2 ;
    
    quota[4].pql_com := pql$_fillm ;
    quota[4].pql_val := max_members*3 + 2 ;

    quota[5].pql_com := pql$_listend;
  
    status := sys$crembx (1,mail_box_chan,string_size, 0, -1 , 0, mail_box);
    if not odd(status) then lib$stop(status);

    cre_status := sys$creprc (pidadr , image  , cre_input , cre_output , 
                     cre_error , 0 , quota     , prcnam     , 
                     my_prib   , my_uic , 0         , 0          );

    if not odd(cre_status) then lib$stop(cre_status);
  
    write ('The conference '); 
    write_string (command); 
    writeln (' was created.');

    status := sys$qiow (0 , mail_box_chan , io$_writelblk, 
              mail_box_iosb , 0 , 0 , my_name.buffer^[1] , 
              my_name.length , 0 , 0 , nil , 0);

    status := sys$delmbx ( mail_box_chan );
    end;
  end;
(* *)
procedure page_confer ;
var real_box,join : string; status : integer;
begin 
  if (command.length > max_name_size) then 
    command.length := max_name_size;

  if (not find_confer (command)) then begin 
    write ('The conference '); write_string (command) ;
    writeln (' does not exist.');
    end
  else begin 
    clr_string (mail_box) ;
    add_packed (mail_box , mail_box_name);
    add_string (mail_box , command);

    new_string (join);    new_string (real_box);
    add_string (join , my_name);
    add_packed (join , join_prompt); 
    add_string (join , my_usrname);
    add_packed (join , join_prompt_1);
    add_packed (join , join_prompt_2);

    status := translate ( mail_box , real_box);
    if not odd(status) then lib$stop(status);

    status := sys$assign ( real_box , mail_box_chan , 0 , 0);
    if not odd(status) then lib$stop (status);

    write_string (join); writeln;
    writeln ('Please wait for a return or response.');

    status := sys$qiow (0 , mail_box_chan , io$_writelblk, 
              mail_box_iosb , 0 , 0 , join.buffer^[1] , 
              join.length , 0 , 0 , nil , 0);

    status := sys$dassgn (mail_box_chan);

    end;
  end;
(* *)       
procedure initilize ;
var i,j,status:integer ; 
begin 
  charcount := 0;

  new_string (cmd) ;
  new_string (command);
  new_string (prompt);
  new_string (mail_box);
  new_string (my_name);
  new_string (my_usrname);

  terminator := [' ','/','=']; 

  new_jpi (jpi);
  my_pid := 0;
  status := sys$getjpi (0 , my_pid , 0 , jpi , 0 , 0 , 0);
  if not odd (status) then lib$stop(status);
  jpi.prcname.length := jpi.prcname_len^ ;
  jpi.usrname.length := jpi.usrname_len^ ;
  jpi.terminal.length:= jpi.term_length^ ;
  my_pid  := jpi.pid.jpi_val^;
  my_prib := jpi.prib.jpi_val^;
  my_uic  := jpi.uic.jpi_val^;
  my_name.length    := jpi.prcname.length;
  for i := 1 to my_name.length do
    my_name.buffer^[i]    := jpi.prcname.buffer^[i]; 
  my_usrname.length := jpi.usrname.length;
  for i := 1 to my_usrname.length do 
    my_usrname.buffer^[i] := jpi.usrname.buffer^[i];

  end; 

(*********************)
(* main program body *)
(*********************)
begin 
  initilize ;
  get_command ( command , main_prompt );
  
  if match ( command , '/LIST   ' , 4) then 
     list_confer
  
  else if match ( command , '/CREATE ' , 4) then 
     create_confer 

  else 
     page_confer;

  end.