
(********************************************************************)
(*                                                                  *)
(*  tar.s7i       Tar archive library                               *)
(*  Copyright (C) 1994, 2004, 2005, 2010, 2014  Thomas Mertes       *)
(*                                                                  *)
(*  This file is part of the Seed7 Runtime Library.                 *)
(*                                                                  *)
(*  The Seed7 Runtime Library is free software; you can             *)
(*  redistribute it and/or modify it under the terms of the GNU     *)
(*  Lesser General Public License as published by the Free Software *)
(*  Foundation; either version 2.1 of the License, or (at your      *)
(*  option) any later version.                                      *)
(*                                                                  *)
(*  The Seed7 Runtime Library 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 Lesser General Public License for more    *)
(*  details.                                                        *)
(*                                                                  *)
(*  You should have received a copy of the GNU Lesser General       *)
(*  Public License along with this program; if not, write to the    *)
(*  Free Software Foundation, Inc., 51 Franklin Street,             *)
(*  Fifth Floor, Boston, MA  02110-1301, USA.                       *)
(*                                                                  *)
(********************************************************************)


include "stdio.s7i";
include "osfiles.s7i";
include "time.s7i";
include "getf.s7i";
include "gzip.s7i";


const string: TMAGIC is "ustar";
const string: NOMAGIC is "";

const char: REGTYPE      is '0';   # Regular file (preferred code)
const char: AREGTYPE     is '\0;'; # Regular file (alternate code)
const char: LNKTYPE      is '1';   # Hard link.
const char: SYMTYPE      is '2';   # Symbolic link
const char: CHRTYPE      is '3';   # Character special
const char: BLKTYPE      is '4';   # Block special
const char: DIRTYPE      is '5';   # Directory
const char: FIFOTYPE     is '6';   # Named pipe
const char: CONTTYPE     is '7';   # Contiguous file
const char: LONGNAMETYPE is 'L';   # Long (untruncated) filename of the next file

const type: header is new struct
    var string: name is "";
    var fileMode: mode is fileMode.value;
    var integer: uid is 0;
    var integer: gid is 0;
    var integer: size is 0;
    var integer: mtime is 0;
    var integer: chksum is 0;
    var char: typeflag is REGTYPE;
    var string: linkname is "";
    var string: magic is "";
    var string: version is "";
    var string: uname is "";
    var string: gname is "";
    var integer: devmajor is 0;
    var integer: devminor is 0;
    var string: prefix is "";
  end struct;


const proc: check (ref file: outFile, ref header: head) is func
  local
    var string: stri is "";
  begin
    write("name: ");
    writeln(head.name);
    write("mode: ");
    writeln(head.mode);
    write("uid: ");
    writeln(head.uid);
    write("gid: ");
    writeln(head.gid);
    write("size: ");
    writeln(head.size);
    write("mtime: ");
    writeln(head.mtime);
    write("chksum: ");
    writeln(head.chksum);
    write("typeflag: ");
    writeln(literal(head.typeflag));
    write("linkname: ");
    writeln(head.linkname);
    write("magic: ");
    writeln(literal(head.magic));
    write("version: ");
    writeln(literal(head.version));
    write("uname: ");
    writeln(head.uname);
    write("gname: ");
    writeln(head.gname);
    write("devmajor: ");
    writeln(head.devmajor);
    write("devminor: ");
    writeln(head.devminor);
    write("prefix: ");
    writeln(head.prefix);
  end func;


const func string: gets0 (inout file: inFile, in integer: length) is func
  result
    var string: stri is "";
  local
    var integer: zeroBytePos is 0;
  begin
    stri := gets(inFile, length);
    zeroBytePos := pos(stri, "\0;");
    if zeroBytePos <> 0 then
      stri := stri[ .. pred(zeroBytePos)];
    end if;
  end func;


const func string: gets0spc (inout file: inFile, in integer: length) is func
  result
    var string: stri is "";
  local
    var integer: zeroBytePos is 0;
    var integer: spacePos is 0;
  begin
    stri := gets(inFile, length);
    zeroBytePos := pos(stri, "\0;");
    if zeroBytePos <> 0 then
      stri := stri[ .. pred(zeroBytePos)];
    end if;
    spacePos := pos(stri, " ");
    if spacePos <> 0 then
      stri := stri[ .. pred(spacePos)];
    end if;
  end func;


const func integer: getoct (inout file: inFile, in integer: length) is func
  result
    var integer: number is 0;
  local
    var string: stri is "";
    var integer: start is 1;
    var integer: pos is 0;
  begin
    stri := gets(inFile, length);
    while start <= length(stri) and stri[start] = ' ' do
      incr(start);
    end while;
    pos := start;
    while pos <= length(stri) and stri[pos] >= '0' and stri[pos] <= '7' do
      incr(pos);
    end while;
    if pos > start then
      number := integer(stri[start .. pred(pos)], 8);
    end if;
  end func;


const proc: puts0 (inout string: out_stri, in string: stri, in integer: length) is func
  begin
    out_stri &:= stri[ .. length];
    if length(stri) < length then
      out_stri &:= "\0;" mult length - length(stri);
    end if;
  end func;


const proc: putspc (inout string: out_stri, in string: stri, in integer: length) is func
  begin
    out_stri &:= stri[ .. length] rpad length;
  end func;


const proc: putoct (inout string: out_stri, in integer: number, in integer: length) is func
  begin
    out_stri &:= number radix 8 lpad0 pred(length) <& "\0;";
  end func;


const func integer: chksum (in string: stri) is func
  result
    var integer: checkSum is 0;
  local
    var char: ch is ' ';
  begin
    for ch range stri do
      checkSum +:= ord(ch);
    end for;
    checkSum := checkSum mod 2 ** 16;
  end func;


const proc: readHeadBlock (inout file: inFile, inout header: head) is func
  local
    var string: stri is "";
  begin
    head := header.value;
    head.name :=                gets0(inFile,  100);
    head.mode := fileMode conv getoct(inFile,    8);
    head.uid :=                getoct(inFile,    8);
    head.gid :=                getoct(inFile,    8);
    head.size :=               getoct(inFile,   12);
    head.mtime :=              getoct(inFile,   12);
    head.chksum :=             getoct(inFile,    8);
    head.typeflag :=             getc(inFile);
    head.linkname :=            gets0(inFile,  100);
    head.magic :=            gets0spc(inFile,    6);
    head.version :=              gets(inFile,    2);
    head.uname :=               gets0(inFile,   32);
    head.gname :=               gets0(inFile,   32);
    head.devmajor :=           getoct(inFile,    8);
    head.devminor :=           getoct(inFile,    8);
    head.prefix :=              gets0(inFile,  155);
    stri :=                      gets(inFile,   12);
  end func;


const proc: readHead (inout file: inFile, inout header: head) is func
  local
    var string: fileName is "";
  begin
    readHeadBlock(inFile, head);
    # check(STD_OUT, head);
    if head.name <> "" and head.magic = TMAGIC and
        head.typeflag = LONGNAMETYPE and head.size <> 0 then
      fileName := gets0(inFile, head.size);
      seek(inFile, tell(inFile) + 511 - pred(head.size) mod 512);
      readHeadBlock(inFile, head);
      # check(STD_OUT, head);
      head.name := fileName;
    end if;
  end func;


const proc: writeHeadBlock (inout file: outFile, ref header: head) is func
  local
    var string: out_stri is "";
    var string: chksum is "";
  begin
    puts0  (out_stri, head.name,      100);
    putoct (out_stri, integer conv (head.mode), 8);
    putoct (out_stri, head.uid,         8);
    putoct (out_stri, head.gid,         8);
    putoct (out_stri, head.size,       12);
    putoct (out_stri, head.mtime,      12);
    putspc (out_stri, "",               8);
    out_stri &:=      head.typeflag; (* 1*)
    puts0  (out_stri, head.linkname,  100);
    puts0  (out_stri, head.magic,       6);
    putspc (out_stri, head.version,     2);
    puts0  (out_stri, head.uname,      32);
    puts0  (out_stri, head.gname,      32);
    putoct (out_stri, head.devmajor,    8);
    putoct (out_stri, head.devminor,    8);
    puts0  (out_stri, head.prefix,    155);
    puts0  (out_stri, "",              12);
    putoct (chksum,   chksum(out_stri), 8);
    out_stri := out_stri[ .. 148] & chksum & out_stri[157 .. ];
    write(outFile, out_stri);
  end func;


const proc: writeHead (inout file: outFile, ref header: head) is func
  local
    var header: longNameHead is header.value;
  begin
    if length(head.name) > 100 then
      longNameHead.name     := "././@LongLink";
      longNameHead.mode     := fileMode.value;
      longNameHead.uid      := 0;
      longNameHead.gid      := 0;
      longNameHead.size     := length(head.name);
      longNameHead.mtime    := 0;
      longNameHead.typeflag := LONGNAMETYPE;
      longNameHead.linkname := "";
      longNameHead.magic    := TMAGIC;
      longNameHead.version  := "  ";
      longNameHead.uname    := "root";
      longNameHead.gname    := "root";
      longNameHead.devmajor := 0;
      longNameHead.devminor := 0;
      longNameHead.prefix   := "";
      writeHeadBlock(outFile, longNameHead);
      write(outFile, head.name);
      write(outFile, "\0;" mult 511 - pred(longNameHead.size) mod 512);
    end if;
    writeHeadBlock(outFile, head);
  end func;


const proc: setUpHead (in string: basePath, in string: name,
    in string: fileTypeMarker, inout header: head) is func
  begin
    head.name     := name & fileTypeMarker;
    head.mode     := fileMode(basePath & name);
    head.uid      := 100;
    head.gid      := 100;
    head.size     := 0;
    head.mtime    := timestamp1970(getMTime(basePath & name));
    head.chksum   := 0;  # Filled later
    head.typeflag := REGTYPE;
    head.linkname := "";
    head.magic    := TMAGIC;
    head.version  := "  ";
    head.uname    := "";
    head.gname    := "";
    head.devmajor := 0;
    head.devminor := 0;
    head.prefix   := "";
  end func;


(**
 *  Determine the filenames in a directory, using a TAR file.
 *  @return an array with the file names.
 *  @exception FILE_ERROR The remote host returns an error.
 *)
const func array string: readDir (inout file: inFile, in var string: dirPath) is func
  result
    var array string: fileNames is 0 times "";
  local
    var header: head is header.value;
    var set of string: fileNameSet is (set of string).value;
    var string: fileName is "";
    var integer: slashPos is 0;
  begin
    if dirPath = "." then
      dirPath := "";
    end if;
    readHead(inFile, head);
    while head.name <> "" and (head.magic = TMAGIC or head.magic = NOMAGIC) do
      if startsWith(head.name, dirPath) then
        fileName := head.name[succ(length(dirPath)) ..];
        if startsWith(fileName, "/") then
          fileName := fileName[2 ..];
        end if;
        slashPos := pos(fileName, '/');
        if slashPos <> 0 then
          fileName := fileName[.. pred(slashPos)];
        end if;
        if fileName <> "" and fileName not in fileNameSet then
          incl(fileNameSet, fileName);
          fileNames &:= fileName;
        end if;
      end if;
      if head.size <> 0 then
        seek(inFile, tell(inFile) + succ(pred(head.size) mdiv 512) * 512);
      end if;
      readHead(inFile, head);
    end while;
  end func;


const proc: tarTell (inout file: inFile, in array string: arg_list,
    in boolean: do_view) is func
  local
    var header: head is header.value;
    var time: modTime is time.value;
  begin
    readHead(inFile, head);
    while head.name <> "" and (head.magic = TMAGIC or head.magic = NOMAGIC) do
      if do_view then
        if head.typeflag = DIRTYPE then
          write("d");
        else
          write("-");
        end if;
        write(head.mode);
        write(" ");
        if head.uname <> "" then
          write(head.uname);
        else
          write(head.uid);
        end if;
        write("/");
        if head.gname <> "" then
          write(head.gname);
        else
          write(head.gid);
        end if;
        write(head.size lpad 14);
        write(" ");
        modTime := timestamp1970ToTime(head.mtime);
        write(strDate(modTime));
        write(" ");
        write(str_hh_mm(modTime, ":"));
        write(" ");
        # write(strTimeZone(modTime) rpad 12);
      end if;
      writeln(head.name);
      if head.size <> 0 then
        seek(inFile, tell(inFile) + succ(pred(head.size) mdiv 512) * 512);
      end if;
      readHead(inFile, head);
    end while;
  end func;


const proc: tarTell (in string: inFileName, in array string: arg_list,
    in boolean: do_view, in boolean: do_unzip) is func
  local
    var file: inFile is STD_NULL;
    var string: magicBytes is "";
  begin
    inFile := open(inFileName, "r");
    if inFile <> STD_NULL then
      magicBytes := gets(inFile, 2);
      seek(inFile, 1);
      if magicBytes = "\31;\139;" then
        inFile := gunzip(inFile);
      elsif do_unzip then
        write("tar7: File \"");
        write(inFileName);
        writeln("\" not in gzip format.");
      end if;
    end if;
    if inFile <> STD_NULL then
      tarTell(inFile, arg_list, do_view);
    else
      write("tar7: Cannot open \"");
      write(inFileName);
      writeln("\".");
    end if;
  end func;


const proc: tarXtract (inout file: inFile, in array string: arg_list,
    in boolean: do_view) is func
  local
    var string: stri is "";
    var header: head is header.value;
    var time: modTime is time.value;
    var array header: dirHeaderList is 0 times header.value;
    var integer: index is 0;
    var boolean: okay is TRUE;
  begin
    readHead(inFile, head);
    while head.name <> "" and (head.magic = TMAGIC or head.magic = NOMAGIC) and okay do
      if do_view then
        write("x ");
        writeln(head.name);
      end if;
      if endsWith(head.name, "/") then
        head.name := head.name[.. pred(length(head.name))];
      end if;
      if head.typeflag = DIRTYPE then
        if fileType(head.name) = FILE_DIR then
          dirHeaderList &:= [] (head);
        elsif fileType(head.name) = FILE_ABSENT then
          mkdir(head.name);
          dirHeaderList &:= [] (head);
        else
          writeln("*** The file " <& literal(head.name) <& " exists, but is not a directory");
          okay := FALSE;
        end if;
      elsif head.typeflag = REGTYPE or head.typeflag = AREGTYPE then
        if head.size <> 0 then
          stri := gets(inFile, succ(pred(head.size) mdiv 512) * 512);
          if fileType(head.name) = FILE_REGULAR then
            removeFile(head.name);
          end if;
          if fileType(head.name) = FILE_ABSENT then
            putf(head.name, stri[ .. head.size]);
            setFileMode(head.name, head.mode);
            modTime := timestamp1970ToTime(head.mtime);
            setMTime(head.name, modTime);
          else
            writeln("*** The file " <& literal(head.name) <& " exists, but is not a regular file");
            okay := FALSE;
          end if;
        end if;
      end if;
      readHead(inFile, head);
    end while;
    for index range length(dirHeaderList) downto 1 do
      setFileMode(dirHeaderList[index].name, dirHeaderList[index].mode);
      modTime := timestamp1970ToTime(dirHeaderList[index].mtime);
      setMTime(dirHeaderList[index].name, modTime);
    end for;
  end func;


const proc: tarXtract (in string: inFileName, in array string: arg_list,
    in boolean: do_view, in boolean: do_unzip) is func
  local
    var file: inFile is STD_NULL;
    var string: magicBytes is "";
  begin
    inFile := open(inFileName, "r");
    if inFile <> STD_NULL then
      magicBytes := gets(inFile, 2);
      seek(inFile, 1);
      if magicBytes = "\31;\139;" then
        inFile := gunzip(inFile);
      elsif do_unzip then
        write("tar7: File \"");
        write(inFileName);
        writeln("\" not in gzip format.");
      end if;
    end if;
    if inFile <> STD_NULL then
      tarXtract(inFile, arg_list, do_view);
    else
      write("tar7: Cannot open \"");
      write(inFileName);
      writeln("\".");
    end if;
  end func;


const proc: tarXtract (in string: inFileName, in boolean: do_view) is func
  begin
    tarXtract(inFileName, 0 times "", do_view, FALSE);
  end func;


const proc: tarXtract (in string: inFileName) is func
  begin
    tarXtract(inFileName, 0 times "", FALSE, FALSE);
  end func;


const proc: tarCreate (inout file: outFile, in string: basePath, in string: pathFromBase,
    in array string: arg_list, in boolean: do_view) is func
  local
    var string: name is "";
    var array string: dir_content is 0 times "";
    var string: stri is "";
    var header: head is header.value;
  begin
    for name range arg_list do
      name := pathFromBase & name;
      if do_view then
        write("c ");
        writeln(name);
      end if;
      if fileType(basePath & name) = FILE_DIR then
        dir_content := readDir(basePath & name);
        setUpHead(basePath, name, "/", head);
        head.typeflag := DIRTYPE;
        writeHead(outFile, head);
        tarCreate(outFile, basePath, name & "/", dir_content, do_view);
      else
        stri := getf(basePath & name);
        setUpHead(basePath, name, "", head);
        head.size := length(stri);
        writeHead(outFile, head);
        write(outFile, stri);
        write(outFile, "\0;" mult 511 - pred(head.size) mod 512);
      end if;
    end for;
  end func;


const proc: tarCreate (in string: outFileName, in array string: arg_list,
    in boolean: do_view, in boolean: do_zip) is func
  local
    var file: outFile is STD_NULL;
    var string: name is "";
    var integer: lastSlashPos is 0;
    var string: uncompressed is "";
  begin
    outFile := open(outFileName, "w");
    if outFile <> STD_NULL and do_zip then
      outFile := openGzipFile(outFile);
    end if;
    if outFile <> STD_NULL then
      for name range arg_list do
        lastSlashPos := rpos(name, "/");
        if lastSlashPos = 0 then
          tarCreate(outFile, "", "", [] name, do_view);
        else
          tarCreate(outFile, name[ .. lastSlashPos],
              "", [] (name[succ(lastSlashPos) ..]), do_view);
        end if;
      end for;
      close(outFile);
    end if;
  end func;


const proc: tarCreate (in string: outFileName, in array string: arg_list,
    in boolean: do_view) is func
  begin
    tarCreate(outFileName, arg_list, do_view, FALSE);
  end func;


const proc: tarCreate (in string: outFileName, in array string: arg_list) is func
  begin
    tarCreate(outFileName, arg_list, FALSE, FALSE);
  end func;
