home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / beehive / bbs / rover12a.arc / EXPORT.INC < prev    next >
Text File  |  1991-08-11  |  10KB  |  397 lines
  1. {** EXPORT.INC **}
  2.  
  3. procedure export_menu;
  4. label continue, nextstep;
  5. var
  6.   ch: char;
  7.   st: string[6];
  8.   value, code, I: integer;
  9.   textflag: boolean;
  10. begin
  11.   folder:= 0;
  12.   deleted:= 0;
  13.   public:= 0;
  14.   start_number:= 0;
  15.   textflag:= false;
  16.   writeln('EXPORT MENU:');
  17.   writeln('(control C aborts)');
  18.   writeln;
  19.   if existstext('MESSAGES.ASC') then
  20.   begin
  21.     textflag:= true;
  22.     write('MESSAGES.ASC exists, and will be overwritten if you proceed.');
  23.   end
  24.   else
  25.   begin
  26.     if not opennewtext('MESSAGES.ASC') then finis(2);
  27.     writeln('Messages will be exported to MESSAGES.ASC on the default drive.');
  28.   end;
  29.   writeln;
  30.   writeln;
  31.   write('Do you want to select specific message(s) (y,[N])? ');
  32.   by_number:= (upcase(readKeyETX) = 'Y');
  33.   if by_number then
  34.   begin
  35.       for I:= 1 to 10 do msg[I]:= 0;
  36.       writeln;
  37.       writeln('    Enter up to 10 message numbers to select.');
  38.       writeln('    Enter 0 to end.');
  39.       for I:= 1 to 10 do
  40.       begin
  41.         write(I, '. ');
  42.         readln(msg[I]);
  43.         if msg[I] < 1 then goto continue;
  44.       end;
  45.     end;
  46. CONTINUE:
  47.   if by_number then goto nextstep;
  48.   writeln;
  49.   write('Is there a starting number (y,[N])? ');
  50.   if (upcase(readKeyETX) = 'Y') then
  51.   begin
  52.     writeln;
  53.     write('    Enter the starting message number: ');
  54.     readln(st);
  55.     if (length(st) > 0) then
  56.     begin
  57.       val(st, start_number, code);
  58.       if (code > 0) then start_number:= 0;
  59.     end;
  60.   end
  61.   else writeln;
  62.   write('Select folder number (1-9) or [A] LL: ');
  63.   ch:= readKeyETX;
  64.   if ch in ['1'..'9'] then folder:= ord(ch) - $30
  65.     else folder:= 0;
  66.   writeln;
  67.   write('Select <D>eleted, <U>ndeleted, <R>ead, or [A] LL: ');
  68.   case upcase(readKeyETX) of
  69.     'D': deleted:= 2;
  70.     'U': deleted:= 1;
  71.     'R': deleted:= 3;
  72.     else deleted:= 0;
  73.   end;
  74.   writeln;
  75.   write('Select <P>ublic, p<R>ivate, or [A} LL: ');
  76.   case upcase(readKeyETX) of
  77.     'P': public:= 1;
  78.     'R': public:= 2;
  79.     else public:= 0;
  80.   end;
  81.   writeln;
  82. NEXTSTEP:
  83.   writeln;
  84.   set_pick:= ((folder + deleted + public) > 0) or by_number;
  85.   if textflag then if not opennewtext('MESSAGES.ASC') then finis(2);
  86. end; {export_menu}
  87.  
  88. function pad(PadStr: Str30; Len: integer): Str30;
  89. var
  90.   I: integer;
  91. begin
  92.   if length(PadStr) < Len then
  93.   begin
  94.     for I := length(PadStr) to Len do PadStr := PadStr + ' ';
  95.     Pad := PadStr
  96.   end
  97. end; {pad}
  98.  
  99. function trim(st: Str80): Str80;
  100. {remove trailing blanks}
  101. label exitloop;
  102. var
  103.   I: integer;
  104.   len: integer;
  105. begin
  106.   len:= length(st);
  107.   for I := len downto 1 do
  108.     if st[I] = ' ' then delete(st,I,1) else goto exitloop;
  109. EXITLOOP:
  110.   trim:= st;
  111. end; {trim}
  112.  
  113. function convert(bt: byte): str1;
  114. var
  115.   ch: str1;
  116. begin
  117.   if (bt and $80 = $80) then ch:= ^@
  118.    else ch:= chr(bt);
  119.   {ch:= chr(bt and $7F);}
  120.   if ch in [^A..^_, char($7F)] then ch:= ' ';
  121.   convert:= ch;
  122. end; {convert}
  123.  
  124. procedure transfer(start, count: integer);
  125. var
  126.   I: integer;
  127. begin
  128.   for I:= 1 to count do
  129.     selectbuffer[I]:= msgindexbuffer[I + start - 1];
  130. end; {transfer}
  131.  
  132. function buffer_to_string: str30;
  133. label stop;
  134. var
  135.   I: integer;
  136.   st: str30;
  137. begin
  138.   st:= '';
  139.   for I:= 1 to 30 do
  140.     begin
  141.       if selectbuffer[I] = 0 then goto stop;
  142.       st:= st + convert(selectbuffer[I]);
  143.     end;
  144. STOP:
  145.   buffer_to_string:= st;
  146. end; {buffer_to_string}
  147.  
  148. function buffer_to_integer: integer;
  149. var
  150.   bt,bt1: byte;
  151.   numb: integer;
  152. begin
  153.   bt:= selectbuffer[1];
  154.   bt1:= selectbuffer[2];
  155.   numb:= bt + (256 * bt1);
  156.   buffer_to_integer:= numb;
  157. end; {buffer_to_integer}
  158.  
  159. procedure display;
  160. begin
  161.   transfer(1,30);
  162.   writeln(buffer_to_string);
  163. end; {display}
  164.  
  165. function pick: boolean;
  166. label exitloop;
  167. var
  168.   I: integer;
  169.   test: boolean;
  170.   OK: boolean;
  171. begin
  172.   pick:= true;
  173.   test:= true;
  174.   OK:= true;
  175.   if not (set_pick or (start_number > 0)) then exit;
  176.   if (start_number > 0) then
  177.     test:= (msgindex.msg_no >= start_number);
  178.   if folder> 0 then test:= test and (folder = msgindex.folder);
  179.   if deleted> 0 then
  180.    case deleted of
  181.     1: test:= test and (msgindex.deleted < 2); {undeleted = 0, read = 1}
  182.     2: test:= test and (msgindex.deleted > 127);  {deleted}
  183.     3: test:= test and (msgindex.deleted = 1);  {read}
  184.    end; {case}
  185.   if public> 0 then
  186.    case public of
  187.     1: test:= test and (msgindex.public = 0); {public}
  188.     2: test:= test and (msgindex.public > 0);  {private}
  189.    end; {case}
  190.   if by_number and test then
  191.     for I:= 1 to 10 do
  192.       begin
  193.         OK:= false;
  194.         if msg[I] = 0 then goto exitloop;
  195.         OK:= (msg[I] = msgindex.msg_no);
  196.         if OK then goto exitloop;
  197.       end;
  198. EXITLOOP:
  199.   test:= test and OK;
  200.   pick:= test;
  201. end; {pick}
  202.  
  203. procedure move_buffer;
  204. var
  205.   I, count, destination: integer;
  206.   skip: boolean;
  207. begin
  208.   skip:= msgindex_pointer >= 100;
  209.   count:= 100 - msgindex_pointer;
  210.   if skip then msgindex_pointer:= 100;
  211.   if msgindex_pointer > 0 then
  212.     for I:= 1 to msgindex_pointer do  {move stored data}
  213.       msgindexbuffer[I]:= store[I];
  214.   if not skip then
  215.   begin
  216.   destination:= msgindex_pointer + 1;
  217.   msgindex_pointer:= 128 - count;
  218.   for I:= 0 to count - 1 do {move read data}
  219.     msgindexbuffer[I + destination]:= buffer[I + 1];
  220.   for I:= 1 to msgindex_pointer do  {store extra data}
  221.     store[I]:= buffer[I + count];
  222.   end
  223.   else
  224.   begin
  225.     msgindex_pointer:= abs(count);
  226.       for I:= 1 to msgindex_pointer do
  227.         store[I]:= store[I + 100];
  228.   end;
  229. end; {move_buffer}
  230.  
  231. procedure set_msgindex_record;
  232. var
  233.   m,d,y: byte;
  234. begin
  235.   msgindex.date:= byte_to_string(msgindexbuffer[33]) + '/'
  236.      + byte_to_string(msgindexbuffer[34]) + '/'
  237.        + byte_to_string(msgindexbuffer[35]);
  238.   {msgindex.time:= time;}
  239.   with msgindex do
  240.   begin
  241.     receiver:= buffertostring(msgindexbuffer, 1, 30); {str30}
  242.     msg_no:= msgindexbuffer[31] + msgindexbuffer[32]*256; {integer}
  243.     num_of_recs:= msgindexbuffer[36]; {byte}
  244.     start_rec_no:= msgindexbuffer[37] + msgindexbuffer[38]*256; {integer}
  245.     msgindex_rec_no:= mirecord; {integer}
  246.     subject:= buffertostring(msgindexbuffer, 41, 26); {string[26]}
  247.     sender:=  buffertostring(msgindexbuffer, 67, 30); {str30}
  248.     public:=  msgindexbuffer[97]; {byte}
  249.     folder:=  msgindexbuffer[98]; {byte}
  250.     deleted:= msgindexbuffer[99]; {byte}
  251.     null:=    0; {byte}
  252.   end; {with}
  253. end; {set_msgindex_record}
  254.  
  255. function readmsgindex: boolean;
  256. var
  257.   buffer: bufftype;
  258.   mioffset: byte;
  259.   physicalrecord: integer;
  260.   name: string[30];
  261.   N: integer;
  262. begin
  263.   begin
  264.     if (msgindexrec > index.last_msgindex_rec) then
  265.     begin
  266.       readmsgindex:= false;
  267.       exit;
  268.     end;
  269.     physicalrecord:= trunc((100/128) * msgindexrec);
  270.     mioffset:= round(frac((100/128) * msgindexrec) * 128) + 1;
  271.  
  272.     seek(msgndxfil, physicalrecord);
  273.     blockread(msgndxfil, msgindexbuffer, 1);
  274.     buffer:= msgindexbuffer;
  275.     if (mioffset > 29) then  {overflow to next physical rec.}
  276.       blockread(msgndxfil, buffer, 1);
  277.  
  278.     if (mioffset > 1) and (mioffset < 30) then
  279.     for N:= mioffset  to (100 + mioffset -1) do
  280.       msgindexbuffer[n - mioffset + 1] := msgindexbuffer[n];
  281.  
  282.     if (mioffset > 29) then  {overflow to next physical rec}
  283.     begin
  284.       for N:= mioffset  to 128 do
  285.         msgindexbuffer[n - mioffset + 1] := msgindexbuffer[n];
  286.       for N:= 1 to (100 - 128 + mioffset -1) do
  287.         msgindexbuffer[n + 128 - mioffset + 1] := buffer[n];
  288.     end;
  289.  
  290.     nextrecord:= msgindexbuffer[37]
  291.                  + msgindexbuffer[38]*256
  292.                    + msgindexbuffer[36];
  293.  
  294.   end;
  295.  
  296.   set_msgindex_record;
  297.   msgindexbuffer:= buffer;
  298.   readmsgindex:= true;
  299. end; {readmsgindex}
  300.  
  301. function nextmsgindex: boolean;
  302. var
  303.   OK: boolean;
  304. begin
  305.   OK:= readmsgindex;
  306.   nextmsgindex:= OK;
  307.   if not OK then exit;
  308.   msgindexrec:= msgindexrec + 1;
  309. end; {nextmsgindex}
  310.  
  311. function chek0(st: str64): str64;
  312. {delete end of line after null}
  313. var
  314.   p: byte;
  315.   st1: str64;
  316. begin
  317.   st1:= st;
  318.   p:= 0;
  319.   if (length(st) > 0) then
  320.     p:= pos(NUL, st);
  321.   if (p > 0) then
  322.       st1:= copy(st, 1, p - 1 );
  323.   chek0:= st1;
  324. end; {chek0}
  325.  
  326. procedure header;
  327. begin
  328.   writeln(textfil,'Folder: ', folders[msgindex.folder]);
  329.   write(textfil,'Msg. # ', msgindex.msg_no:4, '  ');
  330.   write(textfil,'Dated: ' + msgindex.date);
  331.   write(textfil,' ':10);
  332.   writeln(textfil,'Subj: ' + msgindex.subject);
  333.   write(textfil,'To: ' + fixcaps(msgindex.receiver));
  334.   writeln(textfil,'    From: ' + fixcaps(msgindex.sender));
  335.   writeln(textfil);
  336. end; {header}
  337.  
  338. function readmessageline(numb: integer): str64;
  339. var
  340.   I: integer;
  341.   OD: boolean;
  342.   st: string[128];
  343.   st1: str64;
  344. begin
  345.   st:= '';
  346.   OD:= odd(numb);
  347.   numb:= trunc(numb / 2);
  348.   seek(messagesfil,numb);
  349.   blockread(messagesfil, buffer, 1);
  350.     begin
  351.       for I:= 1 to 128 do
  352.         st:= st +  convert(buffer[I]);
  353.       if not od then st1:= copy(st,1,64)
  354.         else st1:= copy(st,65,64);
  355.     end;
  356.   readmessageline:= st1;
  357. end; {readmessageline}
  358.  
  359. procedure get_message;
  360. var
  361.   I: integer;
  362.   OK: boolean;
  363.   st: str64;
  364. begin
  365.   st:= '';
  366.   begin
  367.   header;
  368.   for I:= 0 to msgindex.num_of_recs - 1 do
  369.    begin
  370.      st:= chek0(readmessageline(msgindex.start_rec_no + I));
  371.      writeln(textfil,st);
  372.    end;
  373.    writeln(textfil);
  374.   end;
  375. end; {get_message}
  376.  
  377. procedure do_export;
  378. begin
  379.   if not openfiles then finis(2);
  380.   readindex;
  381.   if not export then exit;
  382.   writeln('EXPORT FILES:');
  383.   writeln;
  384.   writeln('working...');
  385.   writeln;
  386.   if (index.next_message_number < start_number + 1) then finis(1);
  387.   msgindexrec:= 0;
  388.   while nextmsgindex do
  389.     if pick then
  390.     begin
  391.      write(msgindex.msg_no, ' ');
  392.      get_message; {if readmessages then;}
  393.      { transfer_message;}
  394.     end;
  395.   writeln;
  396. end; {do_export}
  397.