home *** CD-ROM | disk | FTP | other *** search
/ Beijing Paradise BBS Backup / PARADISE.ISO / software / BBSDOORW / RD0421.ZIP / RDOOR.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1993-04-18  |  12.5 KB  |  473 lines
  1. {$A+,B-,D-,E-,F+,G-,I-,L-,N-,O-,R-,S+,V-,X+}
  2. {$M 65520,0,262144}
  3. Program rdoor;
  4.  
  5. Uses
  6.     CrT, Dos, Turbo3;
  7.  
  8. {$I Records.pas}
  9.  
  10. { Define this if this is a beta test }
  11. { Define Beta}
  12.  
  13. Const                         
  14.     Title = 'KludgeWare! RDoor';
  15. {$IFDEF Beta}    
  16.     Version = ' V1.2 Beta';
  17. {$ELSE}
  18.     Version = ' V1.2';
  19. {$ENDIF}
  20.  
  21. (*--------------------------------------------------------------------------
  22. The I/O section is (c) copyright 1988-91 Santronics Software
  23. Taken from the TPascal squish API
  24. ----------------------------------------------------------------------------*)
  25.  
  26. Const
  27.     { Used for SHARE support }     
  28.     _KEEP_MODE  = -1;             { DO NOT CHANGE FILE MODE IN FOPEN }
  29.                                   { share mode DOs 3++ and above }
  30.  
  31.     _READONLY   = $00;         _DENYALL    = $10;
  32.     _WRITEONLY  = $01;         _DENYWRITE  = $20;
  33.     _READWRITE  = $02;         _DENYREAD   = $30;
  34.                                _DENYNONE   = $40;
  35.  
  36. Const LockRegion   = 00;
  37.       UnLockRegion = 01;
  38.  
  39. type
  40.     dsysinfrec = record
  41.         sl     : byte;     { Security Level, Read back (Line 15) }
  42.         uPos : longint;  { Users file record number, Use to locate user (Line 26) }
  43.         UL     : word;     { Total uploads, Read back (Line 28) }
  44.         Dl     : word;     { Total downloads, Read back (Line 29) }
  45.         daydK : word;     { Daily download "K" total, Read back (Line 30) }
  46.         tcred : longint; { Time Credits in minutes, CAN'T read back (Line 42) }
  47.         fdltdy : word;     { Files downloaded today, Read back (Line 47) }
  48.         tkupl : longint; { Total K uploaded, Read back (Line 48) }
  49.         tkdl : Longint;  { Total K Downloaded, Read back (Line 49) }
  50.     end;  {  Rec  }
  51.     
  52.     STREAM = file;
  53.     str80 = string [80];
  54. Var
  55.     Copyright : str80;
  56.     dSyspath,
  57.     uDatPath  : str80;
  58.     ecode     : byte;
  59.     urec      : userrec;
  60.     dinf      : dsysinfrec;
  61.     fluff     : boolean;
  62.  
  63. {  ────────────────────────────────────────────────────────────  }
  64.  
  65. function fopen(var fv   : stream;
  66.                    fn   : pathstr;
  67.                    mode : integer
  68.                       ) : integer;
  69. {open untyped file return the dos error code}
  70. var
  71.     fm : byte;
  72.     isgood : integer;
  73. begin
  74.     assign(fv,fn);
  75.     fm := filemode;
  76.     if mode <> _KEEP_MODE then filemode := mode;
  77.     reset(fv,1);
  78.     isgood := ioresult;
  79.     fopen := isgood;
  80.     filemode := fm;
  81.  
  82. {$IFDEF Beta}
  83.     if isgood = 0 then
  84.         Writeln('+ File: ', fn, ' is now opened.')
  85.     else
  86.         writeln('! File: ', fn, ' did not open correctly for some reason.');
  87. {$ENDIF}
  88.  
  89. end;
  90.  
  91. function  fclose(var fv : stream) : integer;
  92. begin
  93.    close(fv);
  94.    fclose := ioresult;
  95. end;
  96.  
  97. Function ShareLoaded : Boolean;
  98. var reg : registers;
  99. begin
  100.     reg.ax := $1000;
  101.     Intr($2F,reg);
  102.     ShareLoaded := ((reg.flags and $01) = 0) and (reg.al = $FF);
  103. end;
  104.  
  105. (*
  106.  
  107. Lock or Unlock region of file.
  108.  
  109. Input         : Handle  - turbo untype file variable handle (filerec(fv).handle)
  110. input         : action  - action to take. See constants above;
  111. input         : start   - beginging file position to lock.
  112. input         : bytes   - number of bytes to lock.
  113. output        : ax      - ax register return value
  114.  
  115. returns TRUE if lock is successful, False otherwise (check AX)
  116.  
  117. *)
  118.  
  119. Function FileLock(handle : word; action : byte; start,bytes : longint; var ax : integer): Boolean;
  120. var
  121.     reg : registers;
  122.     isgood : boolean;
  123. begin
  124.  
  125.     reg.ax := $5C00 + action;
  126.     reg.bx := handle;
  127.     reg.cx := hi(start);
  128.     reg.dx := lo(start);
  129.     reg.si := hi(bytes);
  130.     reg.di := lo(bytes);
  131.  
  132.     Intr($21,reg);
  133.     isgood := (reg.flags and $01) = $00;
  134.     filelock := isgood;
  135.     ax := reg.ax;
  136.     
  137. {$IFDEF Beta}
  138.     if isgood then
  139.         writeln('+ File locked correctly.')
  140.     else
  141.         writeln('! Problem locking file.');
  142. {$ENDIF}
  143.  
  144. end;
  145.  
  146.  
  147.  
  148. Procedure Show_Copyright;
  149. Begin  {  Show_Copyright  }
  150.  
  151. {$IFDEF Beta}
  152.     Writeln('- Displaying Copyright notice');
  153. {$ELSE}
  154.     Clrscr;
  155. {$ENDIF}
  156.     Writeln(Title+Version+' is');
  157.  
  158.     Writeln('is ', Copyright);
  159.     Writeln('All Rights Reserved');
  160.     writeln;
  161.  
  162.     Writeln('This program may be freely distributed and used as LONG as there are');
  163.     Writeln('NO modifications to the executable or documentation files, and that');
  164.     Writeln('there are NO files added to the distribution archive.');
  165.     
  166.     Writeln('No registration fee for this program is required.');
  167.     writeln;
  168.     
  169. End;   {  Show_Copyright  }
  170.  
  171. {  ────────────────────────────────────────────────────────────  }
  172.  
  173. Procedure Killit(Errnum : byte; errmess : str80);
  174. Begin  {  Killit  }
  175.  
  176. {$IFDEF Beta}
  177.     Writeln('= Shutting down the program.');
  178. {$ENDIF}
  179.  
  180.     Writeln(errmess);
  181.     halt(errnum);
  182.  
  183. End;   {  Killit  }
  184.  
  185. {  ────────────────────────────────────────────────────────────  }
  186.  
  187. Procedure Show_help;
  188. Begin  {  Show_help  }
  189.  
  190. {$IFDEF Beta}
  191.     Writeln('! User did not enter in command line correct.');
  192. {$ENDIF}
  193.     Textcolor(14);
  194.  
  195.     Writeln('rDoor is run with two REQUIRED commandline parameters in the following');
  196.     Writeln( 'manner:');
  197.     Writeln;
  198.  
  199.     Writeln('rDoor c:\rg\doorpath\ c:\rg\data\');
  200.     Writeln;
  201.  
  202.     Writeln('The first path is the path to the door.sys to read into the bbs, and');
  203.     Writeln('the second path is the path to your USERS.DAT.  You MUST include the');
  204.     Writeln('trailing backslash on the end of each path, and BOTH paths are needed');
  205.     Writeln('for the program to run correctly.');
  206.  
  207.     Textcolor(15);
  208.  
  209. End;   {  Show_help  }
  210.  
  211. {  ────────────────────────────────────────────────────────────  }
  212.  
  213. Function Start_Up(var dsyspath,
  214.                       udatpath    : str80; 
  215.                   var ecode     : byte) : boolean;
  216. {
  217.     Parses commandline to find path to users.dat and path to door.sys, 
  218.     also displays help text if not found.
  219. }
  220. var
  221.     isgood : boolean;
  222.     p1,
  223.     p2       : str80;
  224. Begin  {  Start_Up  }
  225.  
  226. {$IFDEF Beta}
  227.     writeln('- Starting program.');
  228. {$ENDIF}
  229.     Copyright := 'Copyright 1992 By Patrick Spence';
  230.     isgood := false;
  231.     textcolor(15);
  232.     
  233.     Show_Copyright;
  234.  
  235.     If (paramcount > 2) or (paramcount < 1) then
  236.     begin
  237.         Show_Help;
  238.     end
  239.     else
  240.     begin
  241.         p1 := paramstr(1);
  242.         p2 := paramstr(2);
  243.         dsyspath := p1+'door.sys';
  244.         udatpath := p2+'users.dat';
  245.         isgood := true;
  246. {$IFDEF Beta}
  247.         writeln('- Parameter 1 is    : ', p1);
  248.         writeln('- Parameter 2 is    : ', p2);
  249.         writeln('- Door.sys path is  : ', dsyspath);
  250.         writeln('- Users.dat path is : ', udatpath);
  251. {$ENDIF}
  252.     end;
  253.  
  254.     start_up := isgood;
  255.     
  256. End;   {  Start_Up  }
  257.  
  258. {  ────────────────────────────────────────────────────────────  }
  259.  
  260. Procedure Action(   dSyspath,
  261.                     uDatpath  : Str80;
  262.                  var ecode    : byte);
  263. {
  264.     Opens door.sys, reads the pertanant info, and updates the correct 
  265.     user record.
  266. }
  267. var
  268.     ud       : stream;
  269.     ds       : text;
  270.     sizerec  : longint;
  271.     filepos  : longint;
  272.     tStr     : str80;
  273.     tfluff   : str80;
  274.     error    : byte;
  275.     ax       : integer;
  276.     flf      : boolean;
  277.     loop     : byte;
  278.  
  279. Begin  {  Action  }
  280.  
  281.     sizerec := sizeof(urec);
  282. {$IFDEF Beta}
  283.     writeln('- User record size is : ', sizerec);
  284. {$ENDIF}
  285.  
  286.     assign(ds, dsyspath);
  287.     reset(ds);
  288.     error := ioresult;
  289. {$IFDEF Beta}
  290.     if error <> 0 then
  291.         writeln('! Unable to open door.sys at ', dsyspath)
  292.     else
  293.         writeln('+ Door.sys opened at ', dsyspath);
  294. {$ENDIF}
  295.     if error > 0 then Killit(error, 'Error opening DOOR.SYS, Check Configuration');
  296.     for loop := 1 to 14 do
  297.     begin
  298.         readln(ds, tfluff);
  299. {$IFDEF Beta}    
  300.         writeln('- Unused data on line: ', loop, ' is ', tfluff);
  301. {$ENDIF}
  302.     end;
  303.     readln(ds, dinf.sl);
  304. {$IFDEF Beta}    
  305.         writeln('+ Users security level is: ', dinf.sl);
  306. {$ENDIF}
  307.     for loop := 16 to 25 do
  308.     begin
  309.         readln(ds, tfluff);
  310. {$IFDEF Beta}    
  311.         writeln('- Unused data on line: ', loop, ' is ', tfluff);
  312. {$ENDIF}
  313.     end;
  314.     readln(ds, dinf.uPos);
  315. {$IFDEF Beta}    
  316.     writeln('+ Users Number is: ', dinf.uPos);
  317. {$ENDIF}
  318.     readln(ds, tfluff);
  319. {$IFDEF Beta}    
  320.     writeln('- Unused data on line: 27 is ', tfluff);
  321. {$ENDIF}
  322.     readln(ds, dinf.ul);
  323. {$IFDEF Beta}    
  324.     writeln('+ Users number of uploads is: ', dinf.ul);
  325. {$ENDIF}
  326.     readln(ds, dinf.dl);
  327. {$IFDEF Beta}    
  328.     writeln('+ Users number of downloads is: ', dinf.dl);
  329. {$ENDIF}
  330.     readln(ds, dinf.daydk);
  331. {$IFDEF Beta}    
  332.     writeln('+ Users number of K d/l today is: ', dinf.daydk);
  333. {$ENDIF}
  334.     for loop := 31 to 41 do
  335.     begin
  336.         readln(ds, tfluff);
  337. {$IFDEF Beta}    
  338.         writeln('- Unused data on line: ', loop, ' is ', tfluff);
  339. {$ENDIF}
  340.     end;
  341.     readln(ds, dinf.tcred);
  342. {$IFDEF Beta}    
  343.     writeln('+ Users time credits (unused) is: ', dinf.tcred);
  344. {$ENDIF}
  345.     for loop := 43 to 46 do
  346.     begin
  347.         readln(ds, tfluff);
  348. {$IFDEF Beta}    
  349.         writeln('- Unused data on line: ', loop, ' is ', tfluff);
  350. {$ENDIF}
  351.     end;
  352.     readln(ds, dinf.fdltdy);
  353. {$IFDEF Beta}    
  354.     writeln('+ Users number of files downloaded today is: ', dinf.fdltdy);
  355. {$ENDIF}
  356.     readln(ds, dinf.tkupl);
  357. {$IFDEF Beta}    
  358.     writeln('+ Users total K uploaded is: ', dinf.tkupl);
  359. {$ENDIF}
  360.     readln(ds, dinf.tkdl);
  361. {$IFDEF Beta}    
  362.     writeln('+ Users total K downloaded is: ', dinf.tkdl);
  363. {$ENDIF}
  364.     close(ds);
  365. {$IFDEF Beta}    
  366.     writeln('- Door.sys is now closed.');
  367. {$ENDIF}
  368.  
  369.  
  370.     error := fopen(ud, udatpath, _readwrite);
  371.     if error > 0 then Killit(error, 'Error opening USERS.DAT, check configuration');
  372.     filepos := sizerec*dinf.upos;
  373. {$IFDEF Beta}
  374.     writeln('- Seeking in USERS.DAT to byte position: ', filepos);
  375. {$ENDIF}
  376.     seek(ud, filepos);
  377. {$IFDEF Beta}
  378.     writeln('- Reading in Users record from user.dat');
  379. {$ENDIF}
  380.     blockread(ud, urec, sizerec);
  381.     error := ioresult;
  382. {$IFDEF Beta}
  383.     if (error=0) then
  384.         writeln('+ User read in is: ', urec.name);
  385. {$ENDIF}
  386.     if error > 0 then killit(error, 'Error accessing USERS.DAT');
  387.     with urec do
  388.     begin
  389.         sl := dinf.sl;             { Security Level, Read back (Line 15) }
  390. {$IFDEF Beta}
  391.     writeln('+ SL written to record: ', sl);
  392. {$ENDIF}
  393.         uploads := dinf.UL;        { Total uploads, Read back (Line 28) }
  394. {$IFDEF Beta}
  395.     writeln('+ Total uploads written to record: ', uploads);
  396. {$ENDIF}
  397.         downloads := dinf.Dl;      { Total downloads, Read back (Line 29) }
  398. {$IFDEF Beta}
  399.     writeln('+ Total downloads written to record: ', downloads);
  400. {$ENDIF}
  401.         dlktoday := dinf.daydK;    { Daily download "K" total, Read back (Line 30) }
  402. {$IFDEF Beta}
  403.     writeln('+ Downloads today written to record: ', dlktoday);
  404. {$ENDIF}
  405.         dltoday := dinf.fdltdy;    { Files downloaded today, Read back (Line 47) }
  406. {$IFDEF Beta}
  407.     writeln('+ Number of files d/l today written to record: ', dltoday);
  408. {$ENDIF}
  409.         uk := dinf.tkupl;          { Total K uploaded, Read back (Line 48) }
  410. {$IFDEF Beta}
  411.     writeln('+ Total K uploaded written to record: ', uk);
  412. {$ENDIF}
  413.         dk := dinf.tkdl;           { Total K Downloaded, Read back (Line 49) }
  414.     end;  {  With  }
  415.     
  416. {$IFDEF Beta}
  417.     writeln('- Seeking in USERS.DAT to byte position: ', filepos);
  418. {$ENDIF}
  419.     seek(ud, filepos);
  420. {$IFDEF Beta}
  421.     writeln('- Writing to Users.dat from record in memory.');
  422. {$ENDIF}
  423.     blockwrite(ud, urec, sizerec);
  424.     error := ioresult;
  425. {$IFDEF Beta}
  426.     if (error=0) then
  427.         writeln('+ Record written to users.dat');
  428. {$ENDIF}
  429.     if error > 0 then killit(error, 'Error accessing USERS.DAT');
  430.  
  431.     error := fclose(ud);
  432.     if error > 0 then Killit(error, 'Error Closing USERS.DAT');
  433.  
  434. End;   {  Action  }
  435.  
  436. {  ────────────────────────────────────────────────────────────  }
  437.  
  438. Procedure Shut_Down(ecode : byte);
  439. {
  440.     performs cleanup activity.
  441. }
  442. Begin  {  Shut_Down  }
  443.  
  444. {$IFDEF Beta}
  445.     writeln('- Shutting down program.');
  446. {$ENDIF}
  447.     Gotoxy(1, 22);
  448.     killit(ecode, 'Thank you for using another fine KludgeWare! Product.');
  449.  
  450. End;   {  Shut_Down  }
  451.  
  452. {  ────────────────────────────────────────────────────────────  }
  453.  
  454. Begin  {  rDoor  }
  455.  
  456. {$IFDEF Beta}
  457.     assign (output, '');
  458.     rewrite(output);
  459.     Writeln('+ Calling Initialzation procedure.');
  460. {$ENDIF}
  461.     Fluff := Start_Up(dSyspath, uDatpath, ecode);
  462. {$IFDEF Beta}
  463.     writeln('+ Calling main action procedure.');
  464. {$ENDIF}
  465.     if fluff then
  466.         Action(dSyspath, uDatpath, ecode);
  467. {$IFDEF Beta}
  468.     writeln('+ Calling shut down procedure.');
  469. {$ENDIF}
  470.     Shut_Down(ecode);
  471.  
  472. End.   {  rDoor  }
  473.