home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / ADC_TP3.ZIP / DELIB.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1987-03-01  |  3.1 KB  |  93 lines
  1. Program DeLibrary;
  2.  
  3. { DeLibrary for Turbo Pascal
  4.   Version 1.00
  5.   By Bela Lubkin
  6.  
  7.   This program extracts all the files from a library.  It does only the bare
  8.   minimum of error checking.  It does not provide any options.  The only thing
  9.   it does is split library files.  If you have any interest in using
  10.   libraries, you are directed to:
  11.     For CP/M-80: LU310.BIN (LU310.COM) in DL2 of SIGCPM, GO PCS-47 or R SIGCPM
  12.     For CP/M-86: LU8645.BIN (LU8645.CMD) in DL9 of SIGCPM
  13.     For MS-DOS:  LU8643.BIN (LU8643.EXE) in DL6 of IBM PC SIG, GO PCS-131 or
  14.                  R IBMSIG.
  15.   (Do a S/KEY:LIBRARY/DES to find all associated documents and to possibly
  16.    find newer versions)
  17. }
  18.  
  19.   Const
  20.     BufSecs=200;   { Number of 128 byte sectors to allocate for buffer }
  21.  
  22.   Type
  23.     Sector=Array [0..127] Of Byte;
  24.     String80=String[80];
  25.     FileName=String[20];
  26.  
  27.   Var
  28.     LibFile,OutFile: File;
  29.     LibName,OutName: FileName;
  30.     DirBuffer: Sector;
  31.     I,J,Offset,DirLength,FirstSec,NumSecs,Secs: Integer;
  32.     Buffer: Array [1..BufSecs] Of Sector;
  33.  
  34.   Procedure Error(S: String80);
  35.  
  36.     Begin
  37.       Write(S);
  38.       {$I-} Close(LibFile); {$I+}
  39.       Halt;
  40.     End;
  41.  
  42.   Begin
  43.     Write('Enter library file name: ');
  44.     ReadLn(LibName);
  45.     If Pos('.',LibName)=0 Then LibName:=LibName+'.LBR';
  46.     Assign(LibFile,LibName);
  47.     {$I-} Reset(LibFile); {$I+}
  48.     If IOResult<>0 Then Error('Library file not found');
  49.     BlockRead(LibFile,DirBuffer,1);
  50.     If DirBuffer[0]<>0 Then Error('Not a library file');
  51.     For I:=1 To 11 Do If DirBuffer[I]<>32 Then Error('Not a library file');
  52.     If (DirBuffer[12]<>0) Or (DirBuffer[13]<>0) Then
  53.       Error('Not a library file');
  54.     DirLength:=DirBuffer[14]+256*DirBuffer[15];
  55.     If DirLength=0 Then Error('Not a library file');
  56.     For I:=1 To DirLength*4-1 Do
  57.      Begin
  58.       Offset:=32*(I Mod 4);
  59.       If Offset=0 Then
  60.        Begin
  61.         Seek(LibFile,I Div 4);
  62.         BlockRead(LibFile,DirBuffer,1);
  63.        End;
  64.       If DirBuffer[Offset]=$FF Then Error('Done!')
  65.       Else If DirBuffer[Offset]=0 Then
  66.        Begin
  67.         OutName:='';
  68.         For J:=1 To 8 Do If DirBuffer[Offset+J]<>32 Then
  69.           OutName:=OutName+Chr(DirBuffer[Offset+J]);
  70.         OutName:=OutName+'.';
  71.         For J:=9 To 11 Do If DirBuffer[Offset+J]<>32 Then
  72.           OutName:=OutName+Chr(DirBuffer[Offset+J]);
  73.         WriteLn('Extracting file ',OutName);
  74.         Assign(OutFile,OutName);
  75.         {$I-} Rewrite(OutFile); {$I+}
  76.         If IOResult<>0 Then Error('Could not create '+OutName);
  77.         FirstSec:=DirBuffer[Offset+12]+256*DirBuffer[Offset+13];
  78.         NumSecs:=DirBuffer[Offset+14]+256*DirBuffer[Offset+15];
  79.         Seek(LibFile,FirstSec);
  80.         While NumSecs>0 Do
  81.          Begin
  82.           If BufSecs<NumSecs Then Secs:=BufSecs
  83.           Else Secs:=NumSecs;
  84.           BlockRead(LibFile,Buffer,Secs);
  85.           BlockWrite(OutFile,Buffer,Secs);
  86.           NumSecs:=NumSecs-Secs;
  87.          End;
  88.         Close(OutFile);
  89.        End;
  90.      End;
  91.     Error('Done!');
  92.   End.
  93.