Lexical functions - F$ENVIRONMENT

The next lexical function is F$ENVIRONMENT. Here is the function description:

F$ENVIRONMENT returns information about the current UCL/process environment.

Format
F$ENVIRONMENT(item)

Return Value
The information corresponding to the specified item.

Arguments
item

A keyword indicating the type of information to return. The following are the valid keywords:

Value Meaning

CAPTIVE TRUE if the process is logged into a captive account.

CONTROL The control characters currently enabled. Multiple characters are delimited with commas. Null is returned if no control characters are enabled.

DEFAULT The current default disk and directory.

DISIMAGE TRUE if the logged-in account does not allow direct image invocation (eg the RUN command).

INTERACTIVE TRUE if the process is interactive.

KEY_STATE Current locked keypad state.

MAX_DEPTH Maximum allowable command procedure depth.

MESSAGE Current setting of SET MESSAGE qualifiers.

NOCONTROL The control characters currently disabled. Multiple characters are delimited with commas. Null is returned if no control characters are disabled.

ON_CONTROL_Y Within a command procedure, this returns TRUE if ON_CONTROL_Y is set and FALSE otherwise.

ON_SEVERITY Within a command procedure, this returns the severity level at which the action specified with the ON command was specified.

OUTPUT_RATE Delta time of the batch job default output rate. Returns null if used interactively.

PROCEDURE Specification of current command file. If interactive, the terminal device name is returned.

PROMPT Current DCL prompt.

PROMPT_CONTROL TRUE if prompt is preceded by a CRLF.

PROTECTION Current default file protection.

RESTRICTED TRUE if in a restricted account, FALSE otherwise.

SYMBOL_SCOPE Indicates the current symbol scoping state: [NO]LOCAL or [NO]GLOBAL.

VERB_SCOPE Indicates the current verb scoping state: [NO]LOCAL or [NO]GLOBAL.

VERIFY_IMAGE TRUE if image verification is set. FALSE otherwise.

VERIFY_PREFIX Returns prefix control string.

VERIFY_PROCEDURE True if SET_VERIFY=PROCEDURE is set.

Example
$ X = F$ENVIRONMENT("PROMPT")
This would return the current UCL prompt.

        Function_Environment : begin
                                   if( Missing_Parentheses( '(' ) ) then
                                   begin
                                       exit ;
                                   end ;
                                   if( Parse_Environment( Err, Context ) ) then
                                   begin
                                       exit ;
                                   end ;
                                   if( Missing_Parentheses( ')' ) ) then
                                   begin
                                       exit ;
                                   end ;
                                   S := Context ;
                               end ;

We add handling for this lexical function in Function_Reference. The Parse_Environment function provides a kind of hodge-podge of information about the environment that UCL is running in. It pulls data from symbol tables, process info, and internal UCL values.

function Parse_Environment( var Err : integer ; var Context : string ) : boolean ;

var Flags, Index, P, Start : int64 ;
    S, S1 : string ;

begin
    Result := False ;
    S1 := Get_Parameter( Err, Context ) ;
    if( Err <> 0 ) then
    begin
        Result := True ; // Assume error
        exit ;
    end ;
    S := lowercase( trim( S1 ) ) ;

The Parse_Environment function starts by getting the parameter and converting it to lowercase.

    if( S = 'captive' ) then
    begin
        Flags := Get_UAF( UAI_FLAGS, Err ) ;
        if( ( Flags and UAI_V_CAPTIVE ) <> 0 ) then
        begin
            Context := 'TRUE' ;
        end else
        begin
            Context := 'FALSE' ;
        end ;
    end else
    if( S = 'control' ) then
    begin
        Context := '' ;//TODO
    end else
    if( S = 'default' ) then
    begin
        Context := LIB_Get_Symbol( 'sys$disk:' ) + GETDDIR ;
    end else
    if( S = 'depth' ) then
    begin
        Context := '0' ;//TODO
    end else
    if( S = 'disimage' ) then
    begin
        Flags := Get_UAF( UAI_FLAGS, Err ) ;
        if( ( Flags and UAI_V_DISIMAGE ) <> 0 ) then
        begin
            Context := 'TRUE' ;
        end else
        begin
            Context := 'FALSE' ;
        end ;
    end else
    if( S = 'interactive' ) then
    begin
        if( Interactive ) then
        begin
            Context := 'TRUE' ;
        end else
        begin
            Context := 'FALSE' ;
        end ;
    end else
    if( S = 'keystate' ) then
    begin
        Context := 'DEFAULT' ;//TODO
    end else
    if( S = 'max_depth' ) then
    begin
        Context := '14' ;//TODO
    end else
    if( S = 'message' ) then
    begin
        Context := Message_Switches ;
    end else
    if( S = 'nocontrol' ) then
    begin
        Context := '' ;//TODO
    end else
    if( S = 'on_control_y' ) then
    begin
        if( Interactive ) then
        begin
            Context := 'FALSE' ;
        end else
        begin
            Context := 'INTERACTIVE' ;
        end ;
    end else
    if( S = 'on_severity' ) then
    begin
        if( Interactive ) then
        begin
            Context := 'NONE' ;
        end else
        begin
            Context := 'NONE' ;//TODO
        end ;
    end else
    if( S = 'output_rate' ) then
    begin
        if( Interactive ) then
        begin
            Context := '' ;
        end else
        begin
            Context := '+0:0:0:0.1' ;//TODO
        end ;
    end else
    if( S = 'procedure' ) then
    begin
        Context := Get_Symbol_Value( '', 'sys$command' ) ;
    end else
    if( S = 'prompt' ) then
    begin
        S := LIB_Get_Symbol( '$ucl_prompt' ) ;
        if( S = '' ) then
        begin
            S := '$ ' ;
        end ;
        Context := S ;
    end else
    if( S = 'prompt_control' ) then
    begin
        Context := 'TRUE' ; //TODO
    end else
    if( S = 'protection' ) then
    begin
        P := Get_JPI( JPI_RMS_FILEPROT ) ;
        Context := Protection_To_Text( P ) ;
    end else
    if( S = 'restricted' ) then
    begin
        Flags := Get_UAF( UAI_FLAGS, Err ) ;
        if( ( Flags and UAI_V_RESTRICTED ) <> 0 ) then
        begin
            Context := 'TRUE' ;
        end else
        begin
            Context := 'FALSE' ;
        end ;
    end else
    if( S = 'symbol_scope' ) then
    begin
        if( No_Local_Symbols ) then
        begin
            Context := 'NOLOCAL' ;
        end else
        begin
            Context := 'LOCAL' ;
        end ;
        if( No_Global_Symbols ) then
        begin
            Context := Context + ',' + 'NOGLOBAL' ;
        end else
        begin
            Context := Context + ',' + 'GLOBAL' ;
        end ;
    end else
    if( S = 'verb_scope' ) then
    begin
        if( No_Local_Verbs ) then
        begin
            Context := 'NOLOCAL' ;
        end else
        begin
            Context := 'LOCAL' ;
        end ;
        if( No_Global_Verbs ) then
        begin
            Context := Context + ',' + 'NOGLOBAL' ;
        end else
        begin
            Context := Context + ',' + 'GLOBAL' ;
        end ;
    end else
    if( S = 'verify_image' ) then
    begin
        Context := 'FALSE' ;//TODO
    end else
    if( S = 'verify_prefix' ) then
    begin
        Context := '' ;//TODO
    end else
    if( S = 'verify_procedure' ) then
    begin
        Context := 'FALSE' ;//TODO
    end else
    begin
        Result := True ; // Assume error
        Err := UCL_IVKEYW ;
        Context := S1 ;
        exit ;
    end ;
end ; // Parse_Environment

Next we check the parameter value against the various valid keywords for F$ENVIRONMENT. There is no need to go over each in detail. But I do want to point out the //TODO comments at the end of some of the lines. These relate to features of UCL that we haven't addressed yet, so they are placeholders that we will update in the future. Many of these cases have to do with differences between VMS and UOS. Some of them may simply be left as they are if there is no straight-forward way to convert into VMS-compatible values. But I don't want to bog down this article by getting into those cases right now.

function Get_JPI( Index : int64 ) : int64 ;

var PP_SYS_Descriptor : array[ 0..1 ] of TSYS_Descriptor ;
    Buff, BufLen : int64 ;
    PP : TPID ;

begin
    Buff := 0 ;
    BufLen := 0 ;
    fillchar( PP_SYS_Descriptor, sizeof( PP_SYS_Descriptor ), 0 ) ;
    PP_SYS_Descriptor[ 0 ].MBO := $FFFF ;
    PP_SYS_Descriptor[ 0 ].MBMO := -1 ;
    PP_SYS_Descriptor[ 0 ].Buffer_Length := sizeof( Buff ) ;
    PP_SYS_Descriptor[ 0 ].Item_Code := Index ;
    PP_SYS_Descriptor[ 0 ].Buffer_Address := integer( @Buff ) ;
    PP_SYS_Descriptor[ 0 ].Return_Length_Address := integer( @BufLen ) ;
    PP := 0 ;
    GETJPIW( 0, int64( @PP ), '', integer( @PP_SYS_Descriptor ), integer( @IOSB ), 0, 0 ) ;
    Result := Buff ;
end ;

This function provides a simplified interface to the SYS_GETJPIW system call. It returns an integer value for a given job/process information index.

function Get_UAF( Index : int64 ; Err : integer ) : int64 ;

var Descriptors : array[ 0..1 ] of TDVI_Descriptor ;
    Length : int64 ;

begin
    fillchar( Descriptors, sizeof( Descriptors ), 0 ) ;
    Descriptors[ 0 ].Item_Code := Index ;
    Descriptors[ 0 ].Buffer_Length := sizeof( Result ) ;
    Descriptors[ 0 ].Buffer_Address := int64( @Result ) ;
    Descriptors[ 0 ].Return_Length_Address := int64( @Length ) ;
    Result := 0 ;
    Length := 0 ;
    Err := GETUAI( 0, '', int64( @Descriptors ) ) ;
end ;

Like Get_JPI, this is a simplified interface to a system call - SYS_GETUAI in this case.

function Get_Symbol_Value( const Table, Nam : string ) : string ;

var BufLen, BufLen1, BufLen2, size : int64 ;

begin
    setlength( Result, 255 ) ;
    BufLen := 0 ;
    Buflen1 := 0 ;
    Buflen2 := 0 ;
    Size := 0 ;
    fillchar( SYS_Descriptor, sizeof( SYS_Descriptor ), 0 ) ;
    SYS_Descriptor[ 0 ].MBO := $FFFF ;
    SYS_Descriptor[ 0 ].MBMO := -1 ;
    SYS_Descriptor[ 0 ].Buffer_Length := sizeof( Buff ) ;
    SYS_Descriptor[ 0 ].Item_Code := LNM_ATTRIBUTES ;
    SYS_Descriptor[ 0 ].Buffer_Address := integer( @Buff ) ;
    SYS_Descriptor[ 0 ].Return_Length_Address := integer( @BufLen ) ;
    SYS_Descriptor[ 1 ].MBO := $FFFF ;
    SYS_Descriptor[ 1 ].MBMO := -1 ;
    SYS_Descriptor[ 1 ].Buffer_Length := length( Result ) ;
    SYS_Descriptor[ 1 ].Item_Code := LNM_STRING ;
    SYS_Descriptor[ 1 ].Buffer_Address := int64( PAnsiChar( Result ) ) ;
    SYS_Descriptor[ 1 ].Return_Length_Address := integer( @BufLen1 ) ;
    SYS_Descriptor[ 2 ].MBO := $FFFF ;
    SYS_Descriptor[ 2 ].MBMO := -1 ;
    SYS_Descriptor[ 2 ].Buffer_Length := sizeof( Size ) ;
    SYS_Descriptor[ 2 ].Item_Code := LNM_LENGTH ;
    SYS_Descriptor[ 2 ].Buffer_Address := int64( @Size ) ;
    SYS_Descriptor[ 2 ].Return_Length_Address := integer( @BufLen2 ) ;
    TRNLNM( LNM_M_CASE_BLIND, Table, Nam, 0, int64( @SYS_Descriptor ) ) ;
    if( Size > 255 ) then // Buffer wasn't large enough to contain symbol value
    begin
        setlength( Result, Size ) ;
        fillchar( SYS_Descriptor, sizeof( SYS_Descriptor ), 0 ) ;
        SYS_Descriptor[ 0 ].MBO := $FFFF ;
        SYS_Descriptor[ 0 ].MBMO := -1 ;
        SYS_Descriptor[ 0 ].Buffer_Length := length( Result ) ;
        SYS_Descriptor[ 0 ].Item_Code := LNM_STRING ;
        SYS_Descriptor[ 0 ].Buffer_Address := int64( PAnsiChar( Result ) ) ;
        SYS_Descriptor[ 0 ].Return_Length_Address := integer( @BufLen1 ) ;
        TRNLNM( LNM_M_CASE_BLIND, Table, Nam, 0, int64( @SYS_Descriptor ) ) ;
    end ;
    if( ( Buff and LNM_M_EXISTS ) <> 0 ) then // Found it
    begin
        setlength( Result, BufLen1 ) ;
        exit ;
    end ;
end ; // Get_Symbol_Value


function Symbol_Value( const Nam : string ) : string ; //TODO:Include in article

var N : string ;

begin
    N := '$' + inttostr( PID ) ;
    Result := Get_Symbol_Value( N, Nam ) ;
end ;

Symbol_Value was used by code we've covered in previous articles, but we didn't include this function until now. It simply wraps Get_Symbol_Value, which obtains the value of a symbol, passing the process table name. If a table name is passed to Get_Symbol_Value, the symbol is looked up in that table. If table is null, all tables are checked starting with the current process symbol table on up to the cluster table, until the symbol is found (or not). We set a 255-byte buffer to receive the symbol contents. Along with the symbol value, we request the symbol length. If the actual length exceeds 255, we resize the buffer appropriately and call TRNLNM again to get the full value. The hope is that the second call won't be needed most of the time. The idea here is to reduce the number of calls to ring 0. If the symbol fits in the 255-byte buffer, we've saved a call. Otherwise, we'd have to make a call to get the length, then another call to get the data, meaning that we'd have two calls every single time.

                    JPI_RMS_FILEPROT: // RMS File Protection
                         begin
                             if( Len > sizeof( Value ) ) then
                             begin
                                 Len := sizeof( Value ) ;
                             end ;
                             Process := Get_Process( Target_PID ) ;
                             if( Process = nil ) then // Process doesn't exist
                             begin
                                 Generate_Exception( UOSErr_Nonexistent_Process ) ;
                                 exit ;
                             end ;
                             Value := Process.Protection ;
                             Write_User( Kernel, PID, Descriptor.Buffer_Address, Len, Value ) ;
                             Write_User( Kernel, PID, Descriptor.Return_Length_Address, sizeof( Len ), 
                                 Len ) ;
                         end ;

This code is added to the USC.Get_Job_Process_Info method to handle obtaining the current default file protection code for the process.

    Protection := PROTECTION_SYSTEM_READ or PROTECTION_SYSTEM_WRITE or
        PROTECTION_SYSTEM_EXECUTE or PROTECTION_SYSTEM_DELETE or
        PROTECTION_OWNER_READ or PROTECTION_OWNER_WRITE or
        PROTECTION_OWNER_EXECUTE or PROTECTION_OWNER_DELETE or
        PROTECTION_GROUP_READ or PROTECTION_GROUP_EXECUTE ;

And this code is added to the end of the TProcess constructor to set up the default file protection mask for all processes.

In the next article, we'll look at the SYS_GETUAI system call.