home *** CD-ROM | disk | FTP | other *** search
/ Computer Select (Limited Edition) / Computer Select.iso / pcmag / v11n07 / swrite.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-01-05  |  2.4 KB  |  99 lines
  1. {$D-,L-,I-,R-,S-,V-}
  2. Unit SWrite;
  3. (**) INTERFACE (**)
  4.  
  5. PROCEDURE AssignWrite(var F: Text; Size: word;
  6.   Accumulate : Boolean);
  7. FUNCTION GetLastWritten : pChar;
  8. FUNCTION GetLastWrittenC(VAR F : Text) : pChar;
  9.  
  10. (**) IMPLEMENTATION (**)
  11. USES WinDos;
  12.  
  13. VAR _Buffer : pChar;   {Buffer to hold text passed to
  14.                         NewInOutFunc. Size set by user}
  15.  
  16.  
  17.   FUNCTION GetLastWritten : PChar;
  18.   BEGIN
  19.     GetLastWritten := _Buffer;
  20.   END;
  21.  
  22.   FUNCTION GetLastWrittenC(VAR F : Text): PChar;
  23.   BEGIN
  24.     GetLastWrittenC := _Buffer;
  25.     TTextRec (F).BufPos := 0;
  26.   END;
  27.  
  28.   FUNCTION NewOpenFunc(var F: tTextRec): integer; FAR;
  29.   BEGIN
  30.     NewOpenFunc := 104; {file not open for input}
  31.     WITH F DO
  32.       IF Mode=fmOutput THEN {no error if opened with Rewrite}
  33.         NewOpenFunc := 0;
  34.   END;
  35.  
  36.   FUNCTION NewInOutFunc(var F: tTextRec): integer; FAR;
  37.   BEGIN
  38.     WITH F DO
  39.       BEGIN
  40.         _Buffer[BufPos] := #0; {so routines know where string ends}
  41.         BufPos := 0;
  42.       END;
  43.     NewInOutFunc := 0;
  44.   END;
  45.  
  46.   FUNCTION NewInOutFunc2(var F: tTextRec): integer; FAR;
  47.   BEGIN
  48.     WITH F DO _Buffer[BufPos] := #0;
  49.     NewInOutFunc2 := 0;
  50.   END;
  51.  
  52.   FUNCTION NewFlushFunc(var F: tTextRec): integer; FAR;
  53.   BEGIN
  54.     IF F.BufPos>0 THEN
  55.       NewInOutFunc(F); {so that Close will not have to be called
  56.                         to obtain all characters written}
  57.     NewFlushFunc := 0;
  58.   END;
  59.  
  60.   FUNCTION NewFlushFunc2(var F: tTextRec): integer; FAR;
  61.   BEGIN
  62.     IF F.BufPos>0 THEN
  63.       NewInOutFunc2(F); {so that Close will not have to be called
  64.                         to obtain all characters written}
  65.     NewFlushFunc2 := 0;
  66.   END;
  67.  
  68.   FUNCTION NewCloseFunc(var F: tTextRec): integer; FAR;
  69.   BEGIN
  70.     FreeMem(_Buffer,F.BufSize+1);
  71.     NewCloseFunc := 0;
  72.   END;
  73.  
  74.   PROCEDURE AssignWrite(var F: Text; Size: word;
  75.     Accumulate : Boolean);
  76.   BEGIN
  77.     GetMem(_Buffer,Size+1);
  78.     WITH tTextRec(F) DO
  79.       BEGIN
  80.         Mode      := fmClosed;
  81.         BufSize   := Size;
  82.         BufPtr    := pointer(_Buffer);
  83.         OpenFunc  := @NewOpenFunc;
  84.         IF Accumulate THEN
  85.           BEGIN
  86.             InOutFunc := @NewInOutFunc2;
  87.             FlushFunc := @NewFlushFunc2;
  88.           END
  89.         ELSE
  90.           BEGIN
  91.             InOutFunc := @NewInOutFunc;
  92.             FlushFunc := @NewFlushFunc;
  93.           END;
  94.         CloseFunc := @NewCloseFunc;
  95.         Name[0] := #0;
  96.       END;
  97.   END;
  98.  
  99. END.