SYS_DISPLAY

In the previous article, we covered the F$FILE_ATTRIBUTES lexical function. Now we will look a the SYS_DISPLAY system service that it uses.

function SYS_DISPLAY( FAB, Err, Success : int64 ) : int64 ;

var Status : byte ;
    SysRequest : TInteger3_Request ;

begin
    fillchar( SysRequest, sizeof( SysRequest ), 0 ) ;
    SysRequest.Request.Subsystem := UOS_Subsystem_FIP ;
    SysRequest.Request.Request := UOS_FIP_Display ;
    SysRequest.Request.Length := sizeof( TInteger3_Request ) - sizeof( SysRequest.Request ) ;
    SysRequest.Request.Status := integer( @Status ) ;
    SysRequest.Int1 := FAB ;
    SysRequest.Int2 := Err ;
    SysRequest.Int3 := Success ;

    Call_To_Ring0( integer( @SysRequest ) ) ;
    Result := Status ;
end ;

We add the SYS_DISPLAY function to the RMS unit. When we get to supporting RMS, we will update this to handle RMS-specific information.

      UOS_FIP_Display:
          begin
              UE := Enter_System_Call( Request, SReq, PID, MMC, sizeof( TInteger3_Request ) - sizeof( SReq ), 
                  Address ) ;
              if( UE <> nil ) then
              begin
                  Set_Last_Error( UE ) ;
                  exit ;
              end ;
              try
                  Integer3_Request := PInteger3_Request( Address ) ;

                  // Read input into caller's buffer...
                  Display( PID, Integer3_Request.Int1, Integer3_Request.Int2, Integer3_Request.Int3, 
                      IOSB ) ;
                  Status := Write_User_int64( Kernel, PID, Integer3_Request.Request.Status, 
                      IOSB.r_io_64.r_bcnt_32.l_bcnt ) ;
              finally
                  Exit_System_Call( integer( Integer3_Request ), PID, MMC, 
                      sizeof( TInteger3_Request ) - sizeof( SReq ) ) ;
              end ;
          end ;

This code is added to the FIP.API method.

procedure TUOS_FiP.Display( PID : TPID ; _FAB, Err, Succ : int64 ;
    var IOSB : TIOSB ) ;

var P : integer ;
    Prefix : packed record
                 Code : byte ;
                 Length : byte ;
             end ;
    Device : TDevice ;
    Dummy : integer ;
    Info : TUOS_File_Info ;
    FAB : TFAB ;
    NAM : TNAML ;
    Dev, Dir, Name, Node, Extension, Ver : string ;
    Next : int64 ;
    UE : TUnified_Exception ;
    XABALL : TXABALL ;
    XABDAT : TXABDAT ;
    XABFHC : TXABFHC ;
    XABITM : TXABITM ;
    XABKEY : TXABKEY ;
    XABPRO : TXABPRO ;
    XABRDT : TXABRDT ;
    XABSUM : TXABSUM ;
    XABTRM : TXABTRM ;

begin
    // Get file specification parts...
    if( _FAB = 0 ) then
    begin
        exit ;
    end ;
    fillchar( FAB, sizeof( FAB ), 0 ) ;
    Get_User_Data( Kernel, PID, _FAB, 1, FAB, IOSB.r_io_64.w_status ) ; // Get FAB length
    if( IOSB.r_io_64.w_status <> 0 ) then
    begin
        exit ;
    end ;
    if( FAB.FAB_B_BLN > sizeof( FAB ) ) then
    begin
        FAB.FAB_B_BLN := sizeof( FAB ) ;
    end ;
    Get_User_Data( Kernel, PID, _FAB, FAB.FAB_B_BLN, FAB, IOSB.r_io_64.w_status ) ; // Get FAB
    if( IOSB.r_io_64.w_status <> 0 ) then
    begin
        exit ;
    end ;

The Display method first checks for a FAB address. If 0, we exit immediately (this is a no-op). Next, we zero-fill the FAB so that any unsupplied fields are 0 - in the case when the caller passes only part of the structure. We then get the first byte of the FAB from the caller's memory. This is the FAB length value. We exit immediately if there was an error reading that value. We then make sure that the passed size doesn't excede the actual FAB length. Then we read the entire (provided) FAB structure from the caller's memory - and exit if there was an error.

    //TODO:Handle file handle
    if( FAB.FAB_L_NAM = 0 ) then // No name block
    begin
        exit ;
    end ;
    Get_NAM( Kernel, PID, FAB.FAB_L_NAM, NAM, IOSB.r_io_64.w_status ) ;
    if( IOSB.r_io_64.w_status <> 0 ) then
    begin
        exit ;
    end ;

On VMS, this system call only works on files that are open. In UOS, we avoid the overhead of having to open a file if all we want is some information on it. UOS will support open files as well (in fact, some return values only apply to files that are currently open), but doesn't require them. For now, we'll ignore the case where the file is already open, and when a file handle is passed instead of a name.
If the pointer to the NAML structure is null, we exit since we have no file name that we can use to retrieve information. Otherwise, we use the Get_NAM function to obtain the NAML block, and exit if there's an error.

    Dev := Get_FAB_String( Kernel, PID, NAM.NAML_L_LONG_DEV, NAM.NAML_B_LONG_DEV_SIZE, 
        IOSB.r_io_64.w_status ) ;
    if( IOSB.r_io_64.w_status <> 0 ) then
    begin
        exit ;
    end ;
    Dir := Get_FAB_String( Kernel, PID, NAM.NAML_L_LONG_DIR, NAM.NAML_L_LONG_DIR_SIZE, 
        IOSB.r_io_64.w_status ) ;
    if( IOSB.r_io_64.w_status <> 0 ) then
    begin
        exit ;
    end ;
    Name := Get_FAB_String( Kernel, PID, NAM.NAML_L_LONG_NAME, NAM.NAML_L_LONG_NAME_SIZE, 
       IOSB.r_io_64.w_status ) ;
    if( IOSB.r_io_64.w_status <> 0 ) then
    begin
        exit ;
    end ;
    Node := Get_FAB_String( Kernel, PID, NAM.NAML_L_LONG_NODE, NAM.NAML_L_LONG_NODE_SIZE, 
        IOSB.r_io_64.w_status ) ;
    if( IOSB.r_io_64.w_status <> 0 ) then
    begin
        exit ;
    end ;
    Extension := Get_FAB_String( Kernel, PID, NAM.NAML_L_LONG_TYPE, NAM.NAML_L_LONG_TYPE_SIZE, 
        IOSB.r_io_64.w_status ) ;
    if( IOSB.r_io_64.w_status <> 0 ) then
    begin
        exit ;
    end ;
    Ver := Get_FAB_String( Kernel, PID, NAM.NAML_L_LONG_VER, NAM.NAML_L_LONG_VER_SIZE, 
        IOSB.r_io_64.w_status ) ;
    if( IOSB.r_io_64.w_status <> 0 ) then
    begin
        exit ;
    end ;

Next, we pull all the component parts of the file specification from the NAML block using the Get_FAB_String function.

    if( Dev = '' ) then // No device specified
    begin
        IOSB.r_io_64.w_status := UE_Error ;
        Generate_Exception( UOSErr_Invalid_Device_Name ) ;
        exit ;
    end ;

    if( ( Dir = '' ) and ( Name = '' ) and ( Extension = '' ) and ( Ver = '' ) ) then // Only device
    begin
        Device := Get_Device( Dev ) ;
        if( Device = nil ) then
        begin
            IOSB.r_io_64.w_status := UE_Error ;
            Generate_Exception( UOSErr_Device_Not_Found ) ;
            exit ;
        end ;
        FAB.FAB_L_DEV := Device.Info.Flags ;
        IOSB.r_io_64.w_status := Write_User( Kernel, PID, _FAB, FAB.FAB_B_BLN, FAB ) ;
        exit ;
    end ;

Once we've parsed the specification, we ensure that there is a device specified. We cannot find a file unless we know which device it resides on. So, if the device name is null, we exit with an error.
Next we check for a special case: a device name by itself. Generally, if one wants device information, the GETDVI system service is used. However, we handle the situation here by checking that the device name corresponds to an actual device (if not, we return an error). Then we set the FAB_L_DEV flags from the device flags and exit.

    // Normalize name...
    if( copy( Dev, length( Dev ), 1 ) <> ':' ) then
    begin
        Dev := Dev + ':' ;
    end ;
    Dev := Resolve_Symbol( PID, Dev ) ;
    P := pos( ':', Dev ) ;
    if( ( P > 0 ) and ( P < length( Dev ) ) ) then
    begin
        Dir := Append_Path( copy( Dev, P + 1, length( Dev ) ), Dir ) ;
        Dev := copy( Dev, 1, P ) ;
    end ;
    Dummy := pos( ':', Dev ) ;
    if( Dummy < 2 ) then // Missing device
    begin
        IOSB.r_io_64.w_status := UE_Error ;
        Generate_Exception( UOSErr_Device_Not_Found ) ;
        exit ;
    end ;
    if( copy( Dir, 1, 1 ) <> '\' ) then
    begin
        Dir := '\' + Dir ;
    end ;
    if( copy( Dir, length( Dir ), 1 ) <> '\' ) then
    begin
        Dir := Dir + '\' ;
    end ;

Now we normalize the specification. First we make sure the device name ends with a colon. Then we resolve the symbol in case the device is actually a logical name. Then we copy anything after the colon to the start of the directory name and trim it from the device name. If there is no colon after the symbol resolution, we exit with an error because no device was specified. Then we make sure that the directory name begins and ends with a backslash.

    // Get device and its file system...
    Device := Get_Device( copy( Dev, 1, Dummy ) ) ;
    if( Device = nil ) then
    begin
        IOSB.r_io_64.w_status := UE_Error ;
        Generate_Exception( UOSErr_Device_Not_Found ) ;
        exit ;
    end ;
    if( not Device.Mounted ) then
    begin
        IOSB.r_io_64.w_status := UE_Error ;
        Generate_Exception( UOSErr_Device_Not_Mounted ) ;
        exit ;
    end ;
    if( Device.FS = nil ) then
    begin
        IOSB.r_io_64.w_status := UE_Error ;
        Generate_Exception( UOSErr_Device_Not_File_Structured ) ;
        exit ;
    end ;
    if( ( Extension <> '' ) and ( copy( Extension, 1, 1 ) <> '.' ) ) then
    begin
        Extension := '.' + Extension ;
    end ;

Next we get the device instance for the specified device, and exit if there is none. Then we check to make sure the device is mounted and has an associated file system. If either case isn't true, we exit with an error. Finally, we normalize the file extension by making sure it starts with a dot, unless it is null. At this point, we have a completely normalized specification - although, granted, it is in component pieces.

    // Get file information...
    Info := Device.FS.Get_File_Info( PChar( Dir + Name + Extension ), 0 ) ;
    UE := Device.FS.Last_Error ;
    if( ( UE <> nil ) and ( UE.Get_Error <> 0 ) ) then
    begin
        IOSB.r_io_64.w_status := UE_Error ;
        Generate_Exception( UE.Get_Error ) ;
        exit ;
    end ;

Now we ask the file system for information about the file (combining the components into a single string). If there was an error, we exit.

    // Return information...
    Next := FAB.FAB_L_XAB ;
    while( Next <> 0 ) do // Until end of XAB chain
    begin
        // Get XAB code...
        Get_User_Data( Kernel, PID, Next, sizeof( Prefix ), Prefix, IOSB.r_io_64.w_status ) ;
        if( IOSB.r_io_64.w_status <> 0 ) then
        begin
            exit ;
        end ;

We will now follow the XAB chain, starting with the FAB_L_XAB pointer, and fill the various XAB fields with information. Next contains the current pointer that we are following. Once we hit a null pointer, the loop ends. The first thing we do in the loop is obtain the prefix (type and length) of the XAB and exit if there was a error obtaining it from the caller's memory. Because a given XAB may be one of several types (see previous articles), we have to get the XAB prefix first to determine which type of XAB to process.

        // Based on type of XAB...
        if( Prefix.Code = XAB_C_ALL ) then
        begin
            fillchar( XABALL, sizeof( XABALL ), 0 ) ;
            if( Prefix.Length > sizeof( XABALL ) ) then
            begin
                Prefix.Length := sizeof( XABALL ) ;
            end ;
            Get_User_Data( Kernel, PID, Next, Prefix.Length, XABALL, IOSB.r_io_64.w_status ) ;
            if( IOSB.r_io_64.w_status <> 0 ) then
            begin
                exit ;
            end ;
            Next := XABALL.XAB_L_NXT ;
        end else
        if( Prefix.Code = XAB_C_DAT ) then
        begin
            fillchar( XABDAT, sizeof( XABDAT ), 0 ) ;
            if( Prefix.Length > sizeof( XABDAT ) ) then
            begin
                Prefix.Length := sizeof( XABDAT ) ;
            end ;
            Get_User_Data( Kernel, PID, Next, Prefix.Length, XABDAT, IOSB.r_io_64.w_status ) ;
            if( IOSB.r_io_64.w_status <> 0 ) then
            begin
                exit ;
            end ;
            XABDAT.XAB_Q_BDT := Info.Last_Backup ; // Backup date and time
            XABDAT.XAB_Q_CDT := Info.Creation ; // Creation date and time
            XABDAT.XAB_Q_EDT := Info.Expiration ; // Expiration date and time
            XABDAT.XAB_Q_RDT := Info.Last_Modified ; // Revision date and time
            XABDAT.XAB_Q_ACC := Info.Last_Access ; // Last access date and time
            IOSB.r_io_64.w_status := Write_User( Kernel, PID, Next, Prefix.Length, XABDAT ) ;
            if( IOSB.r_io_64.w_status <> 0 ) then
            begin
                exit ;
            end ;
            Next := XABDAT.XAB_L_NXT ;
        end else

XABALL blocks have to do with RMS allocation information, so there is nothing we do with that block type, except to get the pointer to the next XAB in the chain. XABDAT blocks contain date/time information for the file, all of which we can set from the UOS file information structure that we obtained above.
In either case, we zero out the appropriate XAB structure and then make sure the block size doesn't exceed the XAB structure's actual size. Next we zero-out the structure (in case the caller's structure is smaller than the actual XAB). Then we copy the XAB from the caller's memory to our local structure. After updating the XABDAT structure, we write the update back to the caller's memory. Obviously, we exit if there was an error reading or writing the caller's structure.

        if( Prefix.Code = XAB_C_FHC ) then
        begin
            fillchar( XABFHC, sizeof( XABFHC ), 0 ) ;
            if( Prefix.Length > sizeof( XABFHC ) ) then
            begin
                Prefix.Length := sizeof( XABFHC ) ;
            end ;
            Get_User_Data( Kernel, PID, Next, Prefix.Length, XABFHC, IOSB.r_io_64.w_status ) ;
            if( IOSB.r_io_64.w_status <> 0 ) then
            begin
                exit ;
            end ;
            XABFHC.XAB_Q_EOF := Info.EOF ; // End-of-file (logical file length)
            XABFHC.XAB_W_VERLIMIT := Info.Version_Limit ; // Version limit for the file
            XABFHC.XAB_W_MRS := Info.Record_Size ;
            XABFHC.XAB_Q_SIZ := Info.Size ; // Size on disk
            XABFHC.XAB_Q_USZ := Info.Uncompressed_Size ; // Uncompressed size
            XABFHC.XAB_L_CLS := Info.Clustersize ; // Clustersize
            XABFHC.XAB_L_CRE := Info.Creator ; // Creator UIC
            XABFHC.XAB_W_FLG := Info.Flags and $FFFF ; // Flags (not including protection codes)
            IOSB.r_io_64.w_status := Write_User( Kernel, PID, Next, Prefix.Length, XABFHC ) ;
            if( IOSB.r_io_64.w_status <> 0 ) then
            begin
                exit ;
            end ;
            Next := XABFHC.XAB_L_NXT ;
        end else

For the XABFHC structure, we zero-out and read the structure as we did for the previous two XAB types. Then we update the non-RMS fields and write the structure back.

        if( Prefix.Code = XAB_C_ITM ) then
        begin
            fillchar( XABITM, sizeof( XABITM ), 0 ) ;
            if( Prefix.Length > sizeof( XABITM ) ) then
            begin
                Prefix.Length := sizeof( XABITM ) ;
            end ;
            Get_User_Data( Kernel, PID, Next, Prefix.Length, XABITM, IOSB.r_io_64.w_status ) ;
            if( IOSB.r_io_64.w_status <> 0 ) then
            begin
                exit ;
            end ;
            Next := XABITM.XAB_L_NXT ;
        end else
        if( Prefix.Code = XAB_C_KEY ) then
        begin
            fillchar( XABKEY, sizeof( XABKEY ), 0 ) ;
            if( Prefix.Length > sizeof( XABKEY ) ) then
            begin
                Prefix.Length := sizeof( XABKEY ) ;
            end ;
            Get_User_Data( Kernel, PID, Next, Prefix.Length, XABKEY, IOSB.r_io_64.w_status ) ;
            if( IOSB.r_io_64.w_status <> 0 ) then
            begin
                exit ;
            end ;
            Next := XABKEY.XAB_L_NXT ;
        end else

The XABITM and XABKEY structures are also ignored, for now, and treated as is the XABALL structure above.

        if( Prefix.Code = XAB_C_PRO ) then
        begin
            fillchar( XABPRO, sizeof( XABPRO ), 0 ) ;
            if( Prefix.Length > sizeof( XABPRO ) ) then
            begin
                Prefix.Length := sizeof( XABPRO ) ;
            end ;
            Get_User_Data( Kernel, PID, Next, Prefix.Length, XABPRO, IOSB.r_io_64.w_status ) ;
            if( IOSB.r_io_64.w_status <> 0 ) then
            begin
                exit ;
            end ;
            XABPRO.XAB_L_UIC := Info.Owner ; // File owner
            XABPRO.XAB_W_PRO := ( Info.Flags shr 16 ) and $FFFF ; // File protection
            IOSB.r_io_64.w_status := Write_User( Kernel, PID, Next, Prefix.Length, XABPRO ) ;
            if( IOSB.r_io_64.w_status <> 0 ) then
            begin
                exit ;
            end ;
            Next := XABPRO.XAB_L_NXT ;
        end else

The XABPRO structure only has two non-RMS fields. We update those appropriately. Note that we shift the file flags right to get the file protection code into the XAB_W_PRO field.

        if( Prefix.Code = XAB_C_RDT ) then
        begin
            fillchar( XABRDT, sizeof( XABRDT ), 0 ) ;
            if( Prefix.Length > sizeof( XABRDT ) ) then
            begin
                Prefix.Length := sizeof( XABRDT ) ;
            end ;
            Get_User_Data( Kernel, PID, Next, Prefix.Length, XABRDT, IOSB.r_io_64.w_status ) ;
            if( IOSB.r_io_64.w_status <> 0 ) then
            begin
                exit ;
            end ;
            Next := XABRDT.XAB_L_NXT ;
        end else
        if( Prefix.Code = XAB_C_SUM ) then
        begin
            fillchar( XABSUM, sizeof( XABSUM ), 0 ) ;
            if( Prefix.Length > sizeof( XABSUM ) ) then
            begin
                Prefix.Length := sizeof( XABSUM ) ;
            end ;
            Get_User_Data( Kernel, PID, Next, Prefix.Length, XABSUM, IOSB.r_io_64.w_status ) ;
            if( IOSB.r_io_64.w_status <> 0 ) then
            begin
                exit ;
            end ;
            Next := XABSUM.XAB_L_NXT ;
        end else
        if( Prefix.Code = XAB_C_TRM ) then
        begin
            fillchar( XABTRM, sizeof( XABTRM ), 0 ) ;
            if( Prefix.Length > sizeof( XABTRM ) ) then
            begin
                Prefix.Length := sizeof( XABTRM ) ;
            end ;
            Get_User_Data( Kernel, PID, Next, Prefix.Length, XABTRM, IOSB.r_io_64.w_status ) ;
            if( IOSB.r_io_64.w_status <> 0 ) then
            begin
                exit ;
            end ;
            Next := XABTRM.XAB_L_NXT ;
        end else
        begin
            break ; // Unrecognized XAB code
        end ;
    end ;
end ; // TUOS_FiP.Display

The XABRDT, XABSUM, and XABTRM structures are ignored for now other than as links in the XAB chain.

procedure Get_NAM( Kernel : TUOS_Kernel ; PID : TPID ; Address : int64 ;
    var NAM : TNAML ; var Status : integer ) ;

var I : integer ;

begin
    fillchar( NAM, sizeof( NAM ), 0 ) ;
    Get_User_Data( Kernel, PID, Address, 2, NAM, Status ) ; // Get type and length
    if( Status <> 0 ) then
    begin
        exit ;
    end ;
    I := NAM.NAML_B_BLN ;
    if( I > sizeof( NAM ) ) then
    begin
        I := sizeof( NAM ) ;
    end ;
    Get_User_Data( Kernel, PID, Address, I, NAM, Status ) ; // Get type and length
    if( Status <> 0 ) then
    begin
        exit ;
    end ;
end ;

This function obtains a NAML structure from the caller.

function Get_FAB_String( Kernel : TUOS_Kernel ; PID : TPID ; Address, Len : int64 ;
    var Status : integer ) : string ;

var SRB : TSRB ;
    US : TUOS_String ;

begin
    SRB.Buffer := Address ;
    SRB.Length := Len ;
    US := Get_User_String( Kernel, PID, SRB, Status ) ;
    Result := '' ;
    if( ( US <> nil ) and ( Status = 0 ) ) then
    begin
        Result := trim( US.Contents ) ;
    end ;
    US.Free ;
end ;

This function obtains a string specified by an address and length. We construct a TSRB structure and use the Get_User_String function to obtain the string.

function Append_Path( S1, S2 : string ) : string ;

begin
    if( ( S1 <> '' ) and ( S2 <> '' ) ) then
    begin
        if( ( copy( S2, 1, 1 ) <> '\' ) and ( copy( S1, length( S1 ), 1 ) <> '\' ) ) then
        begin
            S1 := S1 + '\' ;
        end ;
    end ;
    Result := S1 + S2 ;
end ;

This function appends two parts of a path, making sure that the parts are combined with a single backslash.

That finishes our F$FILE_ATTRIBUTES and SYS_DISPLAY code for the time being. In the next article, we'll look at the next lexical function.