(* GGET.PAS -- Get files from a GEOS disk image
** Copyright (c) 1995,1996 Jochen Metzinger
**
** This program is free software; you can redistribute it and/or modify
** it under the terms of the GNU General Public License as published by
** the Free Software Foundation; either version 2, or (at your option)
** any later version.
**
** This program is distributed in the hope that it will be useful,
** but WITHOUT ANY WARRANTY; without even the implied warranty of
** MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
** GNU General Public License for more details.
**
** You should have received a copy of the GNU General Public License
** along with this program; if not, write to the Free Software
** Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
*)

PROGRAM Gget;

USES Crt, global, geos, coding, errors, d64, dir;

CONST
 CVT_EXT = '.CVT';


CONST
 FILE_CHARS: SET OF CHAR =
  ['!','#'..')','-','0'..'9','@'..'Z','^'..'{','}','~'];
 DosTypeName: ARRAY [$0..$7] OF STRING[4] =
  ('.DEL', '.SEQ', '.PRG', '.USR', '.REL', '.XX5', '.XX6', '.XX7');

VAR
 d_name, f_name: STRING;
 use_dir: ARRAY [0..9] OF BOOLEAN;
 use_all_dir: BOOLEAN;
 interactiv, no_geos_files, overwrite, SEQ_formatted: BOOLEAN;


PROCEDURE usage;
BEGIN
 WriteLn('GGET  Version 0.3',country,'  Get files from a GEOS disk image');
 WriteLn('Copyright (c) 1995,1996 Jochen Metzinger ');
 WriteLn;
 WriteLn(short_usage);
 WriteLn;
 WriteLn('  image       disk image');
 WriteLn('  filename    file name selector');
 WriteLn('    /1 .. /9    directory page 1 .. 9');
 WriteLn('    /B          border directory');
 WriteLn('    /I          ask for each file');
 WriteLn('    /O          overwrite existed files');
 WriteLn('    /N          do not create GEOS converted files');
 WriteLn('    /S          create SEQ formatted GEOS files');
 Write('    /G          german');
 IF default_code = ge_coding THEN Write(' [default]');
 WriteLn;
 Write('    /E          english');
 IF default_code = uk_coding THEN Write(' [default]');
 WriteLn;
 HALT(1);
END; (* usage *)

PROCEDURE Init;
 VAR i, j: INTEGER; par: STRING;
BEGIN
 short_usage := 'GGET [/?] image filename [options]';
 d_name := '';
 f_name := '';
 FOR i := 0 TO 9 DO
  use_dir[i] := FALSE;
 interactiv := FALSE;
 no_geos_files := FALSE;
 overwrite := FALSE;
 SEQ_formatted := FALSE;
 IF ParamCount = 0 THEN
  usage;
 FOR i := 1 TO ParamCount DO BEGIN
  par := ParamStr(i);
  IF (par[1] = '/') OR (par[1] = '-') THEN
   BEGIN
    IF Length(par) = 1 THEN
     FATAL('unknown option '+par);
    FOR j := 2 TO Length(par) DO
     CASE UpCase(par[j]) OF
      '?', 'H': usage;
      '0'..'9': use_dir[ORD(par[j])-ORD('0')] := TRUE;
      'B': use_dir[0] := TRUE;
      'I': interactiv := TRUE;
      'N': no_geos_files := TRUE;
      'O': overwrite := TRUE;
      'S': SEQ_formatted := TRUE;
      'G': SetCoding(ge_coding);
      'E': SetCoding(uk_coding);
      ELSE FATAL('unknown option '+par);
     END; (* case *)
   END
  ELSE IF d_name = '' THEN
   d_name := AddExt(par, '.D64')
  ELSE IF f_name = '' THEN
   BEGIN
    j := Pos('*',par);
    IF j > 0 THEN Delete(par,j+1,$FF);
    f_name := Copy(par,1,16);
   END
  ELSE
   FATAL('too many arguments');
 END; (* for *)
 IF d_name = '' THEN usage;
 IF f_name = '' THEN f_name := '*';
 d64_open(d_name);
 short_usage := '';
 InitDir;
 use_all_dir := TRUE;
 IF IsGeosDisk THEN
  FOR i := 0 TO 9 DO
   IF use_dir[i] THEN
    use_all_dir := FALSE;
END; (* init *)

FUNCTION MakeDosFileName(gname, ext: STRING): STRING;
(* convert GEOS file names *)
 VAR fn: STRING; i: BYTE;
BEGIN
 FOR i := 1 TO Length(gname) DO
  IF (gname[i] < #32) OR (#127 < gname[i]) THEN
   gname[i] := 'X';
 fn := Copy(TransStr(gname),1,8);
 FOR i := 1 TO Length(fn) DO
  IF fn[i] IN FILE_CHARS THEN
   fn[i] := UpCase(fn[i])
  ELSE IF fn[i] = ' ' THEN
   fn[i] := '_'
  ELSE
   fn[i] := 'X';
 MakeDosFileName := fn + ext;
END; (* MakeDosFileName *)

FUNCTION FileExists(FileName: STRING): BOOLEAN;
(* exists file? *)
 VAR f: FILE;
BEGIN
 (*$I-*)
 Assign(f, FileName);
 FileMode := FileMode_RO;
 Reset(f);
 FileMode := FileMode_RW;
 Close(f);
 (*$I+*)
 FileExists := (IOResult = 0) and (FileName <> '');
END; (* FileExists *)

FUNCTION GetFileHandler(VAR f: FILE; gname, ext: STRING): BOOLEAN;
(* Open file with checking *)
 VAR fn, fn0: STRING; ch, dummy: CHAR;
BEGIN
 GetFileHandler := FALSE;
 fn := MakeDosFileName(gname, ext);
 Write(' -> ',fn);
 IF interactiv THEN BEGIN
  Write(' (Y,n)? ');
  REPEAT
   ch := UpCase(ReadKey);
   IF ch = #0 THEN dummy := ReadKey;
   IF ch = 'N' THEN BEGIN
    WriteLn('N');
    EXIT;
   END; (* if *)
  UNTIL ch IN ['Y',#13];
  Write('Y');
 END; (* if *)
 WriteLn;
 IF NOT overwrite THEN BEGIN
  ch := 'X';
  WHILE (ch <> 'Y') AND FileExists(fn) DO BEGIN
   Write('GGET: Warning! ', fn, ' already exists. Overwrite (y/n/a/r)? ');
   REPEAT
    ch := UpCase(ReadKey);
    IF ch = #0 THEN dummy := ReadKey;
   UNTIL ch IN ['Y','N','A','R'];
   WriteLn(ch);
   CASE ch OF
    'N': EXIT;
    'Y': (* nothing *);
    'A': BEGIN
      ch := 'Y';
      overwrite := TRUE;
     END;
    'R': BEGIN
      Write('New name? ');
      ReadLn(fn0);
      IF fn0 <> '' THEN fn := AddExt(fn0, ext);
     END;
   END; (* case *)
  END; (* while *)
 END; (* if *)
 (*$I-*)
 Assign(f, fn);
 ReWrite(f, 1);
 (*$I+*)
 IF IOResult <> 0
  THEN error('unable to create file')
  ELSE GetFileHandler := TRUE;
END; (* GetFileHandler *)

FUNCTION CopySEQ(VAR t, s: BYTE; VAR f: FILE): WORD;
 VAR block: d64.BLOCK; cnt, res: WORD;
BEGIN
 CopySEQ := 0;
 cnt := 0;
 WHILE t <> 0 DO BEGIN
  d64_read(t,s,block);
  IF is_err THEN EXIT;
  t := block[0];
  s := block[1];
  BlockWrite(f, block[2], SizeOf(block)-2, res);
  IF res <> SizeOf(block)-2 THEN EXIT;
  INC(cnt);
  IF cnt > $FF THEN BEGIN
   ERROR('chain/file too large');
   EXIT;
  END; (* if *)
 END; (* while *)
 t := cnt;
 IF cnt > 0 THEN BEGIN
  IF s < 2 THEN BEGIN
   ERROR('sector used byte counter wrong');
   s := $FF;
  END; (* if *)
  CopySEQ := $FF - s;
 END; (* if *)
END; (* CopySEQ *)

PROCEDURE CbmFile(VAR dr: DirRec);
 VAR ext, m_ext: STRING; head: d64.BLOCK;
  cbm_file: FILE; back: INTEGER;
BEGIN
 ext := DosTypeName[dr.dostype AND $07];
 IF NOT no_geos_files THEN BEGIN
  (* converted file? *)
  d64_read(dr.tr_1st, dr.sc_1st, head);
  IF is_err THEN BEGIN
   WriteLn;
   EXIT;
  END; (* if *)
  IF GetString(head[$23], 25) = ' formatted GEOS file V1.0' THEN BEGIN
   m_ext := GetString(head[$20], 3);
   IF (m_ext = 'SEQ') OR (m_ext = 'PRG') THEN
    ext := CVT_EXT;
  END; (* if *)
 END; (* if *)
 (* Transfer sequential file *)
 IF NOT GetFileHandler(cbm_file,DirFileName(dr),ext) THEN EXIT;
 back := CopySEQ(dr.tr_1st, dr.sc_1st, cbm_file);
 IF back > 0 THEN BEGIN
  Seek(cbm_file, FileSize(cbm_file)-back);
  Truncate(cbm_file);
 END; (* if *)
 Close(cbm_file);
END; (* CbmFile *)

PROCEDURE GeosFile(dr: DirRec);
 VAR cvt_file: FILE;
  head, info, vlir: d64.BLOCK;
  res, back, chain: WORD;
BEGIN
 IF NOT GetFileHandler(cvt_file,DirFileName(dr),CVT_EXT) THEN
  EXIT;
 (* Output pre-header *)
 FillChar(head, SizeOf(head), 0);
 Move(dr, head[$02], SizeOf(dr));
 BlockWrite(cvt_file, head[2], SizeOf(head)-2, res);
 IF res <> SizeOf(head)-2 THEN FATAL('unable to write');
 (* Output info rec *)
 d64_read(dr.tr_info, dr.sc_info, info);
 IF is_err THEN EXIT;
 BlockWrite(cvt_file, info[2], SizeOf(info)-2, res);
 IF res <> SizeOf(info)-2 THEN FATAL('unable to write');
 (* VLIR/SEQ structure *)
 IF dr.struct = 0 THEN
  (* SEQ format *)
  back := CopySEQ(dr.tr_1st, dr.sc_1st, cvt_file)
 ELSE (* VLIR format *) BEGIN
  (* Output pre-vlir *)
  d64_read(dr.tr_1st, dr.sc_1st, vlir);
  IF is_err THEN EXIT;
  BlockWrite(cvt_file, vlir[2], SizeOf(vlir)-2, res);
  IF res <> SizeOf(vlir)-2 THEN FATAL('unable to write');
  (* Transfer chains *)
  back := 0;
  FOR chain := 1 TO 127 DO
   IF vlir[2*chain] <> 0 THEN BEGIN
    back := CopySEQ(vlir[2*chain], vlir[2*chain+1], cvt_file);
    IF is_err THEN EXIT;
   END; (* if *)
  (* Output vlir *)
  Seek(cvt_file, 2*254);
  BlockWrite(cvt_file, vlir[2], SizeOf(vlir)-2, res);
  IF res <> SizeOf(vlir)-2 THEN FATAL('unable to write');
 END; (* else *)
 (* Cut unused last bytes *)
 IF back > 0 THEN BEGIN
  Seek(cvt_file, FileSize(cvt_file)-back);
  Truncate(cvt_file);
 END; (* if *)
 (* Output header *)
 Seek(cvt_file,0);
 PutString(head[$20], 'PRG formatted GEOS file V1.0'#0);
 IF SEQ_formatted THEN PutString(head[$20], 'SEQ');
 PutString(head[$A0], 'JOCHEN METZINGER''S GGET V3.0'#0);
 BlockWrite(cvt_file, head[2], SizeOf(head)-2, res);
 IF res <> SizeOf(head)-2 THEN FATAL('unable to write');
 Close(cvt_file);
END; (* GeosFile *)

PROCEDURE TransferFile(dr: DirRec);
BEGIN
 Write('"',TransStr(DirFileName(dr)),'"');
 WITH dr DO
  IF (dostype AND $07 = 4) OR (geostype = 0) THEN
   CbmFile(dr)
  ELSE IF no_geos_files THEN
   CbmFile(dr)
  ELSE IF struct <= 1 THEN
   GeosFile(dr)
  ELSE BEGIN
   WriteLn;
   ERROR('neither SEQ nor VLIR');
  END; (* else *)
 IF is_err THEN
  err_recover;
END; (* TransferFile *)

FUNCTION IsInPage(page: INTEGER): BOOLEAN;
BEGIN
 IsInPage := TRUE;
 IF use_all_dir THEN EXIT;
 IsInPage := FALSE;
 IF (page < 0) OR (page > 9) THEN EXIT;
 IsInPage := use_dir[page];
END; (* IsInPage *)

FUNCTION LIKE(fn, pt: STRING): BOOLEAN;
 VAR i: INTEGER;
BEGIN
 LIKE := FALSE;
 FOR i := 1 TO Length(pt) DO BEGIN
  IF pt[i] = '*' THEN BEGIN
   LIKE := TRUE;
   EXIT;
  END; (* if *)
  IF Length(fn) < i THEN
   EXIT;
  IF pt[i] <> '?' THEN
   IF pt[i] <> fn[i] THEN
     EXIT;
 END; (* for *)
 LIKE := (Length(fn) = Length(pt));
END; (* LIKE *)

PROCEDURE DoTransfer;
VAR dr: DirRec; page: WORD;
 found: BOOLEAN;
BEGIN
 DiskName := TransStr(DiskName);
 DiskID := TransStr(DiskID);
 DiskOS := TransStr(DiskOS);
 IF IsGeosDisk THEN Write('GEOS disk') ELSE Write('Disk');
 WriteLn(' "',DiskName,'", ',DiskID,', ',DiskOS,' <',d_name,'>');
 found := FALSE;
 RewindDir;
 WHILE ReadDir(dr, page) DO
  IF dr.dostype <> 0 THEN
   IF IsInPage(page) THEN
    IF LIKE(TransStr(DirFileName(dr)), f_name) THEN BEGIN
     TransferFile(dr);
     found := TRUE;
    END; (* if *)
 IF NOT found THEN
  WriteLn('no file');
END; (* DoTransfer *)

BEGIN
 Init;
 DoTransfer;
 d64_close;
END. (* Gget *)