home *** CD-ROM | disk | FTP | other *** search
/ Shareware Overload / ShartewareOverload.cdr / comm / qmqmpc31.zip / PCBUD202.PAS < prev   
Pascal/Delphi Source File  |  1989-07-01  |  15KB  |  388 lines
  1. program Create_Qmodem_Pcboard_Script;
  2.  
  3. { Original program was donated to public domain by: David W. Terry            }
  4. {                                                   3036 Putnam Ct.           }
  5. {                                                   West Valley City, Ut 84120}
  6. {                                                   Feb. 26, 1985             }
  7. {                                                                             }
  8. { If you make changes and distribute your changed code, Please include some   }
  9. { comments to that effect....                                                 }
  10. {                                                                             }
  11. { Revised by Chuck Seyboldt to create u/l-d/l & logoff segments ONLY          }
  12. { Modified for PCBoard v12 and 14                   Jan. 01, 1989             }
  13. { Modified for Qmodem  v4.0                         Feb. 26, 1989             }
  14.  
  15. type
  16.   str1  = string[1];
  17.   str3  = string[3];
  18.   str12 = string[12];
  19.   str20 = string[20];
  20.   str80 = string[80];
  21.  
  22. var
  23.   Command,              { Menu selection variable                             }
  24.   FileN1,               { Upcase values of optional file identifier           }
  25.   FileN2:        char;  {                                                     }
  26.   TransferType,         { Type of File Transfer desired (Z,O,Y,G,C)           }
  27.   QTransfer:     str1;  { Qmodem's Transfer type (Z,O,O,G,C)                  }
  28.   FileName:      str12; { up/download names                                   }
  29.   FileDesc:      str80; { Description of file to be uploaded                  }
  30.   FileDir:       str20; { Upload/Download Directory                           }
  31.   Count:         byte;  { a count of the # of up/dnloads (for error trapping) }
  32.   CountStr:      str3;  { Counter converted to a string                       }
  33.   ScriptFile:    text;  { file variable for script                            }
  34.   TypeOK,
  35.   FileEx:        boolean;
  36.  
  37. procedure OpenScript;
  38. begin
  39.   TextColor(Cyan);
  40.   write('              Enter 2 character BBS Identifier (Optional):  ');
  41.   TextColor(LightCyan);
  42.   readln(FileName);
  43.   if FileName<>'' then begin
  44.     Delete(FileName,3,12);
  45.       FileN1:=upcase(copy(FileName,1,1));
  46.       FileN2:=upcase(copy(FileName,2,1));
  47.       FileName:='UD'+FileN1+FileN2+'.SEG';
  48.     end;
  49.   if FileName='' then begin
  50.       FileName:='UD.SEG';
  51.     end;
  52. Assign(ScriptFile, FileName);
  53. gotoxy(61,pred(WhereY));
  54.     writeln(FileName);
  55.     rewrite(ScriptFile);
  56.     TextColor(Cyan);
  57.     write('              Enter u/l d/l Directory (omit trailing "\"): ');
  58.     TextColor(LightCyan);
  59.     readln(FileDir);
  60.     if FileDir='' then begin
  61.          FileDir:= '\QM\DL'
  62.          end;
  63.   end;
  64.  
  65. procedure WriteScript(UpDown: str1);
  66. var UpDownStr: str12;
  67.     TypeOk: boolean;
  68. begin
  69.   TextColor(LightGray);
  70.   write(' (C=Xmodem CRC, Y=PCBv12, O=PCBv14, G=Ymodem-G, <Z>=Zmodem): ');
  71.   repeat
  72.     TextColor(White);
  73.     readln(TransferType);
  74.     if  TransferType='' then begin
  75.         TransferType:= 'z';
  76.         end;
  77.     TypeOk:=(pos(upcase(TransferType),'ZOYCG')<>0);
  78.     if not TypeOk then gotoxy(1,WhereY-1);clreol;
  79.     if not TypeOk then write(#7,'Please Re-enter (C, Y, O, G, or <Z>): ');
  80.     until TypeOk;
  81.   gotoxy(16, WhereY-2);
  82.   TextColor(LightRed);
  83.   write  ('[',upcase(TransferType),']');
  84.   gotoxy(1, WhereY+1);clreol;writeln;
  85.   TextColor(White);
  86.   case upcase(TransferType) of
  87.     'Z': QTransfer:='Z';
  88.     'O': QTransfer:='O';
  89.     'Y': QTransfer:='O';
  90.     'C': QTransfer:='C';
  91.     'G': QTransfer:='G';
  92.     end;
  93.   case UpDown of
  94.     'U': UpDownStr:='UPLOAD';
  95.     'D': UpDownStr:='DOWNLOAD';
  96.     end;
  97.   Count:=succ(Count);
  98.   str(Count,CountStr);
  99.   writeln(ScriptFile,'; ******  ',UpDownStr,' [',Qtransfer,'] ',FileName,'  *****************');
  100.   writeln(ScriptFile);
  101.   writeln(ScriptFile,'WHEN      ; clear any pending WHEN commands');
  102.   writeln(ScriptFile,'TIMEOUT   4 SYNA',CountStr);
  103.   writeln(ScriptFile,'WAITFOR   "Command"');
  104.   writeln(ScriptFile);
  105.   writeln(ScriptFile,'GOTO      SYNC',CountStr);
  106.   writeln(ScriptFile,'SYNA',CountStr,':');
  107.   writeln(ScriptFile,'TIMEOUT   5 SYNB',CountStr);
  108.   writeln(ScriptFile,'SYNB',CountStr,':');
  109.   writeln(ScriptFile,'IF        $OFFLINE END_IT');
  110.   writeln(ScriptFile,'SEND      "^M"');
  111.   writeln(ScriptFile,'WAITFOR   "Command"');
  112.   writeln(ScriptFile);
  113.   writeln(ScriptFile,'SYNC',CountStr,':');
  114.   writeln(ScriptFile,'TIMEOUT   30 NEXT',CountStr); 
  115.     if UpDown='U' then begin
  116.     writeln(ScriptFile,'EXIST     ',FileDir,'\',FileName,'  CONT',CountStr);
  117.     writeln(ScriptFile,'PAUSE     1000');
  118.     writeln(ScriptFile,'ASSIGN    4 $ATTR');
  119.     writeln(ScriptFile,'COLORFG   12');
  120.     writeln(ScriptFile,'NOTE      FROM PCBUD:  ',FileDir,'\',FileName,'  *NOT*  FOUND!');
  121.     writeln(ScriptFile,'COLOR     $4');
  122.     writeln(ScriptFile,'GOTO      NEXT',CountStr);
  123.     writeln(ScriptFile);
  124.     writeln(ScriptFile,'CONT',CountStr,':');
  125.     writeln(ScriptFile,'WHEN      "duplicates" NEXT',CountStr);
  126.     writeln(ScriptFile,'WHEN      "exists"     NEXT',CountStr);
  127.     writeln(ScriptFile,'WHEN      "Keep upload inside" "Y^M"');
  128.     writeln(ScriptFile,'IF        $OFFLINE END_IT');
  129.     writeln(ScriptFile,'SEND      "',UpDown,' ',FileName,' ',upcase(TransferType),'^M"');    
  130.     writeln(ScriptFile,'WAITFOR   "description"');
  131.     writeln(ScriptFile);
  132.     writeln(ScriptFile,'TIMEOUT   30 NEXT',CountStr);
  133.     writeln(ScriptFile,'IF        $OFFLINE END_IT');
  134.     writeln(ScriptFile,'SEND      "',FileDesc,'^M"');
  135.     writeln(ScriptFile,'WHEN      "upload!"    NEXT',CountStr);
  136.     writeln(ScriptFile,'WAITFOR   "Aborts Transfer"');
  137.     writeln(ScriptFile,'PAUSE     7000');
  138.     writeln(ScriptFile,'UPLOAD    ',Qtransfer,' ',FileDir,'\',FileName);
  139.     end;
  140.     if UpDown='D' then begin
  141.     writeln(ScriptFile,'WHEN      "not found" NEXT',CountStr);
  142.     writeln(ScriptFile,'WHEN      "to Abort." DL',CountStr);
  143.     writeln(ScriptFile,'IF        $OFFLINE END_IT');
  144.     writeln(ScriptFile,'SEND      "',UpDown,' ',FileName,' ',upcase(TransferType),'^M"');
  145.     writeln(ScriptFile,'WAITFOR   "Aborts Transfer"');
  146.     writeln(ScriptFile);
  147.     writeln(ScriptFile,'DL',CountStr,':');
  148.     writeln(ScriptFile,'PAUSE     7000');
  149.     writeln(ScriptFile,'DOWNLOAD  ',Qtransfer,' ',FileDir,'\',FileName);
  150.     end;
  151.   writeln(ScriptFile);
  152.   writeln(ScriptFile,'NEXT',CountStr,':');
  153.   writeln(ScriptFile);
  154.   end;
  155.  
  156. procedure GetAscii(UpDel: Char);
  157. begin
  158.   gotoxy(1,WhereY-1);clreol;
  159.   if UpDel='A' then begin
  160.     TextColor(LightCyan);write(succ(Count),':');TextColor(White);writeln(' ASCII U/L');
  161.     end;
  162.   if UpDel='N' then begin
  163.     TextColor(LightCyan);write(succ(Count),':');TextColor(White);writeln(' ASCII NO-DEL');
  164.     end;
  165.   TextColor(Cyan);
  166.   write  ('Enter ASCII Upload File Name: ');
  167.   TextColor(LightCyan);
  168.   read   (FileName);
  169.   if FileName='' then begin;
  170.     gotoxy(1,WhereY); clreol; gotoxy(1,WhereY-1); clreol;
  171.     end;
  172.   if FileName<>'' then begin
  173.     gotoxy(1,WhereY);clreol;
  174.     gotoxy(20,WhereY-1);
  175.     TextColor(Yellow);
  176.     writeln(FileName);
  177.     writeln;
  178.     TextColor(LightGray);
  179.     Count:=succ(Count);
  180.     str(Count,CountStr);
  181.     writeln(ScriptFile,'; ******  SEND ',FileName,' ASCII *****************');
  182.     writeln(ScriptFile);
  183.     writeln(ScriptFile,'EXIST     ',FileDir,'\',FileName,'  CONT',CountStr);
  184.     writeln(ScriptFile,'PAUSE     1000');
  185.     writeln(ScriptFile,'ASSIGN    4 $ATTR');
  186.     writeln(ScriptFile,'COLORFG   12');
  187.     writeln(ScriptFile,'NOTE      FROM PCBUD:  ',FileDir,'\',FileName,'  *NOT*  FOUND!');
  188.     writeln(ScriptFile,'COLOR     $4');
  189.     writeln(ScriptFile,'GOTO      NEXT',CountStr);
  190.     writeln(ScriptFile);
  191.     writeln(ScriptFile,'CONT',CountStr,':');
  192.     writeln(ScriptFile,'WHEN      ; clear any pending WHEN commands');
  193.     writeln(ScriptFile,'TIMEOUT   4 SYNA',CountStr);
  194.     writeln(ScriptFile,'WAITFOR   "Command"');
  195.     writeln(ScriptFile);
  196.     writeln(ScriptFile,'GOTO      SYNC',CountStr);
  197.     writeln(ScriptFile,'SYNA',CountStr,':');
  198.     writeln(ScriptFile,'TIMEOUT   5 SYNB',CountStr);
  199.     writeln(ScriptFile,'SYNB',CountStr,':');
  200.     writeln(ScriptFile,'IF        $OFFLINE END_IT');
  201.     writeln(ScriptFile,'SEND      "^M"');
  202.     writeln(ScriptFile,'WAITFOR   "Command"');
  203.     writeln(ScriptFile);
  204.     writeln(ScriptFile,'SYNC',CountStr,':');
  205.     writeln(ScriptFile,'TIMEOUT   5 NEXT',CountStr);
  206.     writeln(ScriptFile,'PAUSE     1000');
  207.     writeln(ScriptFile,'SEND      "E^M"');
  208.     writeln(ScriptFile,'WAITFOR   "?"');
  209.     writeln(ScriptFile);
  210.     writeln(ScriptFile,'PAUSE     1200');
  211.     writeln(ScriptFile,'UPLD      A ',FileDir,'\',FileName,' PACECH=NONE PACESPEED=15 EXPAND=ON EOLCH=10');
  212.     writeln(ScriptFile,'TIMEOUT   110 SYND',CountStr);
  213.     writeln(ScriptFile,'SYND',CountStr,':');
  214.     writeln(ScriptFile,'IF        $OFFLINE END_IT');
  215.     writeln(ScriptFile,'SEND      "^M"');
  216.     writeln(ScriptFile,'WAITFOR   ", (SC)? "');
  217.     writeln(ScriptFile);
  218.     writeln(ScriptFile,'SEND      "S^M"');
  219.     writeln(ScriptFile);
  220.     if UpDel='A' then begin
  221.         writeln(ScriptFile,'DOS       "DEL ',FileDir,'\',FileName,'"');
  222.         writeln(ScriptFile);
  223.         end;
  224.     writeln(ScriptFile,'NEXT',CountStr,':');
  225.     writeln(ScriptFile);
  226.     end;
  227.   end;
  228.  
  229. procedure GetUpload;
  230. var Ypos: byte;
  231. begin
  232.   gotoxy(1,WhereY-1);clreol;
  233.   TextColor(LightCyan);write(succ(Count),':');TextColor(White);writeln(' UPLOAD FILE');
  234.   TextColor(Cyan);
  235.   write('Enter Upload File Name: ');
  236.   TextColor(LightCyan);
  237.   read  (FileName);
  238.   if FileName='' then begin;
  239.     gotoxy(1,WhereY); clreol; gotoxy(1,WhereY-1); clreol;
  240.     end;
  241.   if FileName<>'' then begin
  242.     gotoxy(1,WhereY);clreol;
  243.     TextColor(Yellow);
  244.     gotoxy(20,WhereY-1);
  245.     writeln(FileName);
  246.     TextColor(Green);
  247.     writeln('Enter Upload Description:      (---------------------------------------------)');
  248.     TextColor(LightRed);
  249.     write  ('You must enter a description >  ');
  250.     TextColor(LightGreen);
  251.     read  (FileDesc);
  252.     if FileDesc='' then begin;
  253.       gotoxy(1,WhereY);ClrEol;gotoxy(1,WhereY-1);ClrEol;gotoxy(1,WhereY-1);ClrEol;
  254.       end;
  255.     if FileDesc<>'' then begin
  256.       FileDesc:=Copy(FileDesc, 1, 45);
  257.       gotoxy(1,WhereY);ClrEol;gotoxy(1,WhereY-1);ClrEol;
  258.       gotoxy(33,WhereY-1);TextColor(White);write(': ');TextColor(Green);writeln(FileDesc);
  259.       TextColor(LightGray);
  260.       write('Upload Type');
  261.       WriteScript('U');
  262.       end;
  263.     end;
  264.   end;
  265.  
  266. procedure GetDownload;
  267. var Ypos: byte;
  268. begin
  269.   gotoxy(1,WhereY-1);clreol;
  270.   TextColor(LightCyan);write(succ(Count),':');TextColor(White);writeln(' DOWNLD FILE');
  271.   TextColor(Cyan);
  272.   write('Enter Download File Name: ');
  273.   TextColor(LightCyan);
  274.   read  (FileName);
  275.   if FileName='' then begin;
  276.      gotoxy(1,WhereY); clreol; gotoxy(1,WhereY-1); clreol;
  277.      end;
  278.   if FileName<>'' then begin
  279.     gotoxy(1,WhereY);clreol;
  280.     gotoxy(20,WhereY-1);
  281.     TextColor(Yellow);
  282.     writeln(FileName);
  283.     TextColor(LightGray);
  284.     write('Download Type');
  285.     WriteScript('D');
  286.     end;
  287.   end;
  288.  
  289. procedure Hangup;
  290. begin
  291.   gotoxy(1,WhereY-1);clreol;
  292.   TextColor(LightCyan);write(succ(Count),':');TextColor(White);writeln(' LOGOFF  BBS');writeln;
  293.   Count:=succ(Count);
  294.   str(Count,CountStr);
  295.   writeln(ScriptFile,'; ******  LOGOFF SEGMENT  ********************');
  296.   writeln(ScriptFile);
  297.   writeln(ScriptFile,'WHEN      ; clear any pending WHEN commands');
  298.   writeln(ScriptFile,'TIMEOUT   4 SYNA',CountStr);
  299.   writeln(ScriptFile,'WAITFOR   "Command"');
  300.   writeln(ScriptFile);
  301.   writeln(ScriptFile,'GOTO      SYNC',CountStr);
  302.   writeln(ScriptFile,'SYNA',CountStr,':');
  303.   writeln(ScriptFile,'TIMEOUT   15 SYNB',CountStr);
  304.   writeln(ScriptFile,'SYNB',CountStr,':');
  305.   writeln(ScriptFile,'IF        $OFFLINE END_IT');
  306.   writeln(ScriptFile,'SEND      "^M"');
  307.   writeln(ScriptFile,'WAITFOR   "Command"');
  308.   writeln(ScriptFile);
  309.   writeln(ScriptFile,'SYNC',CountStr,':');
  310.   writeln(ScriptFile,'PAUSE     1000');
  311.   writeln(ScriptFile);
  312.   writeln(ScriptFile,'TURNOFF   CAPTURE');
  313.   writeln(ScriptFile,'ASSIGN  4 78');
  314.   writeln(ScriptFile,'ATWRITE 12 18 $4  " ═════════════════════════════════════════════════════════ "');
  315.   writeln(ScriptFile,'ATWRITE 12 19 $4  " PRESS Esc TO STAY ONLINE WITH $BOARD "');
  316.   writeln(ScriptFile,'ATWRITE 12 20 $4  "       YOU HAVE 10 SECONDS ·············                   "');
  317.   writeln(ScriptFile,'ATWRITE 12 21 $4  " ═════════════════════════════════════════════════════════ "');
  318.   writeln(ScriptFile);
  319.   writeln(ScriptFile,'PAUSE     10000');
  320.   writeln(ScriptFile,'SEND      "G^M"');
  321.   writeln(ScriptFile,'HANGUP');
  322.   writeln(ScriptFile);
  323.   end;
  324.  
  325. begin
  326.   clrscr;
  327.   TextColor(LightGreen);
  328.   writeln(' Qmodem v4.0/PcBoard  u/l d/l SCRIPT                 Script Segment Generator');
  329.   TextColor(LightRed);
  330.   writeln('   Default segment name is  UD.SEG                    For PCBoard  v12 or 14');
  331.   TextColor(White);
  332.   writeln('    Optional format is  UDxx.SEG');
  333.   writeln(' ╘══════════════════════════════════════════════════════════════════════════╛');
  334.   OpenScript;
  335.   if FileName<>'' then begin
  336.     Count:=0;
  337.     gotoxy(1,2);
  338.     TextColor(LightGray);
  339.     writeln('┌──────────────────────────╥────────────────────────╥─────────────────────────┐');
  340.     write  ('│                                                                              ');
  341.     gotoxy(8,3);
  342.     TextColor(LightCyan);
  343.     write  ('D/L DIR: ',FileDir);
  344.     TextColor(LightGray);
  345.     gotoxy(28,3);
  346.     write  ('║  SCRIPT FUNCTION MENU  ║');
  347.     gotoxy(58,3);
  348.     TextColor(LightCyan);
  349.     write('SEGMENT = ',FileName);
  350.     gotoxy( 79,3);
  351.     TextColor(LightGray);
  352.     writeln('│');
  353.     writeln('│       ╓──────────────────╨────────────────────────╨─────────────────╖       │');
  354.     writeln('│       ║  A = Write ASCII ul segment     N = ASCII u/l  (NO delete)  ║ PUBLIC│');
  355.     writeln('│       ║  U = Write  upload  segment     D = Write download segment  ║ DOMAIN│');
  356.     writeln('│ PCBUD ║  L = Write  logoff  segment     Q = QuitSegment Generator   ║  v2.02│');
  357.     writeln('╘═══════╩═════════════════════════════════════════════════════════════╩═══════╛');
  358.     window(1,10,80,25);
  359.     gotoxy(1,1);
  360.     repeat
  361.       TextColor(LightRed);
  362.       write('Enter Command: ');TextColor(Green);write('A, N, U, D, L, <Q>: ');
  363.       TextColor(LightGreen);
  364.       read(Kbd, Command);
  365.         if  Command = #13 then
  366.             Command:= 'q';
  367.       TypeOk:=(pos(upcase(Command),'ANUDLQ')<>0);
  368.       if not TypeOk then
  369.         gotoxy(1,WhereY);
  370.       if TypeOk then
  371.       writeln;
  372.       case upcase(Command) of
  373.         'A': GetAscii('A');
  374.         'N': GetAscii('N');
  375.         'U': GetUpload;
  376.         'D': GetDownload;
  377.         'L': Hangup;
  378.         end;
  379.       until upcase(Command) in ['Q','L'];
  380.     writeln(ScriptFile,'END_IT:');
  381.     writeln(ScriptFile,'RETURN');
  382.     close(ScriptFile);
  383.     gotoxy(1,WhereY-1);clreol;writeln;
  384.     writeln('                           Thank you for using PCBUD!');
  385.     end;
  386.   window(1,1,80,25);
  387.   end.
  388.