{ÛßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßÛ}
{Û                                                       Û}
{Û      Virtual Pascal Examples  Version 2.1             Û}
{Û      Extended Attributes Class                        Û}
{Û      ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÛ}
{Û      Copyright (C) 1996-2000 vpascal.com              Û}
{Û      Written May 1996 by Allan Mertner                Û}
{Û                                                       Û}
{ßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßß}
{$Delphi+,Use32-}

Unit Os2EA;

{$IFDEF VER10}
//  !! This unit requires a version of Virtual Pascal later than 1.0
{$ENDIF}

interface

uses
  Os2Def, Os2Base, Classes, Strings, SysUtils;

type
  // EA Exception class
  EEAError = class(Exception);

  // tEA class for holding any EA type
  tEA = class( tCollectionItem )
  private
    fLen  : SmallWord;
    fData : Pointer;
    fName : pChar;
    procedure SetNameValue( Name: pChar; Len: Integer; Data: Pointer );
    procedure SetValue( Len: Integer; Data: Pointer );
    function  GetEAName: String;
    procedure SetEAName( s: String );
    procedure SetEANameZ( s: pChar );
  protected
    function GetEAType: SmallWord;
  public
    destructor Destroy; override;

    property EANameZ: pChar                     // Name of EA data, pChar
      read fName write SetEANameZ;
    property EAName: String                     // Name of EA data, String
      read GetEAName write SetEAName;
    property EAData: Pointer read fData;        // Pointer to raw EA data
    property EALength: SmallWord read fLen;     // Length of raw EA data
    property EAType: SmallWord read GetEAType;  // EA Type
    function GetString: String; virtual;        // EA string representation
  end;

  // tEA_Ascii for holding eat_ascii type EA's
  tEA_Ascii = class( tEA )
  private
    function GetStrValue: String;
    procedure SetStrValue( s: String );
    function GetStrValueZ: pChar;
    procedure SetStrValueZ( s: pChar );
  public
    function GetString: String; override;       // EA string representation
    property StringValue: String                // Value of string
      read GetStrValue write SetStrValue;
    property StringValueZ: pChar                // Value of string
      read GetStrValueZ write SetStrValueZ;
  end;

  // tEAList for holding all EA's associated with a file
  tEAList = class( tCollection )
  private
    fName : pChar;
  protected
    function Add( EAClass: TCollectionItemClass ): tCollectionItem;
    function InitNewEA( EAClass: tCollectionItemClass; Name: pChar ): tEA;
  public
    constructor Create( const name : string );
    destructor Destroy; virtual;

    function WriteToFile : ApiRet;              // Write list of EAs to file
    function SearchFor( Name: pChar ): tEA;     // Search for EA by name
    property FileName: pChar                    // FileName of EAs
      read fName write fName;
                                                // Add new EAs to list
    function AddEA( Name: String; Len: Integer; Data: Pointer ): tEA;
    function AddZEA( Name: pChar; Len: Integer; Data: Pointer ): tEA;
                                                // Add new ASCII EAs to list
    function AddAscii( Name: String; Value: String ): tEA_Ascii;
    function AddAsciiZ( Name: String; Value: pChar ): tEA_Ascii;
    function AddZAscii( Name: pChar; Value: String ): tEA_Ascii;
    function AddZAsciiZ( Name: pChar; Value: pChar ): tEA_Ascii;

    procedure RemoveNamedEA( Name: String );    // Remove EA by name
    procedure RemoveEA( EA: tEA );              // Remove specific EA
  end;

implementation

const
  eaopsize = 65000;      // Do not change!
  fea2listsize = 60000;

// Base tEA object

procedure tEA.SetNameValue( Name: pChar; Len: Integer; Data: Pointer );
begin
  SetValue( Len, Data );
  fName := strNew( Name );
end;

procedure tEA.SetValue( Len: Integer; Data: Pointer );
begin
  if fLen <> 0 then
    FreeMem( fData, fLen );
  fLen := Len;
  GetMem( fData, Len );
  move( Data^, fData^, fLen );
end;

destructor tEA.destroy;
begin
  if fData <> nil then
    FreeMem( fData, fLen );
  if fName <> nil then
    strDispose( fName );
  inherited destroy;
end;

function tEA.GetEAType: SmallWord;
begin
  If EAData = nil then
    Result := 0
  else
    Result := SmallWord(EAData^);               // Return EA type
end;

function tEA.GetEAName: String;
begin
  Result := StrPas( EANameZ );
end;

procedure tEA.SetEAName( s: String );
begin
  s := s + #0;
  EANameZ := @s[1];
end;

procedure tEA.SetEANameZ( s: pChar );
begin
  if fName <> nil then
    strDispose( fName );
  fName := StrNew( s );
end;

function tEA.GetString : String;
begin
  case EAType of
    eat_ascii    : Result := 'ASCII';
    eat_icon     : Result := 'Icon';
    eat_bitmap   : Result := 'Bitmap';
    eat_metafile : Result := 'Metafile';
    eat_mvmt     : Result := 'Multi-val mt';
    eat_mvst     : Result := 'Multi-val st';
    eat_binary   : Result := 'Binary';
    eat_ea       : Result := 'EA';
    eat_asn1     : Result := 'Asn1';
  else
    Result := 'Unknown';
  end;
  Result := Format( 'Name: %13s  Type: %13s (%4x) ',
                    [EAName, Result, EAType] );
end;

// tEA_Ascii class

function tEA_Ascii.GetString: String;
begin
  Result := Inherited GetString + StringValue;
end;

function tEA_Ascii.GetStrValue: String;
begin
  Result := strPas( StringValueZ );
  SetLength( Result, EALength-2*Sizeof(SmallWord) );
end;

procedure tEA_Ascii.SetStrValue( s: String );
begin
  s := s + #0;                                  // Append #0
  StringValueZ := @s[1];                        // Set value using Z method
end;

function tEA_Ascii.GetStrValueZ: pChar;
begin
  Result := pChar(EAData)+2*Sizeof(SmallWord);
end;

procedure tEA_Ascii.SetStrValueZ( s: pChar );
var
  p : Pointer;
  sLen: SmallWord;
  NewLen: SmallWord;
begin
  sLen := StrLen(s);
  NewLen := sLen+2*SizeOf(SmallWord);           // New required length
  if fLen <> NewLen then                        // Other size; Realloc
    begin
      ReAllocMem( fData, NewLen );
      fLen := NewLen;
    end;
  p := fData;
  SmallWord( p^ ) := eat_Ascii;                 // set type
  inc( pChar(p), Sizeof(SmallWord) );           // Advance Pointer
  SmallWord( p^ ) := sLen;                      // String length
  inc( pChar(p), Sizeof(SmallWord) );           // Advance pointer
  move( s^, p^, sLen );                         // Copy string
end;

// tEAList class definition

constructor tEAList.Create( const name : string );
var
  PathZ     : Array [ 0..cchMaxPathComp ] of Char;
  FullPathZ : Array [ 0..cchMaxPathComp ] of Char;
  FullNameZ : Array [ 0..cchMaxPathComp ] of Char;
  sr        : FileFindBuf4;
  HDir      : Longint;
  buffer    : Pointer;
  Count     : Longint;
  rc        : ApiRet;
  pEA       : PFea2;
  pEAOP     : pEAop2;
  pFEA      : pFEA2;
  pGEA      : pGEA2;
  offset    : Longint;
  Length    : Longint;
  pEABase   : Pointer;
  EAClass   : tCollectionItemClass;

begin
  inherited Create( tEA );

  // Verify that file exists
  StrPCopy( PathZ, Name );
  DosQueryPathInfo ( PathZ, fil_QueryFullName, FullPathZ, cchMaxPathComp );

  StrECopy( FullNameZ, FullPathZ );
  Count := 1;
  HDir := hdir_System;
  rc := DosFindFirst( PathZ, HDir, file_Directory, sr, SizeOf( sr ), Count, fil_QueryEASize );
  DosFindClose( HDir );
  if rc <> no_Error then
    raise EEAError.CreateFmt( 'File %s not found; rc = %d ', [ Name, rc ] );

  // Set up buffer for list of EA name query
  GetMem( Buffer, sr.cbList );
  Count := -1;
  try
    // Get list of EA names from OS/2
    rc := DosEnumAttribute( enumea_RefType_Path, @FullNameZ, 1, Buffer^, sr.cbList, Count, enumea_Level_No_Value );

    // Reorganize and set up to enumerate values
    pEA := PFEa2( Buffer );
    GetMem( pEAOP, eaopsize );
    try
      pEAOP^.fpGEA2List := Ptr(Longint(pEAOP)+sizeof(EAOP2));
      pGEA := @pEAOP^.fpGEA2List^.List[0];
      offset := 0;

      // Move all EA's to structure for DosQueryPathInfo
      If count <> 0 then
        Repeat
          Inc( ULong( pEA ), offset );
          StrCopy( @pGEA^.szName, @pEA^.szName );
          pGEA^.cbName := pEA^.cbName;
          Offset := pEA^.oNextEntryOffset;
          Length := pGEA^.cbName + Sizeof( pGEA^.cbName ) +
                    sizeof( pGEA^.oNextEntryOffset );
          If length mod 4 <> 0 then
            inc( length, 4-length mod 4 );      // Double word aligned
          If Offset <> 0 then
            pGEA^.oNextEntryOffset := Length
          else
            pGEA^.oNextEntryOffset := 0;

          Inc( ULong( pGEA ), Length );
        Until pEA^.oNextEntryOffset = 0;
      with PEAOP^, PEAOP^.fpGEA2List^ do
        begin
          cbList := pChar(pGEA) - pChar(fpGEA2List);
          fpFEA2List := Ptr( Longint(fpGEA2List) + cbList );
          fpFEA2List^.cbList := eaopsize - (pChar(fpFEA2List) - pChar(pEAOP));
        end;
      // Get list of EA values from OS/2
      rc := DosQueryPathInfo( FullNameZ, fil_QueryEAsFromList, pEAOP^, sizeof( EAOP2 ));

      // Insert data into tEAList class structure
      if ( rc = 0 ) and ( pEAOP^.fpFEA2List^.cbList > 0 ) then
        begin
          Offset := 0;
          pFEA := @pEAOP^.fpFEA2List^.List;
          Repeat
            Inc( ULong( pFEA ), offset );       // Base of this EA
            pEABase := pChar(@pFEA^.szName) + pFEA^.cbName + 1;

            if smallWord( pEABase^ ) = eat_Ascii then
              EAClass := tEA_Ascii              // Create Ascii EA
            else
              EAClass := tEA;                   // Create standard EA
            With Add(EAClass) as tEA do         // Create and add
              SetNameValue( @pFEA^.szName, pFEA^.cbValue, pEABase );
            Offset := pFEA^.oNextEntryOffset;   // Go to next EA in list
          Until Offset = 0;
        end;
        FileName := StrPNew( name );
    finally  // Free memory
      FreeMem( pEAOP, eaopsize );
    end;
  finally
    FreeMem( Buffer, sr.cbList );
  end;
end;

destructor tEAList.Destroy;
begin
  if fName <> nil then
    StrDispose( fName );
  inherited Destroy;
end;

function tEAList.Add( EAClass: TCollectionItemClass ): tCollectionItem;
begin
  Result := EAClass.Create(Self);               // Create specified class
end;

function tEAList.InitNewEA( EAClass: tCollectionItemClass; Name: pChar ): tEA;
begin
  StrUpper( Name );                             // Uppercase EA name
  Result := SearchFor( Name );                  // Search for existing
  If Result = nil then                          // Create new EA entry
    begin
      Result := tEA( Add( EAClass ) );          // Create it
      Result.fName := strNew( Name );           // Assign name
    end;
end;

function tEAList.AddAscii( Name: String; Value: String ): tEA_Ascii;
begin
  Value := Value + #0;
  Result := AddAsciiZ( Name, @Value[1] );       // Add as pChar
end;

function tEAList.AddAsciiZ( Name: String; Value: pChar ): tEA_Ascii;
begin
  Name := Name + #0;
  Result := tEA_Ascii( InitNewEA( tEA_Ascii, @Name[1] ) );
  Result.SetStrValueZ( Value );                 // Set String value
end;

function tEAList.AddZAscii( Name: pChar; Value: String ): tEA_Ascii;
begin
  Value := Value + #0;
  Result := AddZAsciiZ( Name, @Value[1] );       // Add as pChar
end;

function tEAList.AddZAsciiZ( Name: pChar; Value: pChar ): tEA_Ascii;
begin
  Result := tEA_Ascii( InitNewEA( tEA_Ascii, Name ) );
  Result.SetStrValueZ( Value );                 // Set String value
end;

function tEAList.AddEA( Name: String; Len: Integer; Data: Pointer ): tEA;
begin
  Name := Name + #0;
  Result := InitNewEA( tEA, @Name[1] );
  Result.SetValue( Len, Data );
end;

function tEAList.AddZEA( Name: pChar; Len: Integer; Data: Pointer ): tEA;
begin
  Result := InitNewEA( tEA, Name );
  Result.SetValue( Len, Data );
end;

procedure tEAList.RemoveNamedEA( Name: String );
var
  p : tEA;
begin
  Name := Name + #0;
  p := SearchFor( @Name[1] );
  If p <> nil then
    p.Collection := nil;                   // Remove from collection
end;

procedure tEAList.RemoveEA( EA: tEA );
begin
  if Assigned(EA) then
    EA.Collection := nil;                  // Remove from collection
end;

function tEAList.WriteToFile : ApiRet;
  function AddEA( pFEA: pFEA2; EA: tCollectionItem ): pFEA2;
  var
    pData : pChar;
  begin
    with pFEA^, EA as tEA do
      begin
        fEA := 0;                          // EA Flags
        cbName := strLen( EANameZ );       // Name bytecount
        cbValue := EALength;               // Value bytecount
        StrCopy( @szName, EANameZ );       // Copy name
        pData := pChar(@szName)+cbName+1;  // First data byte
        Move( EAData^, pData^, EALength ); // Copy value
        oNextEntryOffset := SizeOf( FEA2 )+cbName+1+cbValue;

        // Address of next entry
        Result := pFEA2( pChar(pFEA)+oNextEntryOffset );
      end;
  end;

var
  EAop : EAOP2;
  pFEA : pFEA2;
  i    : Longint;

begin
  Result := error_invalid_parameter;
  EAop.fpGEA2List := nil;
  GetMem( EAop.fpFEA2List, fea2ListSize );
  try
    pFEA := @EAop.fpFEA2List^.List[0];          // First EA
    For i := 0 to Count-2 do
      pFEA := AddEA( pFEA, Items[i] );          // Add all-1 to list
    AddEA( pFEA, Items[Count-1] );              // Add last item to list
    EAop.fpFEA2List^.cbList :=                  // List bytecount
      pChar(pFEA)+pFEA^.oNextEntryOffset-pChar(EAop.fpFEA2List);
    pFEA^.oNextEntryOffset := 0;                // Terminate list

    Result := DosSetPathInfo( FileName,         // Do the actual EA write
                              fil_QueryEASize, EAop, sizeof(eaop2), 0 );
  finally  // Always free memory
    FreeMem( EAop.fpFEA2List, fea2ListSize );
  end;
end;

function tEAList.SearchFor( Name: pChar ): tEA;
var
  i : Longint;
begin
  Result := nil;
  for i := 0 to Count-1 do
    if StrIComp( tEA(Items[i]).EANameZ, Name ) = 0 then
      begin
        Result := tEA(Items[i]);                // Item found
        Break;
      end;
end;

end.

