home *** CD-ROM | disk | FTP | other *** search
/ World of Shareware - Software Farm 2 / wosw_2.zip / wosw_2 / PASCAL / NKTOOLS.ZIP / LOGGER.PAS < prev    next >
Pascal/Delphi Source File  |  1991-02-11  |  14KB  |  351 lines
  1. unit Logger;
  2. (*===================================================================*\
  3. || MODULE NAME:  Logger                                              ||
  4. || DEPENDENCIES: System, Dos                                         ||
  5. || LAST MOD ON:  9102.11                                             ||
  6. || PROGRAMMER:   Naoto Kimura                                        ||
  7. ||                                                                   ||
  8. ||     This is an attempt to try to make a unit that will allow me   ||
  9. || create a log of the input and output without having to            ||
  10. || reimplement the CRT unit.                                         ||
  11. ||                                                                   ||
  12. || REFERENCE                                                         ||
  13. || MATERIALS:    Turbo Pascal User's Manual                          ||
  14. ||                     Borland International                         ||
  15. ||               INTERRUP.LST text file obtained through UseNet      ||
  16. ||                     Ralf Brown (ralf@cs.cmu.edu)                  ||
  17. \*===================================================================*)
  18. interface
  19.  
  20. uses dos;
  21.  
  22. implementation
  23.  
  24. {$F+}
  25. type
  26.     LogRec    = record
  27.         Unused        : array [1..8] of byte;
  28.         LogFileRec    : ^TextRec;
  29.         OldInOutFunc    : pointer
  30.         end;
  31.  
  32. (*-------------------------------------------------------------------*\
  33. | The following is used for performing an indirect call to an I/O     |
  34. | routine used by the text file driver.                               |
  35. \*-------------------------------------------------------------------*)
  36. {$IFDEF VER40}
  37. const
  38.     IndirectAddr    : pointer    = NIL;
  39.  
  40. {static far} function PerformIO (var f : TextRec) : integer;
  41.     inline($FF/$1E/IndirectAddr);    {CALL  [IndirectAddr]}
  42. {$ELSE}
  43. type
  44.     IOfunction    = function (var f : TextRec) : integer;
  45. {$ENDIF}
  46.  
  47. (*-------------------------------------------------------------------*\
  48. | NAME:  OutputToLog                                                  |
  49. |                                                                     |
  50. |     This private routine is used to output stuff to the log file.   |
  51. |                                                                     |
  52. | EXTERNALS:  type     registers (Dos), TextRec (Dos)                 |
  53. \*-------------------------------------------------------------------*)
  54. {static} procedure OutputToLog(
  55.     var f    : TextRec;
  56.     var Dat    : pointer;
  57.         Len    : word     );
  58.     var
  59.     i    : word;
  60.     result    : integer;
  61.     begin
  62.     with f do begin
  63.         i := 0;
  64.         while i < Len do begin
  65.         if BufPos >= BufSize then begin
  66. {$IFDEF VER40}
  67.             IndirectAddr := InOutFunc;
  68.             result := PerformIO(f);
  69. {$ELSE}
  70.             result := IOfunction(InOutFunc)(f)
  71. {$ENDIF}
  72.           end;
  73.         BufPtr^[BufPos] := TextBuf(Dat^)[i];
  74.         inc(BufPos);
  75.         inc(i)
  76.           end;
  77.         if f.BufPos >= f.BufSize then begin
  78. {$IFDEF VER40}
  79.         IndirectAddr := InOutFunc;
  80.         result := PerformIO(f)
  81. {$ELSE}
  82.         result := IOfunction(f.InOutFunc)(f)
  83. {$ENDIF}
  84.           end
  85.       end
  86.     end;    (* OutputToLog *)
  87.  
  88. (*-------------------------------------------------------------------*\
  89. | NAME:  LogOutput                                                    |
  90. |                                                                     |
  91. |     This is the routine to send output to both the standard output  |
  92. | handle and the log file.   This procedure is only used if logging   |
  93. | is to be performed.                                                 |
  94. |                                                                     |
  95. | EXTERNALS:  type     registers (Dos), TextRec (Dos)                 |
  96. \*-------------------------------------------------------------------*)
  97. {static far} function LogOutput(var f : TextRec) : integer;
  98.     const
  99.     NumChrs    : word        = 0;
  100.     result    : integer    = 0;
  101.     begin
  102.     with f,LogRec(UserData) do begin
  103.         NumChrs := BufPos;
  104. {$IFDEF VER40}
  105.         IndirectAddr := OldInOutFunc;
  106.         result := PerformIO(f);
  107. {$ELSE}
  108.         result := IOfunction(OldInOutFunc)(f);
  109. {$ENDIF}
  110.         OutputToLog(LogFileRec^,pointer(BufPtr),NumChrs)
  111.       end;
  112.     LogOutput := result
  113.     end;   (* LogOutput *)
  114.  
  115. (*-------------------------------------------------------------------*\
  116. | NAME:  LogInput                                                     |
  117. |                                                                     |
  118. |     This is the routine that handles input in the Logger unit.  It  |
  119. | calls the original input routine to perform input, then calls the   |
  120. | appropriate routine to log input to the log file.                   |
  121. |                                                                     |
  122. | EXTERNALS:  type     registers (Dos), TextRec (Dos)                 |
  123. \*-------------------------------------------------------------------*)
  124. {static far} function LogInput (var f : TextRec) : integer;
  125.     var
  126.     result    : integer;
  127.     begin
  128.     with f,LogRec(UserData) do begin
  129. {$IFDEF VER40}
  130.         IndirectAddr := OldInOutFunc;
  131.         result := PerformIO(f);
  132. {$ELSE}
  133.         result := IOfunction(OldInOutFunc)(f);
  134. {$ENDIF}
  135.         OutputToLog(LogFileRec^,pointer(BufPtr),BufEnd)
  136.       end;
  137.     LogInput := Result
  138.     end;   (* LogInput *)
  139.  
  140. (*-------------------------------------------------------------------*\
  141. | NAME:  LogIgnore                                                    |
  142. |                                                                     |
  143. | This routine is used to perform a do-nothing function, usually for  |
  144. | don't care conditions that may occur during I/O.  This is an        |
  145. | internal service routine and will not be directly used by any       |
  146. | procedure outside of this unit.                                     |
  147. |                                                                     |
  148. | EXTERNALS:  type     TextRec (Dos)                                  |
  149. \*-------------------------------------------------------------------*)
  150. {static far} function LogIgnore(var f : TextRec) : integer;
  151.     begin
  152.     LogIgnore := 0
  153.     end;   (* LogIgnore *)
  154.  
  155.  
  156. (*-------------------------------------------------------------------*\
  157. | NAME: OpenLogging                                                   |
  158. |                                                                     |
  159. \*-------------------------------------------------------------------*)
  160. function OpenLogging(var f : TextRec) : integer;
  161.     begin
  162.     with TextRec(f),LogRec(UserData) do begin
  163.         if Mode = fmInput then begin
  164.         InOutFunc := @LogInput;
  165.         FlushFunc := @LogIgnore
  166.           end
  167.         else begin
  168.         Mode := fmOutput;
  169.         InOutFunc := @LogOutput;
  170.         FlushFunc := @LogOutput
  171.           end
  172.       end;
  173.     OpenLogging := 0
  174.     end;    (* OpenLogging *)
  175.  
  176. (*-------------------------------------------------------------------*\
  177. | NAME: CloseLogging                                                  |
  178. |                                                                     |
  179. \*-------------------------------------------------------------------*)
  180. function CloseLogging(var f : TextRec) : integer;
  181.     begin
  182.     CloseLogging := 0
  183.     end;    (* CloseLogging *)
  184.  
  185. (*-------------------------------------------------------------------*\
  186. | NAME: AssignLogging                                                 |
  187. |                                                                     |
  188. \*-------------------------------------------------------------------*)
  189. procedure AssignLogging(
  190.     var IO_File,
  191.         LogFile    : text);
  192.     begin
  193.     with TextRec(IO_File) do begin
  194.         Mode     := fmClosed;
  195.         BufSize  := SizeOf(Buffer);
  196.         BufPtr   := @Buffer;
  197.         OpenFunc := @OpenLogging;
  198.         with LogRec(UserData) do begin
  199.         LogFileRec    := @TextRec(LogFile);
  200.         OldInOutFunc    := InOutFunc;
  201.           end;
  202.       end
  203.     end;    (* AssignLogging *)
  204.  
  205. var
  206.     LogFile    : text;
  207.     OldExitProc    : Pointer;
  208.  
  209. {static far} procedure Cleanup;
  210.     begin
  211.     ExitProc := OldExitProc;
  212.     close(LogFile)
  213.     end;
  214.  
  215. const
  216.     DefaultAns    = 'S';
  217.     CopyRight    : array [1..224] of char = (
  218.     ^M,^J,#201,#205,#205,#205,#205,#205,#205,#205,#205,#205,#205,
  219.     #205,#205,#205,#205,#205,#205,#205,#205,#205,#205,#205,#205,
  220.     #205,#205,#205,#205,#205,#205,#205,#205,#205,#205,#205,#205,
  221.     #205,#205,#205,#205,#205,#205,#205,#205,#205,#205,#205,#205,
  222.     #205,#205,#205,#205,#205,#205,#205,#205,#205,#205,#205,#205,
  223.     #205,#205,#205,#205,#205,#205,#205,#205,#205,#205,#205,#205,
  224.     #187,^M,^J,#186,' ','L','O','G','G','E','R',' ',' ',' ',' ',
  225.     ' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',
  226.     ' ',' ',' ',' ',' ','C','o','p','y','r','i','g','h','t',' ',
  227.     '0','2','/','1','1','/','1','9','9','1',' ','(','c',')',' ',
  228.     ' ','N','a','o','t','o',' ','K','i','m','u','r','a',' ',
  229.     #186,^M,^J,#200,#205,#205,#205,#205,#205,#205,#205,#205,
  230.     #205,#205,#205,#205,#205,#205,#205,#205,#205,#205,#205,#205,
  231.     #205,#205,#205,#205,#205,#205,#205,#205,#205,#205,#205,#205,
  232.     #205,#205,#205,#205,#205,#205,#205,#205,#205,#205,#205,#205,
  233.     #205,#205,#205,#205,#205,#205,#205,#205,#205,#205,#205,#205,
  234.     #205,#205,#205,#205,#205,#205,#205,#205,#205,#205,#205,#205,
  235.     #205,#205,#188,^M,^J );
  236.  
  237.     Choices    : array [1..165] of char    = (
  238.     ^M,^J,' ','S','e','l','e','c','t',' ','o','n','e',' ','o','f',
  239.     ' ','t','h','e',' ','f','o','l','l','o','w','i','n','g',':',^M,
  240.     ^J,^M,^J,' ',' ',' ',' ',' ',' ','S',' ',' ',' ',' ',' ',' ',
  241.     's','c','r','e','e','n',' ','o','n','l','y',^M,^J,' ',' ',' ',
  242.     ' ',' ',' ','P',' ',' ',' ',' ',' ',' ','s','c','r','e','e',
  243.     'n',' ','a','n','d',' ','p','r','i','n','t','e','r',^M,^J,' ',
  244.     ' ',' ',' ',' ',' ','F',' ',' ',' ',' ',' ',' ','s','c','r',
  245.     'e','e','n',' ','a','n','d',' ','f','i','l','e',^M,^J,^M,^J,
  246.     ' ',' ','P','l','e','a','s','e',' ','e','n','t','e','r',' ',
  247.     's','e','l','e','c','t','i','o','n',' ','(','d','e','f','a',
  248.     'u','l','t','=',DefaultAns,')',' ',':',' ' );
  249.  
  250.     FilePrompt    : array [1..26] of char    = (
  251.     ^M,^J,' ',' ','E','n','t','e','r',' ','L','o','g',' ','f','i',
  252.     'l','e',' ','n','a','m','e',' ',':',' '  );
  253.  
  254.     ErrMsgBeg    : array [1..25] of char    = (
  255.     ^M,^J,^G,'C','a','n','n','o','t',' ','w','r','i','t','e',' ',
  256.     't','o',' ','f','i','l','e',' ','"' );
  257.     ErrMsgEnd    : array [1..30] of char    = (
  258.     '"','!',' ',' ','N','o',' ','l','o','g','g','i','n','g',' ',
  259.     'w','i','l','l',' ','b','e',' ','d','o','n','e','.',^M,^J );
  260.  
  261.     StartMsg    : array [1..32] of char    = (
  262.     ^M,^J,'-','-',' ','P','r','o','g','r','a','m',' ','e','x','e',
  263.     'c','u','t','i','o','n',' ','b','e','g','i','n','s',' ','-','-'
  264.     );
  265.  
  266. var
  267.     StdCon    : text;
  268.     LogFileName    : string;
  269.     Choice    : char;
  270.     DoLogging    : boolean;
  271.  
  272. begin
  273.     assign(StdCon,'con');    reset(StdCon);
  274.     inline( $B8/$4000/        {  mov  ax,4000H            }
  275.         $BB/$02/$00/    {  mov  bx,StdErr           }
  276.         $B9/$E0/$00/    {  mov  cx,CopyRightLen     }
  277.         $BA/CopyRight/    {  mov  dx,OFFSET CopyRight }
  278.         $CD/$21);        {  int  21h                 }
  279.     repeat
  280.     inline(    $B8/$4000/    {  mov  ax,4000H            }
  281.         $BB/$02/$00/    {  mov  bx,StdErr           }
  282.         $B9/$A5/$00/    {  mov  cx,ChoicesLen       }
  283.         $BA/Choices/    {  mov  dx,OFFSET Choices   }
  284.         $CD/$21);    {  int  21h                 }
  285.     if not (eoln(StdCon) or eof(StdCon)) then
  286.         readln(StdCon,Choice)
  287.     else begin
  288.         Choice := DefaultAns;
  289.         if not eof(StdCon) then readln(StdCon)
  290.       end
  291.     until Choice in ['S','s','P','p','F','f'];
  292.     case Choice of
  293.     'S','s':DoLogging := FALSE;
  294.     'P','p':begin
  295.         LogFileName := 'LPT1';
  296.         DoLogging := TRUE;
  297.         end;
  298.     'F','f':begin
  299.         inline(    $B8/$4000/    {  mov  ax,4000H             }
  300.             $BB/$02/$00/    {  mov  bx,StdErr            }
  301.             $B9/$1A/$00/    {  mov  cx,FilePrompt        }
  302.             $BA/FilePrompt/    {  mov  dx,OFFSET FilePrompt }
  303.             $CD/$21);    {  int  21h                  }
  304.         DoLogging := not SeekEoln(StdCon);
  305.         readln(StdCon,LogFileName)
  306.         end
  307.     end;
  308.     if DoLogging then begin
  309.     assign(LogFile,LogFileName);
  310.     {$I-}
  311.     rewrite(LogFile);
  312.     {$I+}
  313.     if IOresult <> 0 then begin
  314.         inline( $B8/$4000/        {  mov  ax,4000H             }
  315.             $BB/$02/$00/    {  mov  bx,StdErr            }
  316.             $B9/$19/$00/    {  mov  cx,ErrMsgBeg         }
  317.             $BA/ErrMsgBeg/    {  mov  dx,OFFSET ErrMsgBeg  }
  318.             $CD/$21/        {  int  21h                  }
  319.                     {;-- Write file name         }
  320.             $B8/$4000/        {  mov  ax,4000H             }
  321.             $BB/$02/$00/    {  mov  bx,StdErr            }
  322.             $BA/LogFileName/    {  mov  dx,OFFSET LogFileName}
  323.             $8B/$FA/        {  mov  di,dx                }
  324.             $33/$C9/        {  xor  cx,cx                }
  325.             $8A/$0D/        {  mov  cx,[di]              }
  326.             $42/        {  inc  dx                   }
  327.             $CD/$21/        {  int  21h                  }
  328.                     {;-- Finish err msg          }
  329.             $B8/$4000/        {  mov  ax,4000H             }
  330.             $BB/$02/$00/    {  mov  bx,StdErr            }
  331.             $B9/$1E/$00/    {  mov  cx,ErrMsgEnd         }
  332.             $BA/ErrMsgEnd/    {  mov  dx,OFFSET ErrMsgEnd  }
  333.             $CD/$21)        {  int  21h                  }
  334.       end
  335.     else begin
  336.         OldExitProc := ExitProc;
  337.         ExitProc := @Cleanup;
  338.         AssignLogging( input, LogFile );
  339.         reset(input);
  340.         AssignLogging( output, LogFile );
  341.         rewrite(output)
  342.       end
  343.       end;
  344.     inline( $B8/$4000/        {  mov  ax,4000H            }
  345.         $BB/$02/$00/    {  mov  bx,StdErr           }
  346.         $B9/$20/$00/    {  mov  cx,StartMsgLen      }
  347.         $BA/StartMsg/    {  mov  dx,OFFSET StartMsg  }
  348.         $CD/$21);        {  int  21h                 }
  349.     close(StdCon)
  350. end.
  351.