home *** CD-ROM | disk | FTP | other *** search
/ RBBS in a Box Volume 1 #3.1 / RBBSIABOX31.cdr / pool / plist2b.pas < prev    next >
Pascal/Delphi Source File  |  1990-09-29  |  17KB  |  484 lines
  1. program PLIST;
  2. (*
  3.   Written by: Rick Schaeffer
  4.               E. 13611 26th Av.
  5.               Spokane, Wa.  99216
  6.  
  7.   modifications (7/8/84  by Len Whitten, CIS: [73545,1006])
  8.      1) added error handling if file not found
  9.      2) added default extension of .PAS to main & include files
  10.      3) added "WhenCreated" procedure to extract file
  11.         creation date & time from TURBO FIB
  12.      4) added demarcation of where include file ends
  13.      5) added upper char. conversion to include file
  14.      6) increased left margin to 5 spaces (80 char. line just fits @ 10cpi)
  15.      7) added listing control: {.L-} turns it off, {.L+} turns it back on,
  16.         must be in column 1
  17.      
  18.   further modifications (7/12/84 by Rick Schaeffer)
  19.      1) cleaned up the command line parsing routines and put them in
  20.         separate procedures.  Now permits any number of command line
  21.         arguments, each argument separated with at least one space.
  22.      2) added support for an optional second command line parameter
  23.         which specifies whether include files will be listed or not.
  24.         The command is invoked by placing "/i" on the command line
  25.         at least one space after the file name to be listed.  For
  26.         instance, to list MYPROG.PAS as well as any "included" files,
  27.         the command line would be: PLIST MYPROG /I
  28.  
  29.    further modification (8/28/84) by Jay Kadashaw)
  30.       1) Restored filedate and filetime after listing an included
  31.          file.
  32.       2) Added comment counter and begin/end counter.
  33.       3) Output can be routed to either the printer or console.
  34.       4) After listing first file the user is prompted for next
  35.          file if any.
  36. *)
  37.  
  38. (* Supported pseudo operations:
  39.     1) Listing control: {.L-} turns it off, {.L+} turns it back on,
  40.        must be in column 1
  41.     2. Page ejection: {.PAGE}, must be in column 1.
  42.     *)
  43.  
  44.  { When program is first run will check for a file
  45.    name passed by DOS, and will try to open that file.  If no name is
  46.    passed, will ask operator for a file name to open.  Proc will tell
  47.    operator if file doesn't exist and will allow multiple retrys.
  48.  
  49.    Included files will be expanded only if the program is invoked as
  50.    follows:
  51.      pretty filename /i
  52.    The default is not to expand included files.
  53.  
  54.    On 2nd and later executions, proc will not check for DOS passed file
  55.    name.  In all cases, proc will assume a file type of .PAS if file
  56.    type is not specified.
  57.    PROGRAM EXIT from this proc when a null string is encountered in
  58.    response to a file name request. }
  59.  
  60. const monthmask = $000F;
  61.   daymask = $001F;
  62.   minutemask = $003F;
  63.   secondmask = $001F;
  64.   First   : boolean = true;    {true when prog is run}
  65.  
  66. { to customize code for your printer - adjust the next item }
  67.  
  68.   maxline = 58;
  69.  
  70.   cr = #13;
  71.   lf = #10;
  72.   ff = #12;
  73.  
  74. type
  75.    two_letters = string[2];
  76.    dtstr = string[8];
  77.    fnmtype = string[14];
  78.    instring = string[135];
  79.    regpack = record
  80.       ax,bx,cx,dx,bp,si,di,ds,es,flags : integer;
  81.    end;
  82.  
  83. Var
  84.   Buff1     : instring;          {input line buffer}
  85.   listfil   : text;              {FIB for LST: or CON: output}
  86.   infile    : text;              {FIB for input file}
  87.   fnam      : fnmtype;           {in file name}
  88.   bcount    : integer;           {begin/end counter}
  89.   kcount    : integer;           {comment counter}
  90.   linect    : integer;           {output file line counter}
  91.   pageno    : integer;
  92.   offset    : integer;
  93.   print     : boolean;           (* {.L-} don't print *)
  94.                                  (* {.L+} print       *)
  95.   print_head : boolean;
  96.   c         : char;
  97.   month, day, year,
  98.   hour, minute, second : two_letters;
  99.   sysdate, systime,
  100.   filedate, filetime : dtstr;
  101.   expand_includes    : boolean;
  102.   holdarg            : instring;
  103.   allregs : regpack;
  104. {.page}
  105. procedure getchar(var char_value : char);
  106.    begin
  107.      allregs.ax := $0000;
  108.      intr($16, allregs);
  109.      char_value := chr(ord(lo(allregs.ax)));
  110.    end; {getchar}
  111.  
  112. procedure fill_blanks (var line: dtstr);
  113.   var
  114.     i : integer;
  115. begin
  116.   for i:= 1 to 8 do if line[i] = ' ' then line[i]:= '0';
  117. end;  {fill_blanks}
  118.  
  119. procedure getdate(var date : dtstr);
  120.  
  121. begin
  122.    allregs.ax := $2A * 256;
  123.    MsDos(allregs);
  124.    str((allregs.dx div 256):2,month);
  125.    str((allregs.dx mod 256):2,day);
  126.    str((allregs.cx - 1900):2,year);
  127.    date := month + '/' + day + '/' + year;
  128.    fill_blanks (date);
  129. end;  {getdate}
  130.  
  131. procedure gettime(var time : dtstr);
  132.  
  133. begin
  134.    allregs.ax := $2C * 256;
  135.    MsDos(allregs);
  136.    str((allregs.cx div 256):2,hour);
  137.    str((allregs.cx mod 256):2,minute);
  138.    str((allregs.dx div 256):2,second);
  139.    time := hour + ':' + minute + ':' + second;
  140.    fill_blanks (time);
  141. end;  {gettime}
  142.  
  143. procedure WhenCreated (var date, time: dtstr; var infile: text);
  144.  
  145. var fulltime,fulldate: integer;
  146.  
  147. begin
  148.  
  149. {fulldate gets the area of the FIB which corresponds to bytes 20-21
  150.  of the FCB. Format is: bits 0 - 4: day of month
  151.                              5 - 8: month of year
  152.                              9 -15: year - 1980                     }
  153.  
  154.     fulldate:= memw [seg(infile):ofs(infile)+31];
  155.     str(((fulldate shr 9) + 80):2,year);
  156.     str(((fulldate shr 5) and monthmask):2,month);
  157.     str((fulldate and daymask):2,day);
  158.     date:= month + '/' + day + '/' + year;
  159.     fill_blanks(date);
  160.  
  161. {fulltime gets the area of the FIB which corresponds to bytes 22-23
  162.  of the FCB. Format is: bits 0 - 4: seconds/2
  163.                              5 -10: minutes
  164.                              11-15: hours                          }
  165.  
  166.     fulltime:= memw [seg(infile):ofs(infile)+33];
  167.     str((fulltime shr 11):2,hour);
  168.     str(((fulltime shr 5) and minutemask):2,minute);
  169.     str(((fulltime and secondmask) * 2):2,second);
  170.     time:= hour + ':' + minute + ':' + second;
  171.     fill_blanks (time);
  172. end;  {WhenCreated}
  173.  
  174. procedure print_heading(filename : fnmtype);
  175.  
  176. var offset_inc: integer;
  177.  
  178. begin
  179.    if print then
  180.      begin
  181.        pageno := pageno + 1;
  182.        write(listfil, ff);  {top of form}
  183.        writeln(listfil);
  184.        write(listfil,'     TURBO Pascal Program Lister');
  185.        writeln(listfil,' ':8,'Printed: ',sysdate,'  ',
  186.                systime,'   Page ',pageno:4);
  187.        if filename <> fnam then begin
  188.           offset_inc:= 14 - length (filename);
  189.           write(listfil,'     Include File: ',filename,' ':offset_inc,
  190.              'Created: ',filedate,'  ',filetime);
  191.        end
  192.        else write(listfil,'     Main File: ',fnam,' ':offset,
  193.              'Created: ',filedate,'  ',filetime);
  194.        writeln(listfil); writeln(listfil);
  195.        writeln(listfil, ' C  B');
  196.        writeln(listfil);
  197.        linect := 6;
  198.      end; {check for print}
  199. end;  {print_heading}
  200.  
  201. procedure printline(iptline : instring; filename : fnmtype);
  202. begin
  203.    if print then
  204.      begin
  205.        if linect < 56 then
  206.          begin
  207.           writeln(listfil,'     ',iptline);
  208.           linect := linect + 1;
  209.          end
  210.           else
  211.            begin
  212.              print_heading(filename);
  213.            end;
  214.      end; {check for print}
  215. end;  {printline}
  216. {.page}
  217. function chkinc(var iptline : instring; var incflname : fnmtype) : boolean;
  218. var
  219.    done : boolean;
  220.    i, j : integer;
  221. begin
  222.    i := 4; j := 1; incflname := '';
  223.    if copy(iptline, 1, 3) = '{$I' then begin
  224.       i := 4; j := 1; incflname := '';
  225.       while (iptline[i] = ' ') and (i <= length(iptline)) do i := i + 1;
  226.       done := false;
  227.       while not done do begin
  228.          if i <= length(iptline) then begin
  229.             if not (iptline[i] in [' ','}','+','-']) then begin
  230.                incflname[j] := iptline[i];
  231.                i := i + 1; j := j + 1;
  232.             end else done := true;
  233.          end else done := true;
  234.          if j > 14 then done := true;
  235.       end;
  236.       incflname[0] := chr(j - 1);
  237.    end;
  238.    if incflname <> '' then chkinc := true else chkinc := false;
  239. end;  {chkinc}
  240.  
  241. function parse_cmd(argno : integer) : instring;
  242. var
  243.    i,j : integer;
  244.    wkstr : instring;
  245.    done : boolean;
  246.    cmdline : ^instring;
  247. begin
  248.    cmdline := ptr(CSEG,$0080);
  249.    wkstr := '';
  250.    done := false; i := 1; j := 0;
  251.    if length(cmdline^) < i then done := true;
  252.    repeat
  253.       while ((cmdline^[i] = ' ') and (not done)) do begin
  254.          i := i + 1;
  255.          if i > length(cmdline^) then done := true;
  256.       end;
  257.       if not done then j := j + 1;
  258.       while ((cmdline^[i] <> ' ') and (not done)) do begin
  259.          wkstr := wkstr + cmdline^[i];
  260.          i := i + 1;
  261.          if i > length(cmdline^) then done := true;
  262.       end;
  263.       if (j <> argno) then wkstr := '';
  264.    until (done or (j = argno));
  265.    for i := 1 to length(wkstr) do
  266.       wkstr[i] := upcase(wkstr[i]); {all arguments forced to upper case}
  267.    parse_cmd := wkstr;
  268. end;
  269.  
  270.  PROCEDURE GET_IN_FILE;     {GETS INPUT FILE NAME }
  271.    var
  272.     existing : boolean;
  273.   begin
  274.     repeat             {until file exists}
  275.       holdarg := parse_cmd(1); {get command line argument # 1}
  276.       if (length(holdarg) in [1..14]) and first then
  277.         fnam := holdarg  {move possible file name to fnam}
  278.       else
  279.         begin
  280.           writeln;
  281.           write(' ENTER FILE NAME TO LIST or <cr> to EXIT  ');
  282.           readln(fnam);
  283.         end;
  284.  
  285.      if fnam = '' then HALT;         {***** EXIT *****}
  286.      if pos('.',fnam) = 0 then       {file type given?}
  287.        fnam := concat(fnam,'.PAS');  {file default to .PAS type}
  288.  
  289.      {get optional command line argument # 2}
  290.      if (length(holdarg) in [1..14]) and first then
  291.        begin
  292.          holdarg := parse_cmd(2);
  293.          if holdarg = '/I' then expand_includes := true
  294.             else expand_includes := false;
  295.        end;
  296.  
  297.      first := false;                 {get passed file name only once}
  298.      assign( infile, fnam);
  299.        {$I-}
  300.      reset( infile );                {check for existence of file}
  301.        {$I+}
  302.      existing := (ioresult = 0);     {true if file found}
  303.      if not existing then
  304.        begin
  305.         writeln;
  306.         writeln(' FILE DOESN''T EXIST'); {tell operator the sad news}
  307.        end;
  308.     until existing;                     {until file exists}
  309.  end; {GET_IN_FILE}
  310.  
  311. { GET_OUT_FILE procedure asks operator to select output to console
  312.   device or list device, and then assigns and resets a file control
  313.   block to the appropriate device.  'C' or 'P' is only correct
  314.   response, and multiple retrys are allowed. }
  315.  
  316. Procedure Get_Out_File;
  317.   var
  318.     c : char;
  319.   begin
  320.     repeat    {until good selection}
  321.       writeln; write(' OUTPUT LISTING TO (C)ONSOLE OR (P)RINTER ?  ');
  322.       getchar(c);
  323.       c := upcase(c); write(c);
  324.    until c in ['C', 'P'];
  325.  
  326.    writeln;
  327.    if c = 'C' then
  328.       assign (listfil, 'CON:')
  329.    else
  330.       assign (listfil, 'LST:');
  331.  
  332.    reset(listfil);
  333.  end;  {GET_OUT_FILE}
  334.  
  335. Procedure ListIt(filename : fnmtype); forward;
  336. {.page}
  337. { SCAN_LINE procedure scans one line of Turbo Pascal source code
  338.   looking for BEGIN/END pairs, CASE/END pairs, LITERAL fields
  339.   and COMMENT fields.  BCOUNT is begin/end and case/end counter.
  340.   KCOUNT is comment counter.  Begin/case/ends are only valid
  341.   outside of comment fields and literal constant fields (KCOUNT = 0
  342.   and NOT LITERAL).
  343.   Some of the code in the SCAN_LINE procedure appears at first glance
  344.   to be repitive and/or redundant, but was added to speed up the
  345.   process of scanning each line of source code.}
  346.  
  347. Procedure SCAN_LINE;
  348.   var
  349.     literal : boolean;          { true if in literal field}
  350.     tmp     : string[7];        { tmp work area }
  351.     i       : integer;          {loop variable index}
  352.     buff2   : instring;         {working line buffer}
  353.     incflname : fnmtype;        {in file name}
  354.     filedate_save : dtstr;
  355.     filetime_save : dtstr;
  356.   begin
  357.     literal := false;
  358.  
  359.     buff2[0] := buff1[0];  {copy input buffer to working buffer}
  360.     for i := 1 to length(buff1) do
  361.      buff2[i] := upcase(buff1[i]);  {and translate to upper case}
  362.  
  363.     if chkinc(buff2, incflname) and expand_includes then
  364.        begin
  365.        for i := 1 to length(incflname) do
  366.            incflname[i] := upcase(incflname[i]);
  367.           if pos('.',incflname) = 0 then incflname := incflname + '.PAS';
  368.           printline('*************************************',incflname);
  369.           printline('    Including "'+incflname+'"', incflname);
  370.           printline('*************************************',incflname);
  371.           filedate_save := filedate;  {save filedate & filetime for}
  372.           filetime_save := filetime;  {main file                   }
  373.           listit(incflname);
  374.           filedate := filedate_save;  {restore}
  375.           filetime := filetime_save;
  376.           printline('*************************************',incflname);
  377.           printline('    End of    "'+incflname+'"', incflname);
  378.           printline('*************************************',incflname);
  379.          end;  {include file check}
  380.  
  381.     if copy(buff2,1,5) = '{.L-}' then print := false;
  382.     if copy(buff2,1,5) = '{.L+}' then print := true;
  383.  
  384.     if copy(buff2,1,7) = '{.PAGE}' then print_head := true;
  385.  
  386.     buff2 := concat('  ', buff2, '      ');  {add on some working space}
  387.     for i := 1 to length(buff2) - 6 do
  388.       begin
  389.         tmp := copy(buff2, i, 7);
  390.         if not literal then   {possible to find comment delim}
  391.           begin
  392.            {determine if comment area delim}
  393.            if tmp[1] in ['{', '}', '(', '*'] then
  394.              begin
  395.                if (tmp[1] = '{') or (copy(tmp,1,2)='(*') then
  396.                  kcount := succ(kcount);  {count comment opens}
  397.                if (tmp[1] = '}') or (copy(tmp,1,2)='*)') then
  398.                  kcount := pred(kcount);  {un-count comment closes}
  399.              end;
  400.           end;
  401.  
  402.          if kcount = 0 then  {we aren't in a comment area}
  403.            begin
  404.             if tmp[1] = chr(39) then
  405.               literal := not literal;   {toggle literal flag}
  406.  
  407.            if not literal and (tmp[2] in ['B','C','E']) then
  408.              begin
  409.                if (tmp = ' BEGIN ') or (copy(tmp,1,6) = ' CASE ') then
  410.                 begin
  411.                  bcount := succ(bcount);  {count BEGIN}
  412.                  i := i + 5;              {skip rest of begin}
  413.                 end;
  414.                if (copy(tmp,1,4) = ' END') and
  415.                   (tmp[5] in ['.', ' ', ';']) and
  416.                    (bcount > 0) then
  417.                 begin
  418.                  bcount := pred(bcount);   {un-count for END}
  419.                  i := i + 4;
  420.                 end;
  421.               end;  {if not literal}
  422.            end;  { if kcount = 0 }
  423.         end;  { for i := }
  424.     end;  {SCAN_LINE}
  425. {.page}
  426. Procedure ListIt;
  427.   var
  428.     infile : text;
  429.   begin
  430.      assign(infile, filename);
  431.    {$I-} reset(infile) {$I+} ;
  432.    if IOresult <> 0 then begin
  433.       writeln ('File ',filename,' not found.');
  434.       halt;
  435.    end;
  436.      WhenCreated (filedate,filetime,infile);
  437.          print_heading(filename);
  438.          while not eof(infile) do
  439.            begin
  440.             readln(infile, buff1);
  441.             scan_line;
  442.             if print_head then
  443.                 print_heading(filename);
  444.             if print and (not print_head) then
  445.               begin
  446.                 writeln(listfil,kcount : 2, bcount : 3, '  ', buff1);
  447.                 linect := succ(linect);
  448.                 if linect > maxline then
  449.                   begin
  450.                     print_heading(filename);
  451.                   end;
  452.               end;
  453.             print_head := false;
  454.          end;     {while not eof}
  455.   end; {ListIt}
  456.  
  457. {.page}
  458.   begin {main procedure}
  459.      getdate(sysdate);
  460.      gettime(systime);
  461.      expand_includes := false;       {default settings}
  462.      print := true;
  463.  
  464.    repeat {forever}
  465.      ClrScr;
  466.      GotoXY(2, 2);
  467.      writeln('TURBO Pascal Formatted Listing');
  468.      GotoXY(2, 4);
  469.      get_in_file;      {file to list}
  470.      offset := 24 - length(fnam);
  471.      get_out_file;     {where to list it}
  472.      pageno := 0;
  473.      linect := 1;      {output line counter}
  474.      kcount := 0;
  475.      bcount := 0;
  476.      print_head := false;
  477.      listit(fnam);
  478.     write(cr, lf, 'HIT ANY KEY TO CONTINUE ');  {allow op to see end
  479.                                                  of listing}
  480.     getchar(c);
  481.     until false {repeat forever - exit is in GET_IN_FILE PROCEDURE}
  482.  end.  {main procedure}
  483. cedure}
  484.