home *** CD-ROM | disk | FTP | other *** search
/ Beijing Paradise BBS Backup / PARADISE.ISO / software / BBSDOORW / AVAILIST.ZIP / AL_READ.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1993-01-04  |  7.6 KB  |  244 lines
  1. {*****************************************************************************
  2.  *                                                                           *
  3.  *                       AL_Read.Pas By Andrew Farmer                        *
  4.  *          File Read and Write Module for AvaiList Revision 1.10            *
  5.  *                                                                           *
  6.  *         Copyright 1989 by Andrew D. Farmer, All Rights Reserved.          *
  7.  *                                                                           *
  8.  *                                                                           *
  9.  *     Compiled using Turbo Pascal Version 5.0 By Borland International      *
  10.  *                                                                           *
  11.  *****************************************************************************}
  12.  
  13. Procedure JulianDate (TheFlag : Word);
  14. Begin
  15.   If TheFlag = 1 then JD := 0;
  16.   If TheFlag = 2 then JD := 31;
  17.   If TheFlag = 3 then JD := 59;
  18.   If TheFlag = 4 then JD := 90;
  19.   If TheFlag = 5 then JD := 120;
  20.   If TheFlag = 6 then JD := 151;
  21.   If TheFlag = 7 then JD := 181;
  22.   If TheFlag = 8 then JD := 212;
  23.   If TheFlag = 9 then JD := 243;
  24.   If TheFlag = 10 then JD := 273;
  25.   If TheFlag = 11 then JD := 304;
  26.   If TheFlag = 12 then JD := 334;
  27. End;
  28.  
  29. Procedure ReadDirBbs;
  30. Begin
  31.   Assign(DirCopy,SortDir);
  32.   {$I-} Reset(DirCopy); {$I+}
  33.   OK := (IOResult = 0);
  34.   If Not OK then Dirbbs := SortArea;
  35.   If OK Then Begin Readln(DirCopy,DirBbs); Close(DirCopy); End;
  36.   If Dirbbs = '' then Dirbbs := SortArea;
  37.   For N := 1 to Length(Dirbbs) do
  38.   Dirbbs[N] := UpCase(Dirbbs[N]);
  39.   GraphLine := LR + LR + LR + LR;
  40.   For N := 1 to Length(Dirbbs) do
  41.   GraphLine := GraphLine + LR;
  42.   Writeln(ListOut,'');
  43.   WriteLn(ListOut,TL,Graphline,TR);
  44.   Writeln(ListOut,TB,'  ',dirbbs,'  ',TB);
  45.   Writeln(ListOut,BL,GraphLine,BR);
  46.   If DoNewList = True then
  47.   Begin
  48.     Writeln(NewOut,'');
  49.     WriteLn(NewOut,TL,Graphline,TR);
  50.     Writeln(NewOut,TB,'  ',dirbbs,'  ',TB);
  51.     Writeln(NewOut,BL,GraphLine,BR);
  52.   End;
  53. End; { Procedure ReadDirBbs }
  54.  
  55. Procedure ExpandFileSpec;
  56. Begin
  57.   Date;
  58.   count := 0;
  59.   Fspace := ' ';
  60.   FlagIt := '  ';
  61.   TotalFile := TotalFile + 1;
  62.   AreaTotal := AreaTotal + 1;
  63.   TheFile := SearchData.Name;
  64.   For N := 1 to length(TheFile) do
  65.   Count := Count + 1;
  66.   FCount := 12 - count;
  67.   If FCount <> 0 then
  68.   Begin
  69.     For N := 1 to FCount do
  70.     Fspace := FSpace + ' ';
  71.   End;
  72.   UnPackTime(SearchData.Time,SearchTime);
  73.   TotalSize := TotalSize + SearchData.Size;
  74.   AreaSize := AreaSize + SearchData.Size;
  75.   If (FlagNew = True) then
  76.   Begin
  77.     If SearchTime.Year = Year then
  78.     Begin
  79.       JulianDate(month);
  80.       NowJD := JD + day;
  81.       JulianDate(SearchTime.Month);
  82.       FileJD := JD + SearchTime.Day;
  83.       DiffJD := NowJD - FileJD;
  84.       If DiffJD < FlagDays then 
  85.       Begin
  86.         FlagIt := FlagChar + ' ';
  87.         TotalNFile := TotalNFile + 1;
  88.         TotalNSize := TotalNSize + SearchData.Size;
  89.         NewTot := NewTot + 1;
  90.       End;
  91.     End;
  92.     If SearchTime.Year = Year - 1 then
  93.     Begin
  94.       JulianDate(month);
  95.       NowJD := JD + day + 365;
  96.       JulianDate(SearchTime.Month);
  97.       FileJD := JD + SearchTime.Day;
  98.       DiffJD := NowJD - FileJD;
  99.       If DiffJD < FlagDays then 
  100.       Begin
  101.         FlagIt := FlagChar + ' ';
  102.         TotalNFile := TotalNFile + 1;
  103.         TotalNSize := TotalNSize + SearchData.Size;
  104.         NewTot := NewTot + 1;
  105.       End;
  106.     End;
  107.   End;
  108.   Str(SearchData.Size,FSize);
  109.   Str(SearchTime.Year,FYear);
  110.   Fyear := Copy(Fyear,3,2);
  111.   Str(SearchTime.Month,FMonth);
  112.   If FMonth = '0' then Fmonth := '00';
  113.   If FMonth = '1' then Fmonth := '01';
  114.   If FMonth = '2' then Fmonth := '02';
  115.   If FMonth = '3' then Fmonth := '03';
  116.   If FMonth = '4' then Fmonth := '04';
  117.   If FMonth = '5' then Fmonth := '05';
  118.   If FMonth = '6' then Fmonth := '06';
  119.   If FMonth = '7' then Fmonth := '07';
  120.   If FMonth = '8' then Fmonth := '08';
  121.   If FMonth = '9' then Fmonth := '09';
  122.   Str(SearchTime.Day,FDay);
  123.   If FDay = '0' then FDay := '00';
  124.   If FDay = '1' then FDay := '01';
  125.   If FDay = '2' then FDay := '02';
  126.   If FDay = '3' then FDay := '03';
  127.   If FDay = '4' then FDay := '04';
  128.   If FDay = '5' then FDay := '05';
  129.   If FDay = '6' then FDay := '06';
  130.   If FDay = '7' then FDay := '07';
  131.   If FDay = '8' then FDay := '08';
  132.   If FDay = '9' then FDay := '09';
  133.   Fdate := Concat(Fmonth,'-',Fday,'-',Fyear);
  134.   If NoDate = False then Writeln(ListOut,TheFile,FSpace,Fsize:7,' ',Fdate,FlagIt,TheDesc);
  135.   If NoDate = True then Writeln(ListOut,TheFile,FSpace,Fsize:7,FlagIt,TheDesc);
  136.   If (DoNewList = True) AND (FlagIt = FlagChar + ' ') then
  137.   Begin
  138.     If NoDate = False then Writeln(NewOut,TheFile,FSpace,Fsize:7,' ',Fdate,'  ',TheDesc);
  139.     If NoDate = True then Writeln(NewOut,TheFile,FSpace,Fsize:7,'  ',TheDesc);
  140.   End;
  141. End;
  142.  
  143. Procedure ReadFilesBbs;
  144. Var Files : Array[1..512] of String[79];
  145. Label 1, Done;
  146. Begin
  147.   Writeln(ListOut,'');
  148.   If DoNewList = True then Writeln(NewOut,'');
  149.   Assign(FileCopy,SortFiles);
  150.   SetTextBuf(FileCopy,Buf);
  151.   {$I-} Reset(FileCopy); {$I+}
  152.   OK := (IOResult = 0);
  153.   If Not OK then
  154.   Begin 
  155.     Writeln(ListOut,'No Files'); 
  156.     If DoNewList = True then Writeln(NewOut,'No Files');
  157.     Exit; 
  158.   End;
  159.   FileInc := 0;
  160.   FileCount := 0;
  161.   Repeat
  162.     Inc(FileInc);
  163.     ReadLn(FileCopy,GetFiles);
  164.     Files[FileInc] := GetFiles;
  165.   Until Eof(FileCopy);
  166.   Close(FileCopy);
  167.   FileCount := FileInc;
  168.   FileInc := 0;
  169.   Repeat
  170.     Inc(FileInc);
  171.     FilesBbs := Files[FileInc];
  172.     FC1 := Copy(Filesbbs,1,1);
  173.     FC2 := Copy(Filesbbs,1,13);
  174.     if (Filesbbs = '') or (FC1 = ' ') or (FC1 = '-') then
  175.     Begin
  176.       If StripCom = False then Writeln(ListOut,Filesbbs);
  177.       Goto 1;
  178.     End;
  179.     count := 0;
  180.     repeat
  181.       Count := Count + 1;
  182.       Ch := Copy(FC2,Count,1);
  183.     until (Ch = ' ') or (Count = Length(FilesBbs));
  184.     If Count = Length(FilesBbs) then
  185.     Begin
  186.       Count := Length(Filesbbs);
  187.       FileCheck := Copy(Filesbbs,1,count);
  188.       TheDesc := 'No description given at upload';
  189.       Goto Done;
  190.     End;
  191.     count := count - 1;
  192.     FileCheck := Copy(Filesbbs,1,count);
  193.     count2 := count + 2;
  194.     FC3 := Copy(Filesbbs,count2,Length(Filesbbs));
  195.     If FC3 = '' then TheDesc := 'No description given at upload';
  196.     Count3 := 0;
  197.     repeat
  198.       Count3 := Count3 + 1;
  199.       Ch := Copy(FC3,Count3,1);
  200.     until Ch <> ' ';
  201.     count3 := count3 + count2;
  202.     count3 := count3 - 1;
  203.     If NoDate = False then TheDesc := Copy(Filesbbs,count3,48);
  204.     If NoDate = True then TheDesc := Copy(Filesbbs,count3,57);
  205.     If TheDesc = '' then TheDesc := 'No description given at upload';
  206.     Done:
  207.     ThePath := SortArea + '\' + FileCheck;
  208.     FindFirst(ThePath,AnyFile,SearchData);
  209.     If (DOSERROR <> 0) AND (KillOrphan = False) then 
  210.     Begin
  211.       TheFile := FileCheck;
  212.       Count := 0;
  213.       FSpace := ' ';
  214.       For N := 1 to length(TheFile) do
  215.       Count := Count + 1;
  216.       FCount := 12 - count;
  217.       If FCount <> 0 then
  218.       Begin
  219.         For N := 1 to FCount do
  220.         Fspace := FSpace + ' ';
  221.       End;
  222.       If NoDate = True then
  223.       Begin
  224.         FSize := 'OFFLINE';
  225.         Writeln(ListOut,TheFile,FSpace,Fsize:7,'  ',TheDesc);
  226.       End;
  227.       If NoDate = False then
  228.       Begin
  229.         Fdate := 'OFF-LINE'; 
  230.         FSize := ' STORED';
  231.         Writeln(ListOut,TheFile,FSpace,Fsize:7,' ',Fdate,'  ',TheDesc);
  232.       End;
  233.     End;
  234.     If DOSERROR = 0 then
  235.     Begin
  236.       Repeat
  237.         ExpandFileSpec;
  238.         FindNext(SearchData);
  239.       Until DOSERROR = 18;
  240.     End;
  241.     1:
  242.   Until FileInc = FileCount;
  243. End; { Procedure ReadFilesBbs }
  244.