home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / beehive / bbs / arkmail.pas < prev    next >
Pascal/Delphi Source File  |  1986-11-28  |  13KB  |  404 lines
  1. {R+}
  2. program ARKMAIL; {Copyright (c) 1989 Marc Newman
  3. This program invokes the ARK Version .04 program to create ARKs of FIDO
  4. mail via the submit mechanisim.  It calls itself as the last command
  5. to process further .OUT files.  A .FLO file is created, and it
  6. uses the POLL command to create a .OUT file
  7. In addition, if a .FLO file is not found, all MO?,TU?,WE? etc files
  8. are deleted.  If a .FLO file is found, it is checked to see if the
  9. current filename is already waiting to go out, if so, the same file
  10. is updated.  If not, it is added to (or a new .FLO created) and a
  11. poll sent out.  This program MUST be run on the same drive/user as
  12. the ybbaT MAIL.SYS file and all the .OUT files to be processed.
  13. Include ARKMAIL as the command immediately before KSMAIL in your
  14. outgoing batch file.  That way, any outgoing mail will be ARKed.
  15.  
  16. You MUST use ARK version .04, prior versions (.35) did not support
  17. multiple drives.
  18.  
  19. You must provide a ROS.CLK insert which reads your clock and returns
  20. a byte array consisting of:
  21.   t[0] = seconds
  22.   t[1] = minutes
  23.   t[2] = hours
  24.   t[3] = day
  25.   t[4] = month
  26.   t[5] = year
  27.  Note, these are integer values in BYTE format (0-255).  Year is 0-99
  28.  
  29.  Marc K. Newman
  30. The Black Box RCPM/DRBBS/ybbaT
  31. 713-480-2686 300/1200 Baud & FIDONET 1:106/601.0
  32. Version 0.1 3/29/89
  33.  
  34. If you enjoy this program, use it and feel free to distribute it for
  35. non-commercial use.  If you change it, I would appreciate it if you
  36. retain this notice and give me credit for the portions of the program
  37. I wrote.  If you want to use this program or portions thereof for
  38. purposes, a $10/copy royalty for my trouble and work will be charged
  39. Note, this includes use on CLUB BBSes, as they are considered businesses
  40. be they for profit or non-profit.
  41.  
  42. Mail any royalty payments to:           Marc Newman
  43.                                         14615 Stilesboro Court
  44.                                         Houston, Texas 77062  }
  45. type
  46.      STR3 = string[3];
  47.      STR4 = string[4];
  48.      str8 = string[8];
  49.      STR11 = STRING[11];
  50.      STR16 = STRING[16];
  51.      STR80 = STRING[80];
  52.      byte256 = array[0..256] of byte;
  53.      TAD_array = array[0..5] of BYTE;
  54. const
  55.      MAIN_DRIVE   : INTEGER = 0; {0=DRIVE A:}
  56.      AUX_DRIVE    : INTEGER = 1; {1=DRIVE B:}
  57.      Select_disk  : integer = $0E;
  58.      Search_first : integer = $11;
  59.      Search_next  : integer = $12;
  60.      Set_DMA      : integer = $1A;
  61.      HEX_array    : array[0..15] of CHAR =
  62.                   ('0','1','2','3','4','5','6','7','8','9',
  63.                   'A','B','C','D','E','F');
  64.      VER          : STRING[3] = '0.1';
  65. var
  66.      OK,
  67.      writenew,
  68.      IN_FLO,
  69.      found     : BOOLEAN;
  70.      mail_sys     : byte256;
  71.      mail_sys_file: file;
  72.      i,
  73.      ERROR,
  74.      LOOP,
  75.      START        : integer;
  76.      MY_NET,
  77.      MY_NODE,
  78.      DEST_NET,
  79.      DEST_NODE    : integer;
  80.      SUB          : FILE;
  81.      FLO          : FILE;
  82.      FILENAME     : STR11;
  83.      NEW_FILENAME : STR8;
  84.      DELTA_NET    : STR4;
  85.      DELTA_NODE   : STR4;
  86.      STRING4      : STR4;
  87.      STRING16     : STR16;
  88.      STRING11     : STR11;
  89.      STRING20     : STRING[20];
  90.      STRING80     : STR80;
  91.      TIME         : TAD_ARRAY;
  92.      BYTE128      : ARRAY[0..128] OF BYTE;
  93.      NEW_EXTENSION : STR3;
  94.  
  95. {$I ROS.CLK}
  96.  
  97. function weekday(month, date, year : integer) : integer;
  98. {Zeller congruence to calculate any day of the week using
  99. integer math.  From letter by Bob Whitefield, Decatur, AL
  100. in the February, 1989 'Computer Language' magazine.}
  101. var
  102.      day : integer;
  103. begin
  104.      if month <= 2 then
  105.      begin
  106.           month := month + 12;
  107.           year := year - 1
  108.      end;
  109.  
  110.      Day := (date + month * 2 + (month + 1) * 6 div 10 + year +
  111.          year div 4 - year div 100 + year div 400 + 2) mod 7;
  112.      weekday := day
  113. end; {Weekday}
  114.  
  115. FUNCTION HEX(x : integer) : STR4;
  116. VAR
  117.           Z : STR4;
  118. begin
  119.           Z := '    ';
  120.           Z[4] := hex_array[LO(x) and $0F];
  121.           Z[3] := hex_array[(LO(X) AND $F0) SHR 4];
  122.           Z[2] := hex_array[HI(X) and $0f];
  123.           Z[1] := hex_array[(HI(X) and $F0) SHR 4];
  124.           HEX := COPY(Z,1,4);
  125. end;
  126.  
  127. function inttoBCD(intg : integer) : byte;
  128. var x,y : byte;
  129. begin
  130.     x := intg div 10;
  131.     y := intg mod 10;
  132.     inttoBCD := ((x and $0f) shl 4) + y;
  133. end;
  134.  
  135. function DEC(X : STR4) : integer;
  136. var
  137.      a,y : integer;
  138.      z : STR4;
  139. begin
  140.      a := 0;
  141.      for i := 4 downto 1 do
  142.      begin
  143.           y := ord(x[i])-ord('0');
  144.           if y > 9 then y := ord(x[i]) - ord('A') +10;
  145.           a := a + (y shl ((4-i) * 4));
  146.      end;
  147.      dec := a;
  148. end;
  149.  
  150. function max(i,j : integer) : integer;
  151. begin
  152.      if i > j then
  153.         max := i
  154.      else
  155.         max := j;
  156. end;
  157.  
  158. procedure submit(ST : STR80);
  159. {Save command line to submit file record}
  160. var
  161.    len, I : byte;
  162.    buffer : array[1..128] of byte;
  163. begin
  164.    writeln(st);
  165.    bdos(select_disk,main_drive);
  166.    if (length(st) = 0) or (st[1] = ';')
  167.       or (st[1] = ' ') then exit;
  168.    len := length(st);
  169.    buffer[1] := len;
  170.    for i := 1 to len do
  171.        buffer[i+1] := ord(st[I]);
  172.    buffer[len+2] := 0;
  173.    buffer[len+3] := ord('$');
  174.    for i := len+4 to 128 do
  175.        buffer[i] := 0;
  176.    blockwrite(sub, buffer,1);
  177. end; {Submit}
  178.  
  179. procedure search_file(VAR in_file : str11;
  180.                       var out_file : str11;
  181.                       var found : boolean);
  182. var
  183.       DMA   : BYTE256;
  184.       FCB   : ARRAY[0..25] OF BYTE ABSOLUTE $005C;
  185.       i,
  186.       START,
  187.       error : integer;
  188. begin
  189.       error := BDos(set_dma,ADDR(DMA));
  190.       FCB[0] := 0;
  191.       for i := 1 to 11 do FCB[I] := ord(in_file[i]);
  192.       error := BDos(SEARCH_FIRST,Addr(FCB));
  193.       found := (error <> 255);
  194.       out_file := '';
  195.       start := error * 32;
  196.       if found then
  197.          for i := 1 to 11 do
  198.              out_file := OUT_FILE + char(mem[addr(dma)+i+start]);
  199. end;
  200.  
  201. function GET_EXTENSION(NET_NODE,FILENAME :STR8) : STR3;
  202. const
  203.      DAY : array[0..6] of string[2] =
  204.          ('SU', 'MO', 'TU', 'WE', 'TH', 'FR', 'SA');
  205. var
  206.      i, code : integer;
  207.      temp : string[20];
  208.      file_id : FILE;
  209.      TEXT_FILE : TEXT;
  210.      OK,
  211.      DAY_OK,
  212.      FOUND : boolean;
  213.      ext_day : string[2];
  214.      extension : string[3];
  215.      TEMP_FILE,
  216.      filename_found : str11;
  217. begin
  218.      IN_FLO := FALSE;
  219.      ext_day := day[weekday(time[4],time[3],time[5])];
  220.      assign(file_id,char(main_drive+ord('A')) + ':' + NET_NODE+'.FLO');
  221.      {$I-}
  222.      reset(file_id);
  223.      {$I+}
  224.      ok := (ioresult = 0);
  225.      if not OK then
  226.      begin         {No .FLO file found, look for last extension}
  227.           close(file_id);
  228.           bdos(select_disk,aux_drive);
  229.           TEMP_FILE := FILENAME+EXT_DAY+'?';
  230.           search_file(TEMP_FILE,filename_found,FOUND);
  231.           if FOUND then
  232.           begin
  233.                assign(file_id,char(aux_drive+ord('A'))+':'+
  234.                               COPY(filename_found,1,8) +
  235.                               '.' +
  236.                               COPY(FILENAME_FOUND,9,3));
  237.                erase(file_id);              {Erase last file}
  238.                val(filename_found[11], i, code);
  239.                i := (i + 1) mod 10;
  240.                str(i:1, temp);
  241.                get_extension := ext_day + temp
  242.           end
  243.           ELSE
  244.           BEGIN
  245.                {NO FILES FROM TODAY FOUND, SEE ABOUT YESTERDAY}
  246.                get_extension := ext_day + '0';
  247.           END;
  248.           {SEE IF ANYTHING TO DELETE FROM PREVIOUS DAYS}
  249.           REPEAT
  250.                 FOUND := FALSE;
  251.                 bdos(select_disk,aux_drive);
  252.                 TEMP_FILE := FILENAME+'???';
  253.                 SEARCH_FILE(TEMP_FILE,FILENAME_FOUND,FOUND);
  254.                 I := -1;
  255.                 DAY_OK := FALSE;
  256.                 REPEAT
  257.                       I := I + 1;
  258.                       IF COPY(FILENAME_FOUND,9,2) = DAY[I] THEN
  259.                          DAY_OK := TRUE;
  260.                 UNTIL OK OR (I = 6);
  261.                 IF FOUND AND DAY_OK THEN
  262.                 BEGIN
  263.                      ASSIGN(FILE_ID,CHAR(AUX_DRIVE+ORD('A'))+':'+
  264.                             COPY(FILENAME_FOUND,1,8) + '.'+
  265.                             COPY(FILENAME_FOUND,9,3));
  266.                      ERASE(FILE_ID);
  267.                 END;
  268.           UNTIL NOT FOUND;
  269.      end
  270.      else       {FOUND A .FLO FILE}
  271.      begin
  272.           close(file_id);
  273.           assign(text_file,CHAR(MAIN_DRIVE+ORD('A')) +
  274.                 ':' + net_node+'.FLO');
  275.           reset(text_file);
  276.           temp := '';
  277.           repeat
  278.                 readln(text_file,temp);
  279.                 WRITELN(TEMP);
  280.           until eof(text_file) or
  281.                 ((copy(temp,3,8) = NET_NODE) and
  282.                  (copy(temp,12,2) = ext_day) and
  283.                  (temp[1] <> CHAR($7E)));
  284.           close(text_file);
  285.           extension := copy(temp,12,3);
  286.           if copy(extension,1,2) <> ext_day then
  287.           BEGIN
  288.                 get_extension := ext_day + '0';
  289.                 ASSIGN(FILE_ID,CHAR(AUX_DRIVE+ORD('A')) + ':' +
  290.                        FILENAME + '.' + EXT_DAY + '0');
  291.                 {$I-}
  292.                 ERASE(FILE_ID);
  293.                 {$I+}
  294.                 OK := (IORESULT = 0);
  295.           END
  296.           else
  297.           BEGIN
  298.                 IN_FLO := TRUE;
  299.                 get_extension := extension;
  300.           END;
  301.      END;
  302. end;
  303.  
  304.  
  305. begin
  306.       WRITELN;
  307.       WRITELN('ybbaT ARKMAIL Version ' + VER + ' (c) 1989 Marc Newman');
  308.       WRITELN('The Black Box BBS (713)-480-2686 FIDO 1:106/601.0');
  309.       WRITELN;
  310.       assign(mail_sys_file,CHAR(MAIN_DRIVE+ORD('A'))+':'+'MAIL.SYS');
  311.       RESET(MAIL_SYS_FILE);
  312.       BLOCKREAD(MAIL_SYS_FILE,mail_sys,2);
  313.       MY_NODE :=ord(MAIL_SYS[0]) + (256*ord(MAIL_SYS[1]));
  314.       MY_NET := ord(MAIL_SYS[168])+(256*ord(MAIL_SYS[169]));
  315.       close(mail_sys_file);
  316.       STRING11 := '????????OUT';
  317.       search_file(STRING11,filename,found);
  318.       if found then
  319.       begin
  320.            assign(sub,CHAR(MAIN_DRIVE+ORD('A'))+':'+'$$$.SUB');
  321.            {$I-}
  322.            reset(sub);
  323.            {$I+}
  324.            OK := (IORESULT = 0);
  325.            if OK then
  326.                seek(sub,filesize(sub))
  327.            else
  328.                rewrite(sub);
  329.            string80 := 'ARKMAIL';
  330.            submit(STRING80);
  331.            DEST_NET := DEC(copy(filename,1,4));
  332.            DEST_NODE := DEC(copy(filename,5,8));
  333.            DELTA_NET := HEX(MY_NET - DEST_NET);
  334.            DELTA_NODE := HEX(MY_NODE - DEST_NODE);
  335.            str(dest_net,string20);
  336.            string20 := string20 + '/';
  337.            str(dest_node,string11);
  338.            string20 := string20 + string11;
  339.            string80 := 'STATUS HOLD ' + STRING20;
  340.            SUBMIT(STRING80);
  341.            string80 := 'POLL ' + string20;
  342.            submit(string80);
  343.            GETTAD(TIME);
  344.            NEW_FILENAME := HEX((TIME[4] shl 12) +
  345.                        (inttobcd(TIME[3]) * 64) +
  346.                        inttobcd(TIME[2])) +
  347.                        HEX((inttobcd(TIME[1]) * 512) +
  348.                        (inttobcd(TIME[0]) * 4));
  349.            STRING80 := 'ERA '+NEW_FILENAME+'.PKT';
  350.            SUBMIT(STRING80);
  351.            new_extension := get_extension(filename,delta_net+delta_node);
  352.            string80 := 'ARK -K ' + CHAR(ORD('A')+AUX_DRIVE) + ':' +
  353.                     COPY(DELTA_NET,1,4) +
  354.                     COPY(DELTA_NODE,1,4) + '.' +
  355.                     new_extension + ' ' +
  356.                     CHAR(ORD('A')+MAIN_DRIVE) + ':' +
  357.                     copy(NEW_FILENAME,1,8)+'.PKT';
  358.            submit(string80);
  359.            string80 :='REN '+copy(new_filename,1,8)+'.PKT='+
  360.                     copy(FILENAME,1,8)+'.OUT ';
  361.            submit(string80);
  362.            assign(FLO,CHAR(ORD('A')+MAIN_DRIVE) + ':' +
  363.                       HEX(DEST_NET)+HEX(DEST_NODE)+'.FLO');
  364.            {$I-}
  365.            RESET(FLO);
  366.            {$I+}
  367.            OK := (IORESULT = 0);
  368.            IF (NOT OK) THEN
  369.            begin
  370.                 REWRITE(FLO);
  371.                 for i := 0 to 127 do BYTE128[i] := $1a;
  372.                 start := 0;
  373.                 WRITENEW := TRUE;
  374.            end
  375.            ELSE
  376.            begin
  377.                 WRITENEW := FALSE;
  378.                 SEEK(FLO,MAX(FILESIZE(FLO)-1,0));
  379.                 BLOCKREAD(FLO,BYTE128,1);
  380.                 I := 0;
  381.                 REPEAT
  382.                      START := I+1;
  383.                      I := I + 1;
  384.                 UNTIL (BYTE128[I] = $1A) OR (I = 127);
  385.                 IF START = 127 THEN
  386.                 BEGIN
  387.                      START := 0;
  388.                      FOR I := 0 TO 127 DO BYTE128[I] := $1A;
  389.                      WRITENEW := TRUE;
  390.                 END;
  391.            end;
  392.            STRING16 := CHAR(ORD('A') + AUX_DRIVE) + ':' +
  393.                            COPY(DELTA_NET,1,4)+
  394.                            COPY(DELTA_NODE,1,4)+ '.' +
  395.                            new_extension+
  396.                            CHR($0D) + CHR($0A);
  397.            FOR I := 0 TO 15 DO BYTE128[START+I] := ORD(STRING16[I+1]);
  398.            IF NOT WRITENEW THEN SEEK(FLO,MAX(FILESIZE(FLO)-1,0));
  399.            IF NOT IN_FLO THEN BLOCKWRITE(FLO,BYTE128,1);
  400.            CLOSE(FLO);
  401.      CLOSE(SUB);
  402.      end;
  403. end.
  404.