home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / sampler / 04 / diverse / memfile.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1987-10-18  |  6.0 KB  |  212 lines
  1. {$R-,I+,N-}
  2. PROGRAM Memory_File;
  3.   USES Crt, DOS;
  4. CONST
  5.   BufSiz       = 127;
  6.   UsrSiz       = 4095;
  7.   IO_Invalid   = 6;
  8.   IO_FileFull  = 101;
  9.   IO_NotOpen   = 103;
  10.   IO_NotInput  = 104;
  11.   IO_NotOutput = 105;
  12. TYPE
  13.   FFileBuffer = ARRAY[0..UsrSiz] OF Char;
  14.   FFilePointer = ^FFileBuffer;
  15.   CharBuf = ARRAY[0..BufSiz] OF Char;
  16.   TextRec = RECORD
  17.               Handle    : Word;
  18.               Mode      : Word;
  19.               BufSize   : Word;
  20.               Private   : Word;
  21.               BufPos    : Word;
  22.               BufEnd    : Word;
  23.               BufPtr    : ^CharBuf;
  24.               OpenFunc  : pointer;
  25.               InOutFunc : pointer;
  26.               FlushFunc : pointer;
  27.               CloseFunc : pointer;
  28.               UFilePos  : Word;
  29.               UFileSiz  : Word;
  30.               FileData  : FFilePointer;
  31.               Erased    : boolean;
  32.               UserData  : ARRAY[1..7] OF Byte;
  33.               Name      : ARRAY[0..79] OF Char;
  34.               Buffer    : CharBuf;
  35.             END;
  36. VAR
  37.   UsrFile : Text;
  38.   line    : STRING[255];
  39.  
  40.   {$F+} {Make routines with FAR calls from here on}
  41.   FUNCTION UsrIgnore(VAR F : TextRec) : Integer;
  42.   BEGIN
  43.     UsrIgnore := 0;
  44.   END;
  45.  
  46.   FUNCTION UsrInput(VAR F : TextRec) : Integer;
  47.     FUNCTION Min(A, B : Word) : Word;
  48.     BEGIN
  49.       IF A < B THEN Min := A ELSE Min := B;
  50.     END;
  51.   BEGIN
  52.     UsrInput := 0;
  53.     WITH F DO
  54.       IF Mode = fmClosed THEN UsrInput := IO_NotOpen
  55.       ELSE IF Mode = fmInput THEN
  56.         BEGIN
  57.           IF UFilePos >= UFileSiz THEN
  58.             BEGIN
  59.               BufEnd := 0;
  60.               BufPos := 0;
  61.             END
  62.           ELSE
  63.             BEGIN
  64.               BufEnd := Min(UFileSiz-UFilePos, BufSiz);
  65.               Move(FileData^[UFilePos], BufPtr^, BufEnd);
  66.               UFilePos := UFilePos+BufEnd;
  67.               BufPos := 0;
  68.             END;
  69.         END
  70.       ELSE IF Mode = fmOutput THEN UsrInput := IO_NotOutput
  71.       ELSE UsrInput := IO_Invalid;
  72.   END;
  73.  
  74.   FUNCTION UsrOutput(VAR F : TextRec) : Integer;
  75.   BEGIN
  76.     UsrOutput := 0;
  77.     WITH F DO
  78.       IF Mode = fmClosed THEN UsrOutput := IO_NotOpen
  79.       ELSE IF Mode = fmOutput THEN
  80.         BEGIN
  81.           IF UFilePos+BufPos >= UsrSiz THEN UsrOutput := IO_FileFull
  82.           ELSE
  83.             BEGIN
  84.               Move(BufPtr^, FileData^[UFilePos], BufPos);
  85.               UFilePos := UFilePos+BufPos;
  86.               IF UFilePos > UFileSiz THEN UFileSiz := UFilePos;
  87.               BufPos := 0;
  88.             END;
  89.         END
  90.       ELSE IF Mode = fmInput THEN UsrOutput := IO_NotInput
  91.       ELSE UsrOutput := IO_Invalid;
  92.   END;
  93.  
  94.   FUNCTION UsrOpen(VAR F : TextRec) : Integer;
  95.   BEGIN
  96.     UsrOpen := 0;
  97.     WITH F DO
  98.       IF Mode = fmInput THEN
  99.         (* ==================================== *)
  100.         (* RESET :  open for input from the     *)
  101.         (* "file".  If size is 0, say the file  *)
  102.         (* doesn't exist.  Otherwise, set InOut *)
  103.         (* for INPUT and put the FilePos at 0.  *)
  104.         (* ==================================== *)
  105.         BEGIN
  106.           IF erased THEN UsrOpen := IO_NotInput
  107.           ELSE
  108.             BEGIN
  109.               FlushFunc := @UsrIgnore;
  110.               InOutFunc := @UsrInput;
  111.               UFilePos := 0;
  112.             END;
  113.         END
  114.       ELSE IF Mode = fmOutput THEN
  115.         (* ==================================== *)
  116.         (* REWRITE -- open for output TO the    *)
  117.         (* "file".  Set FileSize and FilePos to *)
  118.         (* 0 and allocate space for the file's  *)
  119.         (* data to reside in                    *)
  120.         (* ==================================== *)
  121.         BEGIN
  122.           UFileSiz := 0;
  123.           UFilePos := 0;
  124.           IF erased THEN
  125.             BEGIN
  126.               erased := false;
  127.               New(FileData);
  128.             END;
  129.           InOutFunc := @UsrOutput;
  130.           FlushFunc := @UsrOutput;
  131.         END
  132.       ELSE IF Mode = fmInOut THEN
  133.         (* ==================================== *)
  134.         (* APPEND -- if the file doesn't exist  *)
  135.         (* yet, say so.  Otherwise, point the   *)
  136.         (* FilePos at the FileSize, so new      *)
  137.         (* WRITE statements will append to the  *)
  138.         (* "file"                               *)
  139.         (* ==================================== *)
  140.         BEGIN
  141.           IF erased THEN UsrOpen := IO_NotOutput
  142.           ELSE
  143.             BEGIN
  144.               UFilePos := UFileSiz;
  145.               InOutFunc := @UsrOutput;
  146.               FlushFunc := @UsrOutput;
  147.               Mode := fmOutput;
  148.             END;
  149.         END
  150.       ELSE UsrOpen := IO_Invalid;
  151.   END;
  152.  
  153.   {$F-} {Stop making routines with FAR calls}
  154.  
  155.   PROCEDURE EraseUsr(VAR F : Text);
  156.   BEGIN
  157.     WITH TextRec(F) DO
  158.       BEGIN
  159.         erased := true;
  160.         dispose(FileData);
  161.         mode := fmClosed;
  162.       END;
  163.   END;
  164.  
  165.  
  166.   PROCEDURE AssignUsr(VAR F : Text);
  167.   BEGIN
  168.     WITH TextRec(F) DO
  169.       BEGIN
  170.         Mode      := fmClosed;
  171.         BufSize   := BufSiz;
  172.         BufPtr    := @buffer;
  173.         OpenFunc  := @UsrOpen;
  174.         CloseFunc := @UsrIgnore;
  175.         Name[0]   := #0;
  176.         UFileSiz  := 0;
  177.         UFilePos  := 0;
  178.         Erased    := true;
  179.       END;
  180.   END;
  181.  
  182. BEGIN
  183.   ClrScr;
  184.   AssignUsr(UsrFile);
  185.   Rewrite(UsrFile);
  186.   Write(UsrFile, 'I ');
  187.   Write(UsrFile, 'am ', 1.234, ' feet high.');
  188.   WriteLn(UsrFile);
  189.   WriteLn(UsrFile, 'The value of pi is ', Pi:1:11);
  190.   Close(UsrFile);
  191.   Reset(UsrFile);
  192.   WriteLn('I have written some lines to the "fake file".  I can get them');
  193.   WriteLn('back by READING the "fake file" and writing to the screen.');
  194.   WriteLn('HERE they come:');
  195.   WHILE NOT(EoF(UsrFile) OR KeyPressed) DO
  196.     BEGIN
  197.       ReadLn(UsrFile, line);
  198.       WriteLn(line);
  199.     END;
  200.   WriteLn;
  201.   WriteLn('Now going to APPEND -- ...');
  202.   Append(UsrFile);
  203.   WriteLn(UsrFile, 'What is 1/4 of pi? Is it ', Pi/4:1:11, '?');
  204.   Close(UsrFile);
  205.   Reset(UsrFile);
  206.   WHILE NOT(EoF(UsrFile) OR KeyPressed) DO
  207.     BEGIN
  208.       ReadLn(UsrFile, line);
  209.       WriteLn(line);
  210.     END;
  211. END.
  212.