home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / PROG / PASCAL / STREAM13.ZIP / XMSSTRM.INC < prev   
Encoding:
Text File  |  1992-05-05  |  9.3 KB  |  363 lines
  1. { This include file is a slightly modified version of XMSSTRM.PAS, by Stefan
  2.   Boether, included here with his kind permission. -djm }
  3.  
  4.   (*****************************************************************************)
  5.   (*                                                                           *)
  6.   (*        Filename        : XMSSTRM.INC                                      *)
  7.   (*        Autor           : Stefan Boether / Compuserve Id : 100023,275      *)
  8.   (*        System          : TURBO 6.00 / MS-DOS 3.2 / Netzwerk               *)
  9.   (*        Aenderung       :                                                  *)
  10.   (*        wann     was                                                wer    *)
  11.   (*---------------------------------------------------------------------------*)
  12.   (*        22.03.92 Error fixed with NewBlock and UsedBlocks           Stefc  *)
  13.   (*        28.04.92 Size field added, BlockSize made constant          DJM    *)
  14.   (*****************************************************************************)
  15.   (*        Beschreibung:  Object for an Stream in XMS-Memory                  *)
  16.   (*****************************************************************************)
  17.   {Header-End}
  18.  
  19. {!!!!!!!!!!!!!!!
  20.  program Test;
  21.  
  22.  uses objects, XmsStrm;
  23.  
  24.  var T : TXmsStream;
  25.      P : PString;
  26.  
  27. begin
  28.    writeln( xms_MaxAvail, ' ', xms_MemAvail );
  29.    T.Init(  20 );
  30.    T.WriteStr( NewStr( 'Hello' ));
  31.    T.WriteStr( NewStr( 'World' ));
  32.    T.Seek( 0 );
  33.    P := T.ReadStr;
  34.    writeln( P^ );
  35.    P := T.ReadStr;
  36.    writeln( P^ );
  37.    T.Done;
  38. end.
  39.  
  40. !!!!!!!!!!!!!!!!}
  41.  
  42. var xms_IOsts : Byte;
  43.   xms_Addr : Pointer;
  44.  
  45. const
  46.   xms_Initialized : Boolean = False;
  47.   { This allows us to avoid a unit initialization section }
  48.  
  49.   xms_BlockSize = 1024;
  50.  
  51.   { - Some Xms - Procedures that I need ! -}
  52.  
  53.   (* /////////////////////////////////////////////////////////////////////// *)
  54.  
  55.   procedure MoveMem(ToAddress : Pointer; ToHandle : Word;
  56.                     FromAddress : Pointer; FromHandle : Word;
  57.                     Size : LongInt);
  58.   begin
  59.     asm
  60.       mov     ah,$0B
  61.       lea     si,Size
  62.       push    ds
  63.       pop     es
  64.       push    ss
  65.       pop     ds
  66.       call    es:[xms_Addr]
  67.       push    es
  68.       pop     ds
  69.       or      ax,ax
  70.       jnz     @@1
  71.       mov     byte ptr xms_IOsts,bl
  72. @@1:
  73.     end;
  74.   end;
  75.  
  76.   (* /////////////////////////////////////////////////////////////////////// *)
  77.  
  78.   function GetByte(Handle : Word; FromAddress : LongInt) : Byte;
  79.   var TempBuf : array[0..1] of Byte;
  80.   begin
  81.     MoveMem(@TempBuf, 0, Pointer(FromAddress and $FFFFFFFE), Handle, 2);
  82.     GetByte := TempBuf[FromAddress and $00000001];
  83.   end;
  84.  
  85.   (* /////////////////////////////////////////////////////////////////////// *)
  86.  
  87.   procedure SetByte(Handle : Word; ToAddress : LongInt; Value : Byte);
  88.   var TempBuf : array[0..1] of Byte;
  89.   begin
  90.     MoveMem(@TempBuf, 0, Pointer(ToAddress and $FFFFFFFE), Handle, 2);
  91.     TempBuf[ToAddress and $00000001] := Value;
  92.     MoveMem(Pointer(ToAddress and $FFFFFFFE), Handle, @TempBuf, 0, 2);
  93.   end;
  94.  
  95.   (* /////////////////////////////////////////////////////////////////////// *)
  96.  
  97.   procedure xms_Init;
  98.   begin
  99.     if not xms_Initialized then
  100.     begin
  101.       xms_IOsts := 0;
  102.       xms_Addr := nil;
  103.       asm
  104.         mov     ax,$4300
  105.         int     $2F
  106.         cmp     al,$80
  107.         jne     @@1
  108.         mov     ax,$4310
  109.         int     $2F
  110.         mov     word ptr xms_Addr,bx
  111.         mov     word ptr xms_Addr+2,es
  112.         jmp     @@2
  113. @@1:
  114.         mov     byte ptr xms_IOsts,$80
  115. @@2:
  116.       end;
  117.       if xms_IOsts = 0 then
  118.         xms_Initialized := True;
  119.     end;
  120.   end;
  121.  
  122.   (* /////////////////////////////////////////////////////////////////////// *)
  123.  
  124.   function xms_GetMem(KB : Word) : Word; Assembler;
  125.   asm
  126.     mov     ah,$09
  127.     mov     dx,word ptr KB
  128.     call    [xms_Addr]
  129.     or      ax,ax
  130.     jz      @@1
  131.     mov     ax,dx
  132.     jmp     @@2
  133. @@1:
  134.     mov     byte ptr xms_IOsts,bl
  135. @@2:
  136.   end;
  137.  
  138.   (* /////////////////////////////////////////////////////////////////////// *)
  139.  
  140.   procedure xms_FreeMem(Handle : Word);
  141.   begin
  142.     asm
  143.       mov     ah,$0A
  144.       mov     dx,word ptr Handle
  145.       call    [xms_Addr]
  146.       or      ax,ax
  147.       jnz     @@1
  148.       mov     byte ptr xms_IOsts,bl
  149. @@1:
  150.     end;
  151.   end;
  152.  
  153.   (* /////////////////////////////////////////////////////////////////////// *)
  154.  
  155.   procedure xms_ResizeMem(Size, Handle : Word);
  156.   begin
  157.     asm
  158.       mov     ah,$0F
  159.       mov     bx,word ptr Size
  160.       mov     dx,word ptr Handle
  161.       call    [xms_Addr]
  162.       or      ax,ax
  163.       jnz     @@1
  164.       mov     byte ptr xms_IOsts,bl
  165. @@1:
  166.     end;
  167.   end;
  168.  
  169.   (* /////////////////////////////////////////////////////////////////////// *)
  170.  
  171.   procedure xms_MoveFrom(Size, Handle : Word; FromAddress : LongInt;
  172.                          ToAddress : Pointer);
  173.   type ByteArr = array[0..MaxInt] of Byte;
  174.     BytePtr = ^ByteArr;
  175.   begin
  176.     if Size = 0 then Exit;
  177.     if Odd(FromAddress) then begin
  178.       BytePtr(ToAddress)^[0] := GetByte(Handle, FromAddress);
  179.       if xms_IOsts <> 0 then Exit;
  180.       Dec(Size);
  181.       Inc(FromAddress);
  182.       Inc(LongInt(ToAddress));
  183.     end;
  184.     MoveMem(ToAddress, 0, Pointer(FromAddress), Handle, Size and $FFFE);
  185.     if xms_IOsts <> 0 then Exit;
  186.     if Odd(Size)
  187.     then BytePtr(ToAddress)^[Size-1] := GetByte(Handle, FromAddress+Size-1);
  188.     if xms_IOsts <> 0 then Exit;
  189.   end;
  190.  
  191.   (* /////////////////////////////////////////////////////////////////////// *)
  192.  
  193.   procedure xms_MoveTo(Size, Handle : Word; FromAddress : Pointer;
  194.                        ToAddress : LongInt);
  195.   type ByteArr = array[0..MaxInt] of Byte;
  196.     BytePtr = ^ByteArr;
  197.   begin
  198.     if Size = 0 then Exit;
  199.     if Odd(ToAddress) then begin
  200.       SetByte(Handle, ToAddress, BytePtr(FromAddress)^[0]);
  201.       if xms_IOsts <> 0 then Exit;
  202.       Dec(Size);
  203.       Inc(LongInt(FromAddress));
  204.       Inc(ToAddress);
  205.     end;
  206.     MoveMem(Pointer(ToAddress), Handle, FromAddress, 0, Size and $FFFE);
  207.     if xms_IOsts <> 0 then Exit;
  208.     if Odd(Size)
  209.     then SetByte(Handle, ToAddress+Size-1, BytePtr(FromAddress)^[Size-1]);
  210.     if xms_IOsts <> 0 then Exit;
  211.   end;
  212.  
  213.   (* /////////////////////////////////////////////////////////////////////// *)
  214.  
  215.   constructor TXMSStream.Init(AMaxBlocks : Word);
  216.   begin
  217.     TStream.Init;
  218.     xms_Init;
  219.  
  220.     MaxBlocks := AMaxBlocks;
  221.     BlocksUsed := 0;
  222.     Size := 0;
  223.     Position := 0;
  224.     Handle := 0;
  225.     if xms_IOsts <> $00 then
  226.       Error(stInitError, xms_IOsts)
  227.     else
  228.     begin
  229.       Handle := xms_GetMem(1);
  230.       if xms_IOsts <> $00 then
  231.         Error(stInitError, xms_IOsts)
  232.       else
  233.         BlocksUsed := 1;
  234.     end;
  235.   end;
  236.  
  237.   function TXMSStream.GetPos : LongInt;
  238.   begin
  239.     GetPos := Position;
  240.   end;
  241.  
  242.   function TXMSStream.GetSize : LongInt;
  243.   begin
  244.     GetSize := Size;
  245.   end;
  246.  
  247.   procedure TXMSStream.Read(var Buf; Count : Word);
  248.   begin
  249.     if Status = stOK then
  250.       if Position+Count > Size then
  251.         Error(stReaderror, 0)
  252.       else
  253.       begin
  254.         xms_MoveFrom(Count, Handle, Position, @Buf);
  255.         if xms_IOsts <> 0 then
  256.           Error(stReaderror, xms_IOsts)
  257.         else
  258.           Inc(Position, Count);
  259.       end;
  260.   end;
  261.  
  262.   procedure TXMSStream.Seek(Pos : LongInt);
  263.   begin
  264.     if Status = stOK then
  265.       if Pos >= Size then
  266.         Error(stReaderror, Pos)
  267.       else
  268.         Position := Pos;
  269.   end;
  270.  
  271.   procedure TXMSStream.Truncate;
  272.   begin
  273.     if Status = stOK then
  274.     begin
  275.       Size := Position;
  276.       while (BlocksUsed > (Size div xms_BlockSize+1)) do FreeBlock;
  277.     end;
  278.   end;
  279.  
  280.   procedure TXMSStream.Write(var Buf; Count : Word);
  281.   begin
  282.     while (Status = stOK)
  283.     and (Position+Count >= LongMul(xms_BlockSize, BlocksUsed)) do
  284.       NewBlock;
  285.     if Status = stOK then
  286.     begin
  287.       xms_MoveTo(Count, Handle, @Buf, Position);
  288.       if xms_IOsts <> 0 then
  289.         Error(stWriteError, xms_IOsts)
  290.       else
  291.         Inc(Position, Count);
  292.       if Position > Size then
  293.         Size := Position;
  294.     end;
  295.   end;
  296.  
  297.   procedure TXMSStream.NewBlock;
  298.   begin
  299.     if Succ(BlocksUsed) > MaxBlocks then
  300.       Error(stWriteError, stUsedAll)
  301.     else
  302.     begin
  303.       xms_ResizeMem(Succ(BlocksUsed), Handle);
  304.       if xms_IOsts <> 0 then
  305.         Error(stWriteError, xms_IOsts)
  306.       else
  307.         Inc(BlocksUsed);
  308.     end;
  309.   end;
  310.  
  311.   procedure TXMSStream.FreeBlock;
  312.   begin
  313.     Dec(BlocksUsed);
  314.     xms_ResizeMem(BlocksUsed, Handle);
  315.   end;
  316.  
  317.   function xms_MaxAvail : Word;
  318.   begin
  319.     xms_Init;
  320.     if xms_IOsts = 0 then
  321.     asm
  322.       mov     ah,$08
  323.       call    [xms_Addr]
  324.       mov     @result,ax
  325.       or      ax,ax
  326.       jnz     @@1
  327.       mov     byte ptr xms_IOsts,bl
  328. @@1:
  329.     end
  330.     else
  331.       xms_MaxAvail := 0;
  332.   end;
  333.  
  334.   (* /////////////////////////////////////////////////////////////////////// *)
  335.  
  336.   function xms_MemAvail : Word;
  337.   begin
  338.     xms_Init;
  339.     if xms_IOsts = 0 then
  340.     asm
  341.       mov     ah,$08
  342.       call    [xms_Addr]
  343.       or      ax,ax
  344.       jz      @@1
  345.       mov     @result,dx
  346.       jmp     @@2
  347. @@1:
  348.       mov     byte ptr xms_IOsts,bl
  349. @@2:
  350.     end
  351.     else
  352.       xms_MemAvail := 0;
  353.   end;
  354.  
  355.   destructor TXMSStream.Done;
  356.   begin
  357.     Seek(0);
  358.     Truncate;
  359.     if xms_Initialized then
  360.       xms_FreeMem(Handle);
  361.   end;
  362.  
  363.