home *** CD-ROM | disk | FTP | other *** search
/ Beijing Paradise BBS Backup / PARADISE.ISO / software / BBSDOORW / LD112Q.ZIP / LHDOOR.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1993-01-04  |  15.0 KB  |  405 lines
  1. {PROGRAM           : LHDOOR
  2.  
  3.  AUTHORS           : Jan Maaskant(RBBS)  -        Expansions        - 692-0377 - 1:387/301
  4.                      Jon Hamlin(QuickBBS)- The Programmers Paradise - 654-9134 - 1:387/609
  5.  
  6.  PURPOSE           : This isn't really a full scale door, and was never
  7.                      meant to be,  it is meant more as a 'quick fix'
  8.                      for use with a new file compression scheme until
  9.                      one of the more inspired and talented folks out
  10.                      out there decides to make a -real- LHarc door.
  11.  
  12.  OTHER STUFF       : Jon and I continually slash at each other's code,
  13.                      fact is you'll find a lot in here that was done by
  14.                      either of us.  However we don't agree on a lot of
  15.                      things,  and the version of this running on either
  16.                      of our BBS's will usually look and feel -different-
  17.                      Doesn't bother us,  if it bother's you your welcome
  18.                      to slash the code into whatever shape you like,
  19.                      just leave our names in (or suffer horrible
  20.                      agony in the hereafter...) and shoot us a copy
  21.                      if you did any good.
  22. }
  23.  
  24. {$M $4000,0,0}                     {Needed since we use the Exec function }
  25. Uses DOS;
  26.  
  27. var
  28.   choice        : string[1];
  29.   fname         : string[8];
  30.   NewFile       : String[8];
  31.   file_found    : boolean;
  32.   paths         : text;
  33.   path          : string[255];
  34.   fullfilename  : text;
  35.   killarcs      : text;
  36.   di            : Text;
  37.   ch            : string[1];
  38.   Dummy         : String[50];
  39.   i             : Integer;
  40.   U_Security    : Integer;
  41.   U_ANSI        : Integer;
  42.   Set_Sec       : Integer;
  43.   ValidChoice   : Boolean;
  44.   IndFName      : String[80];
  45.   Current       : String[255];
  46.   CmdStr        : String[255];
  47.   DelStr        : String[255];
  48.  
  49. procedure colormenu;
  50. begin
  51.   writeln('C╔══════════════════════════╡LHDOOR╞═s');
  52.   writeln('u═════════════════════════╗HC║         LHZ/ZIP/PAK/ARCs');
  53.   writeln('u Conversion and Viewing Door        ║HC║             s');
  54.   writeln('u          Version 1.12                         ║HC║  s');
  55.   writeln('u                                                          ║');
  56.   writeln('HC║            Inquiries to: Expansions RBBS            s');
  57.   writeln('u       ║HC║                          (512)349-8227   s');
  58.   writeln('u                  ║HC║                          1:387s');
  59.   writeln('u/301                         ║HC║                Quics');
  60.   writeln('ukbbs: The Programmer''s Paradise         ║HC║        s');
  61.   writeln('u                  (512)654-9134                     ║Hs');
  62.   writeln('uC║                          1:387/609                   s');
  63.   writeln('u      ║HC║──────────────────────────────┬───────s');
  64.   writeln('u──────────────────────╢HC║ View              s');
  65.   writeln('u           │        Conversion           ║Hs');
  66.   writeln('uC║ ~~~~                         │        ~~~~s');
  67.   writeln('u~~~~~~           ║HC║ [D] Display file ins');
  68.   writeln('uside LHARC│        [E] Self-extractins');
  69.   writeln('ug  ║HC║ [L] List                     s');
  70.   writeln('u│        [P] PAK file         ║HC║s');
  71.   writeln('u [O] Old style view           │        s');
  72.   writeln('u[S] SEA''s style ARC  ║HC║ [Vs');
  73.   writeln('u] View                     │        [Zs');
  74.   writeln('u] Zip Format       ║HC║                    [Qs');
  75.   writeln('u] Quit back to BBS                    ║HC╚════════A');
  76.   writeln('C══════════════════════╧═════════════════════════════╝');
  77.   writeln;
  78.   write('         Choice: ');
  79. end;
  80.  
  81. procedure monomenu;
  82. begin
  83. writeln;
  84.   writeln('                     LHDOOR');
  85.   writeln('   LZH/ZIP/PAK/ARC Conversion and Viewing Door');
  86.   writeln('                 Version 1.12');
  87.   writeln;
  88.   writeln('   VIEW LZH file                     CONVERT');
  89.   writeln('   ----                              -------');
  90.   writeln('(L)ist                           (E) Self Extracting');
  91.   writeln('(V)iew                           (P) PAK file');
  92.   writeln('(O)ld style view                 (S) SEA'' style ARC');
  93.   writeln('(D)isplay file inside a LHARC    (Z) Zip format');
  94.   writeln;
  95.   writeln('                (Q)uit back to BBS');
  96.   writeln;
  97.   write('Choice: ');
  98. end;
  99.  
  100. procedure up_choice;
  101. var
  102.   ch : char;
  103. begin
  104.   ch := choice[1];
  105.   ch := upcase(ch);
  106.   choice := ch;
  107. end;
  108.  
  109. procedure get_file_name;
  110. var
  111.   dimwit : boolean;
  112. begin
  113.   dimwit := true;
  114.     while dimwit do
  115.     begin
  116.       write('          Enter the filename (No Extension) > ');
  117.       readln(Fname);
  118.       writeln;
  119.       dimwit :=false;  {intelligent until proven dimwitted}
  120.       if fname='' then
  121.         begin
  122.           writeln('Not even remotely valid...');
  123.           dimwit := true;
  124.         end
  125.       else begin
  126.              i := 1;
  127.              NewFile := '';
  128.              While (fname[i] <> '.') and (i <= Length(fname)) do
  129.                begin
  130.                  NewFile := NewFile + fname[i];
  131.                  i := i + 1;
  132.                end;
  133.              fname := NewFile;
  134.            end;
  135.       end;  {If they added an extension}
  136. end;
  137.  
  138. procedure find_file;
  139. begin
  140.     write('          Now searching for the file');
  141.     reset(paths);
  142.     file_found := false;
  143.     while (not(eof(paths)) and not(file_found)) do
  144.       begin
  145.         path := '';
  146.         ch := 'Y';
  147.         while ((ch <> ' ') and not(eof(paths))) do
  148.           begin
  149.             read(paths,ch);
  150.             if ch <> ' '
  151.               then path := path + ch;
  152.           end;
  153.         ch := '';
  154.         Readln(paths,Set_Sec);
  155.         path := path + '\';
  156.         assign(fullfilename,path+fname+'.LZH');
  157.         {$I-}
  158.           reset(fullfilename);
  159.         {$I+}
  160.         if (IORESULT=0) and (Set_Sec <= U_Security)
  161.           then
  162.             file_found := TRUE
  163.           else
  164.               write('.');
  165.       end;
  166.     writeln;
  167. end;
  168.  
  169. PROCEDURE CHOICE_E;
  170.         begin
  171.           writeln;
  172.           writeln('          File located...');
  173.           writeln('          Creating self-extracting file now,  please hold...');
  174.           MkDir('\_$LHTMP');
  175.           ChDir('\_$LHTMP');
  176.           Exec('C:\COMMAND.COM',' /C LHARC s '+PATH+FNAME+' > NUL:');
  177.           Exec('C:\COMMAND.COM',' /C COPY '+FNAME+'.COM '+PATH+FNAME+'.COM');
  178.           Exec('C:\COMMAND.COM',' /C DEL '+FNAME+'.COM');
  179.           ChDir(Current);
  180.           RmDir('\_$LHTMP');
  181.           writeln('          The file is ',fname,'.COM, but is not listed.');
  182.           writeln('          It will be DELETED in the nightly event');
  183.           writeln('          so   -Get it NOW-');
  184.           Writeln;
  185.           Writeln('          Hit Enter to continue');
  186.           ReadLn;
  187.           assign(killarcs,'KILLARCS.BAT');
  188.           {$I-}
  189.           append(killarcs);
  190.           {$I+}
  191.           if not(ioresult=0) then rewrite(killarcs);
  192.           writeln(killarcs,'DEL ',path+fname,'.EXE');
  193.           close(killarcs);
  194.         end;
  195.  
  196. procedure choice_VLOD;
  197. var
  198.   fspec   : string[255];
  199. begin
  200.           if choice='O' then Exec('C:\COMMAND.COM','/C LVIEW '+path+fname);
  201.           if choice='V' then Exec('C:\COMMAND.COM','/C LHARC V '+path+fname);
  202.           if choice='L' then Exec('C:\COMMAND.COM','/C LHARC L '+path+fname);
  203.           if choice='D' then
  204.             begin
  205.               writeln('                   LHarc Internal File Display');
  206.               writeln(' ^S <CTRL S> & ^Q to start and stop your display, ^C to abort.');
  207.               writeln;
  208.               Exec('C:\COMMAND.COM','/C LHARC L '+path+fname);
  209.               writeln('Enter the filespec you wish to VIEW or [ENTER] for all files');
  210.               write('within '+fname+': ');
  211.               readln(fspec);
  212.               writeln('        Please turn on CAPTURE now!');
  213.               writeln('        -------Begin Display-------');
  214.               Exec('C:\COMMAND.COM',' /C LHARC P '+path+fname+' '+fspec+' | MORE');
  215.               writeln('        --------End Display--------');
  216.             end;
  217.           Write('         Press [ENTER] to contine: ');
  218.           Readln;
  219. end;
  220.  
  221. procedure choice_spz;
  222.         begin
  223.           writeln;
  224.           write('          FOUND!  Now creating the archive in ');
  225.           if choice='S' then write ('SEA''s ARC ');
  226.           if choice='P' then write ('NoGate''s PAK ');
  227.           if choice='Z' then write ('Katz''s ZIP ');
  228.           writeln('compatible format');
  229.           writeln('          This could take several moments for a large file!');
  230.           assign(killarcs,'KILLARCS.BAT');
  231.           {$I-}
  232.           append(killarcs);
  233.           {$I+}
  234.           if not(ioresult=0) then rewrite(killarcs);
  235.           if choice <> 'P'
  236.              then writeln(killarcs,'DEL ',path+fname,'.ARC')
  237.              else if choice = 'P'
  238.                      then writeln(killarcs,'DEL ',path+fname,'.PAK')
  239.                      else writeln(killarcs,'DEL ',path+fname,'.ZIP');
  240.           close(killarcs);
  241.           Mkdir('\_$LHTMP');
  242.           Chdir('\_$LHTMP');
  243.           Exec('C:\COMMAND.COM',' /C LHARC '+path+fname+' > _LHTMP');
  244.           Exec('C:\COMMAND.COM',' /C LHARC e /m '+PATH+FNAME);
  245.           If choice <> 'Z'
  246.              then CmdStr := 'PAK A '
  247.              else CmdStr := 'PKZIP -A -EX ';
  248.           if choice = 'S' then CmdStr := CmdStr+'/C ';
  249.           if choice  <> 'Z'
  250.              then CmdStr := CmdStr+'/WA ';
  251.           CmdStr := CmdStr+path+Fname+' ';
  252.           Assign(di,'_LHTMP');
  253.           reset(di);
  254.           ch := 'Z';
  255.           While (ch <> '-') do
  256.               Readln(di,ch);
  257.           ch := 'Z';
  258.           While (ch <> '-') do
  259.             begin
  260.               Read(di,ch);
  261.               If ch <> '-'
  262.                  then begin
  263.                         IndFName := '';
  264.                         While ch = ' ' do
  265.                           Read(di,ch);
  266.                         IndFName := ch;
  267.                         While ch <> ' ' do
  268.                           begin
  269.                             Read(di,ch);
  270.                             IndFname := IndFname + ch;
  271.                           end;
  272.                         Readln(di);
  273.                         CmdStr := CmdStr+IndFName+' ';
  274.                       end;
  275.             end;
  276.           Close(di);
  277.           Exec('C:\COMMAND.COM',' /C '+CmdStr);
  278.           reset(di);
  279.           ch := 'Z';
  280.           While (ch <> '-') do
  281.               Readln(di,ch);
  282.           ch := 'Z';
  283.           While (ch <> '-') do
  284.             begin
  285.               Read(di,ch);
  286.               If ch <> '-'
  287.                  then begin
  288.                         IndFName := '';
  289.                         While ch = ' ' do
  290.                           Read(di,ch);
  291.                         IndFName := ch;
  292.                         While ch <> ' ' do
  293.                           begin
  294.                             Read(di,ch);
  295.                             IndFname := IndFname + ch;
  296.                           end;
  297.                         Readln(di);
  298.                         Exec('C:\COMMAND.COM',' /C DEL '+IndFName);
  299.                       end;
  300.             end;
  301.           Close(di);
  302.           Exec('C:\COMMAND.COM',' /C DEL _LHTMP');
  303.           ChDir(Current);
  304.           RmDir('\_$LHTMP');
  305.           if choice='S' then
  306.             begin
  307.               Exec('C:\COMMAND.COM',' /C COPY '+path+fname+'.PAK '+path+fname+'.ARC');
  308.               Exec('C:\COMMAND.COM',' /C DEL '+path+fname+'.PAK');
  309.             end;
  310.             writeln;
  311.           if Choice = 'Z'
  312.              then
  313.                writeln('          Conversion complete, file is ',fname,'.ZIP.')
  314.             else if choice <> 'P'
  315.              then
  316.                writeln('          Conversion complete, file is ',fname,'.ARC.')
  317.              else
  318.                writeln('          Conversion complete, file is ',fname,'.PAK.');
  319.  
  320.                writeln('          It is available for download, but is not in');
  321.                writeln('          the file listings.');
  322.                writeln('          NOTE: this file will be DELETED in the nightly event');
  323.                writeln('                -So get it now-');
  324.                Writeln('          Hit Enter to continue');
  325.                ReadLn;
  326.              end;
  327.  
  328. procedure not_found_msg;
  329.       begin
  330.         writeln;
  331.         writeln('          Sorry,  the file ',fname,'.LZH was not found on the disk');
  332.         writeln('          If this is the correct name then please inform the sysop of the');
  333.         writeln('          problem.  If this was not the correct name then please feel');
  334.         writeln('          free to try again.');
  335.         writeln;
  336.         write('Press [ENTER] ');
  337.         readln;
  338.         writeln;
  339.         writeln;
  340.       end;  {Bad file was entered}
  341.  
  342. procedure get_user_info;
  343. begin
  344.       Assign(di,'DORINFO1.DEF');
  345.       Reset(di);
  346.       for i := 1 to 9 do Readln(di, Dummy);
  347.       Readln(di,U_ANSI);
  348.       Readln(di,U_Security);
  349.       Close(di);
  350. end;
  351.  
  352. {-------------------Main Loop-------------------}
  353.  
  354. begin
  355.   while TRUE do
  356.     BEGIN
  357.       GetDir(0,Current);
  358.       get_user_info;
  359.       ValidChoice := False;
  360.       while not ValidChoice do
  361.         begin
  362.           ASSIGN (PATHS,'flsearch.ctl');
  363.           choice := 'Y';
  364.           while not ((choice='P') or
  365.                      (choice='D') or
  366.                      (choice='S') or
  367.                      (choice='Q') or
  368.                      (choice='V') or
  369.                      (choice='L') or
  370.                      (choice='E') or
  371.                      (choice='O') or
  372.                      (choice='Z')) do
  373.             begin
  374.               if U_ANSI = 0
  375.                  then monomenu
  376.                  else colormenu;
  377.               readln(choice);
  378.               up_choice;
  379.             end;
  380.  
  381.           IF CHOICE = 'Q' then HALT(0) else
  382.             begin
  383.               get_file_name;
  384.               find_file;
  385.               if not(file_found) then not_found_msg;
  386.               if (file_found) then
  387.               if   choice='E'  then choice_E;
  388.               if (((choice='V') or
  389.                   (choice='L') or
  390.                   (choice='O') or
  391.                   (choice='D')) and
  392.                   file_found) then CHOICE_VLOD;
  393.               if (((choice='S') or
  394.                   (choice='P') or
  395.                   (choice='Z')) and
  396.                   file_found) then CHOICE_SPZ;
  397.             end;
  398.  
  399.           {$I-}
  400.             close(paths);
  401.           {$I+}
  402.         end;
  403.     end; {While not validchoice do}
  404. end.
  405.