home *** CD-ROM | disk | FTP | other *** search
/ Beijing Paradise BBS Backup / PARADISE.ISO / software / BBSDOORW / SHSUCD11.ZIP / SHSUSERV.ADA < prev    next >
Encoding:
Text File  |  1995-12-08  |  13.7 KB  |  493 lines
  1. --************************************************************************
  2. --
  3. --  SHSUServ.ADA               Version 3.0
  4. --
  5. --
  6. --  A copyright-reserved, free use program.  Use at your own risk.
  7. --  (c)John H. McCoy, 1994,1995 Sam Houston St. Univ., TX 77341-2206
  8. --************************************************************************
  9. -- For Meridian ADA286
  10. -- compile -fs -g -K
  11. -- bamp with -M 5000 -s 44500 -G for 48 sessions
  12. --
  13.  
  14. with Types;        use Types;
  15. with NetBios;      use NetBios;
  16. with Drivers;      use Drivers;
  17. with ServerTasks;  use ServerTasks;
  18. with CDRoms;       use CDRoms;
  19. with system;
  20. with memory;
  21. with program_control;
  22. with text_io;      use text_io;
  23. with text_handler; use text_handler;
  24. with arg;
  25. with tty,box,cursor,video,common_display_types;
  26. with unchecked_deallocation, unchecked_conversion;
  27.  
  28.  
  29. procedure SHSUServ is
  30.  
  31. -- Need more than the default 20 handles per process
  32.  
  33.    NewHandles  : bytes(1..255);
  34.  
  35.  
  36. MaxSessions    : constant := 48;
  37. LastCD         : integer := -1;
  38.  
  39. NCB            : NetBiosCmdBlks;
  40. package NB_SS48 is new NB_SSTypes(MaxSessions);use NB_SS48;
  41. NBSS           : NB_SS48.NB_SSs;
  42.  
  43. ServerName     : string16 := ("SHSU-CD-SERVER  ");
  44.  
  45. CDTbl          : CDArrayAccess;
  46.  
  47. NET            : NetAccess := new Nets;
  48. HUB            : SchedulerAccess := new Schedulers;
  49.  
  50. SessionTable   : array (1..MaxSessions ) of SessionsAccess;
  51.  
  52. xch            : common_display_types.byte;
  53. ch             : character;
  54. CMD_Parm_Error : exception;
  55.  
  56. function to_caps (C: character) return character is
  57. begin
  58.   if (C >= 'a' and C<= 'z') then
  59.     return character'val(character'pos(C) -32);
  60.   else
  61.     return c;
  62.   end if;
  63. end to_caps;
  64.  
  65. procedure get_parms is
  66.   parm: text(60);
  67. begin
  68.   for i in 2..arg.count loop      -- first arg is program name
  69.     set(parm, arg.data(i));       -- convert string argument to text object.
  70.  
  71.     if not empty(parm) then
  72.       if value(parm)(1) = '-' or value(parm)(1) = '/' then
  73.         if length(parm) >= 4 then
  74.           case value(parm)(2) is
  75.             when 's'|'S' =>
  76.               if length(parm) > 19 then
  77.                 put_line("Server name to long.  Max is 16 characters.");
  78.                 raise CMD_Parm_Error;
  79.               else
  80.                 ServerName := (others=> ' ');
  81.                 ServerName(1..length(parm)-3) := value(parm)(4..length(parm));
  82.                 for i in 1..16 loop
  83.                   ServerName(i) := to_caps(ServerName(i));
  84.                 end loop;
  85.               end if;
  86.             when others =>
  87.               put_line("Unknown parameter """ & value(parm) & """");
  88.           end case;
  89.         else
  90.           put_line("Invalid parameter """ & value(parm) & """");
  91.         end if;
  92.       else
  93.         put_line("Parameter """ & value(parm) & """ doesn't start with - or /.");
  94.       end if;
  95.     end if;
  96.  
  97.   end loop;
  98.  
  99. end get_parms;
  100.  
  101. procedure SetUpCDs(pCDTbl: out CDArrayAccess) is
  102.  
  103. INI_FName: constant string := ".\SHSUSERV.INI";
  104. INI      : Boolean := False;
  105. INI_F    : text_io.File_Type;
  106.  
  107. Done     : Boolean := False;
  108.  
  109. type DrvrEntries is
  110.   record
  111.     EType  : CDRoms.EntryType;
  112.     Name   : string(1..24);
  113.   end record;
  114. DrvrEntry: DrvrEntries;
  115. DrvrString : string(1..64);
  116. DefDriver : array(1..6) of string(1..16) :=
  117.         (("CD  CD001       "),("CD  CD002       "),
  118.          ("CD  MSCD001     "),("CD  MSCD002     "),
  119.          ("IMG SHSUDRV0.IMG"),("IMG SHSUDRV1.IMG"));
  120.  
  121. DriverUnits    : integer;
  122. CDTbl          : CDArrayAccess;
  123. function CDA_to_DW is new unchecked_conversion(CDArrayAccess, DW);
  124. DrvrIndex  : integer;
  125.  
  126. type ListEntry;
  127. type LinkPtr is access ListEntry;
  128. type ListEntry is
  129.   record
  130.     Link : LinkPtr;
  131.     CDEntry: CDEntries;
  132.   end record;
  133. DriverList     : LinkPtr := null;
  134. NextDriver     : LinkPtr;
  135.  
  136. LastCD         : integer := -1;
  137.  
  138. procedure GetDriveInfo(DriveEntry: in out CDEntries;
  139.                        Units     : out integer) is
  140.   DriverHandle   : integer;
  141.   DriverSubUnits  : byte;
  142. begin
  143.   OpenDevice ( DeviceName => DriveEntry.Driver.Name,
  144.                Handle     => DriverHandle);
  145.   GetDeviceEntryAddresses (Handle           => DriverHandle,
  146.                            DeviceStrategy   => DriveEntry.Driver.Strategy,
  147.                            DeviceInterrupt  => DriveEntry.Driver.Interrupt,
  148.                            SubUnits         => DriverSubUnits );
  149.   CloseDevice (Handle => DriverHandle);
  150.   Units := integer(DriverSubUnits);
  151.   exception
  152.     when DEV_Error => Units := 0;
  153. end GetDriveInfo;
  154.  
  155. function OpenHDCDIMG(FileName: string) return IMG_Access is
  156.   Img_F : IMG_Access := new DIO.File_Type;
  157. begin
  158.   DIO.Open(Img_F.all,DIO.In_File,FileName);
  159.   return Img_F;
  160. exception
  161.   when others =>zapImg_F(Img_F);
  162.                 return null;
  163. end OpenHDCDIMG;
  164.  
  165. procedure LinkUpDrivers(Head:in out LinkPtr;NewEntry:LinkPtr;Units:integer) is
  166.   temp : LinkPtr;
  167. begin
  168.   if Units = 1 then
  169.     NewEntry.CDEntry.Unit := byte(Units-1);
  170.     NewEntry.Link := Head;
  171.     Head  := NewEntry;
  172.   else
  173.     LinkUpDrivers(Head,NewEntry,Units-1);
  174.     temp := new ListEntry;
  175.     temp.all := NewEntry.all;
  176.     temp.CDEntry.Unit := byte(Units-1);
  177.     temp.Link := Head;
  178.     Head  := temp;
  179.   end if;
  180. end LinkUpDrivers;
  181.  
  182. begin
  183.  
  184. begin
  185.   text_io.Open(INI_F,text_io.In_File,INI_FName);
  186.   INI := True;
  187. exception
  188.   when others => null;
  189. end;
  190.  
  191. if  INI then
  192.   tty.put(10,10,"Using INI file: "&INI_FName);
  193. else
  194.   tty.put(10,10,"Using default driver name list.");
  195. end if;
  196.  
  197. DONE := not INI and then DefDriver'last < 1;
  198.  
  199. DrvrIndex := 1;
  200. cursor.move(11,10);
  201.  
  202. while not Done loop
  203.   begin
  204.     declare
  205.       k,n: natural;
  206.     begin
  207.       DrvrString:=(others=>' ');
  208.       if INI then
  209.         k := 0;
  210.         while k = 0 loop
  211.           text_io.get_line(INI_F,DrvrString,k);
  212.         end loop;
  213.       else
  214.         k := DefDriver(DrvrIndex)'last;
  215.         DrvrString(1..k):= DefDriver(DrvrIndex);
  216.         DrvrIndex := DrvrIndex + 1;
  217.         if DrvrIndex > DefDriver'last then
  218.            DONE := True;
  219.         end if;
  220.       end if;
  221.       ET_IO.get(from=> DrvrString, item=> DrvrEntry.EType, last=> n);
  222.       for i in n+1..k loop
  223.         if DrvrString(i) /= ' ' then
  224.           n := i;
  225.           exit;
  226.         end if;
  227.       end loop;
  228.       DrvrEntry.Name := (others=>' ');
  229.       DrvrEntry.Name(1..k-n+1) := DrvrString(n..k);
  230.       declare
  231.         r,c : integer;
  232.       begin
  233.         cursor.get_position(r,c);
  234.         tty.put(r,10,"Looking for: "&DrvrString(n..k));
  235.       end;
  236.     end;
  237.     NextDriver := new ListEntry;
  238.     if DrvrEntry.EType = CD then
  239.       NextDriver.CDEntry :=(EType => CD, Unit=>byte(0),Label=>(others=>' '),
  240.               Status  => long_to_DW(0), VolSize => long_to_DW(0),
  241.               Driver =>(Name => DrvrEntry.Name, Strategy => 0, Interrupt => 0));
  242.       GetDriveInfo(DriveEntry => NextDriver.CDEntry, Units => DriverUnits);
  243.     else
  244.       NextDriver.CDEntry :=(EType => IMG, Unit=>byte(0),Label=>(others=>' '),
  245.               Status  => long_to_DW(0), VolSize => long_to_DW(0),
  246.               File =>(Name => DrvrEntry.Name,
  247.                           Img_F =>OpenHDCDIMG(DrvrEntry.Name)));
  248.       if NextDriver.CDEntry.File.Img_F = null then
  249.         DriverUnits := 0;
  250.       else
  251.         DriverUnits := 1;
  252.       end if;
  253.     end if;
  254.  
  255.     if DriverUnits /= 0 then
  256.       LinkUpDrivers(DriverList,NextDriver,DriverUnits);
  257.       LastCd := LastCd + DriverUnits;
  258.       tty.put_line(" Found");
  259.     else
  260.       tty.put_line(" Not Found");
  261.     end if;
  262.  
  263.   exception
  264.     when data_error => null;       -- ET_IO error, skip this line
  265.     when others =>     DONE:=True;
  266.   end;
  267. end loop; --while
  268.  
  269. if INI then
  270.   text_io.Close(INI_F);
  271. end if;
  272.  
  273. if LastCD < 0 then
  274.   raise DEV_Error;
  275. end if;
  276.  
  277. -- Allocate the driver table
  278.  
  279. CDTbl := new CDArray(0..LastCD);
  280.  
  281. -- Fill in the table entries
  282. declare
  283. ptr:LinkPtr:= DriverList;
  284. begin
  285. for i in reverse CDTbl'range loop
  286.   CDTbl(i) := ptr.CDEntry;
  287.   ptr := ptr.Link;
  288. end loop;
  289.  
  290. --for i in CDTbl'range loop
  291. --  if CDTbl(i).EType = CD then
  292. --    put_line(CDTbl(i).Driver.Name);
  293. --  else
  294. --    put_line(CDTbl(i).File.Name);
  295. --  end if;
  296. --end loop;
  297. end;
  298.  
  299. pCDTbl := CDTbl;
  300.  
  301. end SetUpCDs;
  302.  
  303. procedure ExtendFileHandleTable is
  304.  
  305. -- This increases the max file handles for a process.  Set max for DOS with
  306. --   Files= in CONFIG.SYS
  307. --
  308. -- Must declare NewHandles in static storage area
  309. --    NewHandles  : bytes(1..255);
  310. --
  311.  
  312. PSP_Handles_Offset : memory.segment_offset := memory.segment_offset(16#18#);
  313. PSP_MaxNumberHandles_Offset : memory.segment_offset := memory.segment_offset(16#32#);
  314. PSP_HandleTablePtr_Offset : memory.segment_offset := memory.segment_offset(16#34#);
  315. PSP_seg : memory.memory_segment:= program_control.segment_prefix;
  316.  
  317. OldHandles  : bytes(1..20);
  318.  
  319. for OldHandles use at memory.make(segment => PSP_seg,
  320.                                   offset  => PSP_Handles_Offset);
  321. MaxNumberHandles : word;
  322. for MaxNumberHandles use at memory.make(segment => PSP_seg,
  323.                                    offset  => PSP_MaxNumberHandles_Offset);
  324. HandleTablePtr: system.address;
  325. for HandleTablePtr use at memory.make(segment => PSP_seg,
  326.                                        offset  => PSP_HandleTablePtr_Offset);
  327.  
  328. begin
  329.   NewHandles        := (others=>16#FF#);    -- unused handle code
  330.   NewHandles(1..20) := OldHandles;          -- copy existing handles
  331.   MaxNumberHandles  := NewHandles'last;     -- set new max handles
  332.   HandleTablePtr    := NewHandles(1)'address;  -- point to new handle table
  333.  
  334. end ExtendFileHandleTable;
  335.  
  336. procedure ResetFileHandleTable is
  337. PSP_Handles_Offset : memory.segment_offset := memory.segment_offset(16#18#);
  338. PSP_MaxNumberHandles_Offset : memory.segment_offset := memory.segment_offset(16#32#);
  339. PSP_HandleTablePtr_Offset : memory.segment_offset := memory.segment_offset(16#34#);
  340. PSP_seg : memory.memory_segment:= program_control.segment_prefix;
  341.  
  342. MaxNumberHandles : word;
  343. for MaxNumberHandles use at memory.make(segment => PSP_seg,
  344.                                    offset  => PSP_MaxNumberHandles_Offset);
  345. HandleTablePtr: system.address;
  346. for HandleTablePtr use at memory.make(segment => PSP_seg,
  347.                                        offset  => PSP_HandleTablePtr_Offset);
  348. begin
  349.   MaxNumberHandles  := 20;
  350.   HandleTablePtr    := memory.make(segment => PSP_seg,
  351.                                   offset  => PSP_Handles_Offset);
  352. end ResetFileHandleTable;
  353.  
  354. begin  -- Main **************************************************************
  355.  
  356. tty.clear_screen;
  357. box.draw(0,0,9,79,box.double_sided);
  358. tty.put(2,27,"SHSU CDROM SERVER 3.0");
  359. tty.put(3,20,"A copyright-reserved, free use program.");
  360. tty.put(4,28,"(c)John H. McCoy, 1994, 1995");
  361. tty.put(5,22,"Sam Houston St. Univ., TX 77341-2206");
  362. tty.put(7,17,"Latest version is available from FTP.SHSU.EDU");
  363. tty.put(8,13,"Experimental Academic Software.  Use at your own risk.");
  364.  
  365. get_parms;
  366.  
  367. ExtendFileHandleTable;
  368.  
  369. SetUpCDs(CDTbl);
  370.  
  371. LastCD := CDTbl.all'last;
  372.  
  373. CDs.Setup(CDTbl);
  374. delay(1.0);
  375. declare
  376. r,c: integer;
  377. begin
  378. cursor.get_position(r,c);
  379. tty.put(r,10,"Validating: "&ServerName);
  380. end;
  381.  
  382. NET.Start(ServerName);
  383.  
  384. tty.put(24,0,"Server name validated");
  385.  
  386. Console.Init(MaxSessions => MaxSessions,
  387.              LastCd      => LastCd,
  388.              ServerName  => ServerName);
  389.  
  390. delay(5.0);            -- so initial screen display will complete
  391.  
  392. for i in 1..MaxSessions loop
  393.     SessionTable(i) := new Sessions;
  394.     SessionTable(i).Start(Net,ServerName,types.byte(integer'succ(LastCD)),HUB);
  395. end loop;
  396.  
  397. tty.put(24,0,"Enter S to stop the server. ");
  398.  
  399. loop
  400.   cursor.move(24,27);
  401.   if tty.char_ready then
  402.     tty.get(xch,ch);
  403.     if ch = 'S' or ch = 's' then
  404.       tty.put(24,0,"Are you sure you want to stop? (Y/N)");
  405.       for i in 1..10 loop
  406.         if tty.char_ready then
  407.           tty.get(xch,ch);
  408.           exit;
  409.         end if;
  410.         delay(1.0);
  411.       end loop;
  412.       exit when (ch = 'y' or ch = 'Y');
  413.     end if;
  414.     video.scroll_up(0,24,0,24,79);
  415.     tty.put(24,0,"Enter S to stop the server.");
  416.   end if;
  417.   delay(1.0);
  418.  
  419. end loop;
  420.  
  421. NET.Hold;
  422.  
  423. tty.put(24,0,"Stopping Net.  May take 30 seconds for timeout.");
  424.  
  425.  
  426. NCB.Name    := ServerName;
  427. NCB.Command := NB_SessionStatus;
  428. NCB.BufferPtr := NBSS'address;
  429. NCB.BufferLength := NBSS'size/8;
  430. NetBiosCall(SA_to_ncbAccess(NCB'address));
  431. for i in 1..NBSS.SessionsCount loop
  432.   if (NBSS.SS(integer(i)).State /= NB_SS_ListenPending) then
  433.     nethangup(NBSS.SS(integer(i)).lsn);
  434.   end if;
  435. end loop;
  436.  
  437. declare
  438.     done: boolean;
  439. begin
  440.     loop
  441.     done := true;
  442.       for i in 1..MaxSessions loop
  443.         if SessionTable(i)'terminated then
  444.           null;
  445.         else
  446.           done:=false;
  447.         end if;
  448.       delay (0.0);
  449.      end loop;
  450.     exit when done;
  451.     end loop;
  452. end;
  453.  
  454. -- tty.put(24,0,"Console Shutdown.");
  455.  
  456. video.clear_screen;
  457.  
  458.  
  459. Console.Shutdown;      --don't shutdown console til all sessions done
  460.  
  461.  
  462.  
  463. -- tty.put(24,0,"Hub Shutdown.");
  464.  
  465. HUB.Shutdown;
  466. loop
  467.   exit when HUB'terminated;
  468. end loop;
  469.  
  470. CDs.Shutdown;
  471. loop
  472.   exit when CDs'terminated;
  473. end loop;
  474.  
  475. Net.Shutdown;
  476.  
  477. tty.put(24,0,"Normal End of SHSU CD SERVER.");
  478.  
  479. ResetFileHandleTable;
  480.  
  481. exception
  482.   when CMD_Parm_Error         => Put_line("Command line parm error.");
  483.   when DEV_Error              => Put_line("No CD Roms found.");
  484.                                  ResetFileHandleTable;
  485.   when NBX_NetBiosNotLoaded   => Put_line("Net BIOS not loaded.");
  486.                                  ResetFileHandleTable;
  487.   when NBX_NameAlreadyclaimed => Put_line("Name already in use.");
  488.                                  ResetFileHandleTable;
  489.   when NBX_GeneralError       => Put("Error attempting to start ");
  490.                                  Put_line(ServerName);
  491.                                  ResetFileHandleTable;
  492.  
  493. end SHSUServ;