{ CLI_parse_foreign -- just call it once at the very beginning of your program
  and it acts like you're a DCL command with out the user having to do SET
  COMMAND.

  John Fritz 
  MCV Academic Computing
  Medical College of Virignia
  Box 16, MCV Station
  Richmond, VA   23298
  (804) 786-9843
  }

[inherit('sys$library:starlet','sys$library:rtl')]
module cli_parse_foreign;

[hidden,external(cli$dcl_parse)] function cli$$dcl_parse(
   commandString: [readonly,class_s] packed array[a..b: integer] of char;
   %ref table: [readonly,volatile] integer;
   %immed [unbound] function param_routine(
      var get:    [volatile,readonly] integer;
      var prompt: [volatile,readonly,truncate] integer;
      var retLen: [truncate] $uword): integer := %immed 0;
   %immed [unbound] function prompt_routine(
      var get:    [volatile,readonly] integer;
      var prompt: [volatile,readonly,truncate] integer;
      var retLen: [truncate] $uword): integer := %immed 0;
   prompt: [truncate] varying[len] of char): integer; extern;

[hidden] type
   condition = packed record
      severity: [pos( 0), bit( 3)] 0..7;
      message:  [pos( 3), bit(13)] 0..8191;
      facility: [pos(16), bit(12)] 0..4095;
      printed:  [pos(28), bit( 1)] boolean;
      reserved: [pos(29), bit( 3)] 0..0;
      end;
   sigargs = record num: integer; cond: condition end;
   mechargs = array[0..4] of integer;

[hidden,asynchronous] function printAndExit(
   var sig: [volatile] sigargs;
   var mech: [volatile] mechArgs): integer;
{This condition calls the last chance condition handler to print the sig
 message vector (and exit if the condition's severity is severe). If an
 exit did not take place, and the condition is even, it calls $exit with the 
 condition marked as already printed.
 Thus:
   1) EVERY condition which is signaled will cause an exit (to DCL or to the 
      debugger), and
   2) No other condition handler will get a chance to handle the condition,
      not even the debugger's, unless
   3) You change the last chance condition handler before this handler catches
      an error, in which case weird things may happen.
  Note that we cannot call $putmsg ourselves, since the last chance handler
  apparently cleans up some possible values of the signal array which $putmsg
  does not handle well--some of which are perfectly legal according to the
  $putmsg documentation, and some of which are not but arise naturally when
  calling lib$signal.}
var
   argList: record
      numArgs: $ubyte; reserved: [byte(3)] 0..0;
      s: integer;
      m: integer;
      end;
   lastChance: unsigned;
begin
   with argList do begin 
      numArgs := 2; 
      reserved := 0; 
      s := iaddress(sig);
      m := iaddress(mech);
      end;
   $setexv(2,,,lastChance);		{get the address of last chance handler}
   $setexv(2,%immed lastChance);	{put it back}
   if lastChance = 0 then printAndExit := ss$_resignal
   else begin
      lib$callG(argList, %immed lastChance);
      if odd(sig.cond::integer) then printAndExit := ss$_continue
      else begin
         sig.cond.printed := true;
         $exit(sig.cond::integer);
         end;
      end;
   end;

[hidden] var
   cli$_insfprm: [external,value] integer; 

[hidden,unbound] function dclPrompt(
   var a: [volatile] integer;                                                 
   var b: [volatile] integer;
   var c: $uword): integer;
{This procedure checks to make sure that sys$input is a terminal.
 If not, it signals cli$_insfprm (insufficient parameters),
 which should exit, assuming printAndExit has been established;
 if so, it calls lib$get_input with the same parameters it was
 passed.
 This procedure is necessary because cli$dcl_parse is perfectly happy to
 prompt from a mailbox, although DCL itself will not. (Cli$dcl_parse will
 properly refuse to prompt from a disk file--strange stuff)}

var
   dvitem: [static] record
      bufLen,item: $uword;
      bufAddr,retLen: integer;
      sentinel: integer;
      end := (4,dvi$_devclass,0,0,0);
   devClass: [static,volatile] integer := 0;

begin
   dvitem.bufaddr := iaddress(devClass); 
   $getdviw(devnam:='sys$input',itmlst:=dvitem);
   if devClass <> dc$_term then lib$signal(cli$_insfprm);
   dclPrompt := lib$get_input(%ref a, %ref b, c)
   end;

{@+ mcvlib}

type
   cli_tableType = 
      [byte(5)] record cli_tableType: boolean end;
      {Example declaration: 
         table: [external] cli_tableType;
       The strange type declaration is mostly intended to ensure
       that no other variable has the same type.
       This should refer to a .CLD file something like
       MODULE TABLE
          DEFINE VERB CLI_
          ROUTINE CLI_ABORT ! abort if cli$dispatch is called
          ...
       }
{@- mcvlib}
{@+ mcvlib

[external] procedure cli_parse_foreign(
   var table: cli_tableType;
       verb: [class_s,truncate] packed array[a..b: integer] of char);
   extern;

[external] procedure cli_abort; extern;
   {aborts if cli$dispatch is called}
{@- mcvlib}

[global] procedure cli_abort;
var
   cli$_invreqtyp,cli$_cmdseg: [external,value] integer;
begin
   lib$stop(cli$_invreqtyp,0,cli$_cmdseg,2**16+1,
      %stdescr 'cli$dispatch called after cli_parse_foreign');
   end;

[global] procedure cli_parse_foreign(
   var table: [volatile] integer;
       {This is the table generated by SET COMMAND/OBJECT; it should
        be declared [external] integer;
        (The volatile attribute is to discourage Pascal from copying the
         first longword of the table somewhere, and passing the address
         of that to cli$dcl_parse. I doubt if it would anyway, but
         better safe than sorry.)}
   var verb: [truncate,volatile] integer
       {This is the name of the command (only the first four letters are 
        significant). If the parameter is missing, it be given the value
        'CLI_'. (Since cli_parse_foreign is most useful in situations where
        it is natural to have only one verb in the table, a default makes
        a certain amount of sense.)
        Although declared as an integer, it should actually be a string
        passed by descriptor: any legal string descriptor will do, as
        it will be copied with lib$scopy_dxdx. We again declare it volatile
        to discourage Pascal from copying it}
   );
{Cli_parse_foreign does a DCL parse of the command line for a foreign 
 command, emulating as closely as possible what DCL does before it activates 
 an image which has been installed in a process's command table. The idea is 
 to avoid the eternal wait for SET COMMAND to complete by linking the table
 into the image and using cli_parse_foreign to parse the command line
 made up of the verb parameter concatenated with the string returned by
 lib$get_foreign.
 There are a few oddities to it:
    1) The command is still a foreign command, which implies that it must
       be defined with a DCL symbol, e.g.
          verb :== $programDirectory:verb.exe
       Thus its parameters may be only 251 characters long, after
       squeezing spaces, expanding symbols, and so on. (Why 251 instead
       of 255 or 256 I don't know.)
       Also if users want to put things like
          verb2 :== verb/qualifier
       in login.com files, they must use
          verb2 :== 'verb'/qualifier
       or something similar.
    2) Cli_parse_foreign will refuse to prompt for missing parameters if 
       sys$input is not the terminal, but if you put something like
          $ define/user sys$input sys$command
          $ verb
       in a command procedure, the user will be prompted, which is not the
       case with DCL.
    3) Since the image is always run, certain fine points of behaviour will
       be different if syntax errors are found. You can't continue from
       a control-Y'd image after making an error in the command syntax
       of an image called using cli_parse_foreign, for instance.
    4) Cli_parse_foreign is intended to be called ONCE, at the beginning of
       your program. It will exit if it finds a parsing error, after
       printing the usual DCL error message (except that the facility name
       will be CLI instead of DCL) without printing any traceback messages,
       and without giving ANY other exception handlers a shot at the condition,
       whether those handlers are established by you or by the debugger.
       After such an exit, the value of the $STATUS symbol will have the value 
       it would have when DCL found the same error, plus %X10000000 (since the 
       'do not print' flag is turned on to prevent $exit from printing the 
       error message again). It will also exit if the user hits control-Z
       during prompting for missing parameters. In that case, the value
       of $STATUS will be ss$_normal.
    5) Cli_parse_foreign calls the last chance exception handler to
       print the error messages mentioned in the note above, so don't mess
       with that handler before you call cli_parse_foreign. (The procedure
       calls the last chance handler because the $putmsg system service
       does some very weird things with certain common signal array setups;
       the last chance handler somehow fixes this up.)
    }
var
   stat: integer;
   cli$_nocomd: [external,value] integer;
   temp: integer;
   commandLine: record
      len: $uword;
      v: packed array[1..4] of char; 
      sp: char;
      parms: packed array[1..1024] of char;
      end;
type                      
   vary = varying[size(commandLine)-2] of char;
const
   promptStr = '$: ';
   vSize = size(commandLine.v);
   prefixLen = vSize + size(commandLine.sp);
   defaultVerb = 'CLI_';
begin 
   with commandLine do begin
      if not present(verb) then v := defaultVerb
      else if iaddress(verb) = 0 then v := defaultVerb
      else begin 
         stat := lib$scopy_dxdx(%ref verb,v);
         if not odd(stat) then lib$signal(stat);
         end;
      sp := ' '; 
      lib$get_foreign(parms,,len); 
      len := len+prefixLen;                
      end;
   establish(printAndExit);
   stat := cli$$dcl_parse(commandLine::vary, table, 
      %immed dclPrompt, %immed dclPrompt, promptStr);
   if not odd(stat) then begin
      revert;
      temp := cli$_nocomd;
      if lib$match_cond(stat,rms$_eof,temp) > 0 then $exit(ss$_normal)
      else lib$signal(stat);
      end;
   end;                                                    
end.
