freepascal.compiler/packages/base/paszlib/demo/miniunz.pas

program MiniUnz;

{ mini unzip demo package by Gilles Vollant

  Usage : miniunz [-exvlo] file.zip [file_to_extract]

  -l or -v list the content of the zipfile.
        -e extract a specific file or all files if [file_to_extract] is missing
        -x like -e, but extract without path information
        -o overwrite an existing file without warning

  Pascal tranlastion
  Copyright (C) 2000 by Jacques Nomssi Nzali
  For conditions of distribution and use, see copyright notice in readme.txt
}{$ifdef WIN32}
  {$define Delphi}
  {$ifndef FPC}
    {$define Delphi32}
  {$endif}
{$endif}

uses {$ifdef Delphi}
  SysUtils,
  Windows,
 {$else}
   {$endif}
  zutil,
  //zlib,
  ziputils,
  unzip;

const
  CASESENSITIVITY = 0;
  WRITEBUFFERSIZE = 8192;


{ change_file_date : change the date/time of a file
    filename : the filename of the file where date/time must be modified
    dosdate : the new date at the MSDos format (4 bytes)
    tmu_date : the SAME new date at the tm_unz format }

  procedure change_file_date(const filename: PChar; dosdate: longword; tmu_date: tm_unz);
{$ifdef Delphi32}
  var
    hFile: THandle;
    ftm, ftLocal, ftCreate, ftLastAcc, ftLastWrite: TFileTime;
  begin
    hFile := CreateFile(filename, GENERIC_READ or GENERIC_WRITE,
      0, nil, OPEN_EXISTING, 0, 0);
    GetFileTime(hFile, @ftCreate, @ftLastAcc, @ftLastWrite);
    DosDateTimeToFileTime(word((dosdate shl 16)), word(dosdate), ftLocal);
    LocalFileTimeToFileTime(ftLocal, ftm);
    SetFileTime(hFile, @ftm, @ftLastAcc, @ftm);
    CloseHandle(hFile);
  end;

{$else}
  {$ifdef FPC}
var
  hFile : THandle;
  ftm,ftLocal,ftCreate,ftLastAcc,ftLastWrite : TFileTime;
begin
  hFile := CreateFile(filename,GENERIC_READ or GENERIC_WRITE,
                      0,NIL,OPEN_EXISTING,0,0);
  GetFileTime(hFile, @ftCreate, @ftLastAcc, @ftLastWrite);
  DosDateTimeToFileTime(WORD((dosdate shl 16)), WORD(dosdate), @ftLocal);
  LocalFileTimeToFileTime(ftLocal, @ftm);
  SetFileTime(hFile,ftm, ftLastAcc, ftm);
  CloseHandle(hFile);
end;
  {$else} {  msdos }
var
  f: file;
begin
  Assign(f, filename);
  Reset(f, 1); { open file for reading }
   { (Otherwise, close will update time) }
  SetFTime(f,dosDate);
  Close(f);
end;
  {$endif}
{$endif}


{ mymkdir and change_file_date are not 100 % portable
  As I don't know well Unix, I wait feedback for the unix portion }

  function mymkdir(dirname: PChar): boolean;
  var
    S: string;
  begin
    S := StrPas(dirname);
  {$I-}
    mkdir(S);
    mymkdir := IOresult = 0;
  end;

  function makedir(newdir: PChar): boolean;
  var
    buffer: PChar;
    p:      PChar;
    len:    int;
  var
    hold:   char;
  begin
    makedir := False;
    len     := strlen(newdir);

    if (len <= 0) then
      exit;

    buffer := PChar(zcalloc(nil, len + 1, 1));

    strcopy(buffer, newdir);

    if (buffer[len - 1] = '/') then
      buffer[len - 1] := #0;

    if mymkdir(buffer) then
    begin
      if Assigned(buffer) then
        zcfree(nil, buffer);
      makedir := True;
      exit;
    end;

    p := buffer + 1;
    while True do
    begin
      while ((p^ <> #0) and (p^ <> '\') and (p^ <> '/')) do
        Inc(p);
      hold := p^;
      p^   := #0;
      if (not mymkdir(buffer)) {and (errno = ENOENT)} then
      begin
        WriteLn('couldn''t create directory ', buffer);
        if Assigned(buffer) then
          zcfree(nil, buffer);
        exit;
      end;
      if (hold = #0) then
        break;
      p^ := hold;
      Inc(p);
    end;
    if Assigned(buffer) then
      zcfree(nil, buffer);
    makedir := True;
  end;

  procedure do_banner;
  begin
    WriteLn('MiniUnz 0.15, demo package written by Gilles Vollant');
    WriteLn('Pascal port by Jacques Nomssi Nzali');
    WriteLn('more info at http://wwww.tu-chemnitz.de/~nomssi/paszlib.html');
    WriteLn;
  end;

  procedure do_help;
  begin
    WriteLn('Usage : miniunz [-exvlo] file.zip [file_to_extract]');
    WriteLn;
  end;

  function LeadingZero(w: word): string;
  var
    s: string;
  begin
    Str(w: 0, s);
    if Length(s) = 1 then
      s := '0' + s;
    LeadingZero := s;
  end;

  function HexToStr(w: long): string;
  const
    ByteToChar: array[0..$F] of char = '0123456789ABCDEF';
  var
    s: string;
    i: int;
    x: long;
  begin
    s := '';
    x := w;
    for i := 0 to 3 do
    begin
      s := ByteToChar[byte(x) shr 4] + ByteToChar[byte(x) and $F] + s;
      x := x shr 8;
    end;
    HexToStr := s;
  end;

  function do_list(uf: unzFile): int;
  var
    i:      longword;
    gi:     unz_global_info;
    err:    int;
  var
    filename_inzip: array[0..255] of char;
    file_info: unz_file_info;
    ratio:  longword;
    string_method: string[255];
  var
    iLevel: uInt;
  begin
    err := unzGetGlobalInfo(uf, gi);
    if (err <> UNZ_OK) then
      WriteLn('error ', err, ' with zipfile in unzGetGlobalInfo');
    WriteLn(' Length  Method   Size  Ratio   Date    Time   CRC-32     Name');
    WriteLn(' ------  ------   ----  -----   ----    ----   ------     ----');
    for i := 0 to gi.number_entry - 1 do
    begin
      ratio := 0;
      err   := unzGetCurrentFileInfo(uf, @file_info, filename_inzip, sizeof(filename_inzip), nil, 0, nil, 0);
      if (err <> UNZ_OK) then
      begin
        WriteLn('error ', err, ' with zipfile in unzGetCurrentFileInfo');
        break;
      end;
      if (file_info.uncompressed_size > 0) then
        ratio := (file_info.compressed_size * 100) div file_info.uncompressed_size;

      if (file_info.compression_method = 0) then
        string_method := 'Stored'
      else
      if (file_info.compression_method = Z_DEFLATED) then
      begin
        iLevel := uInt((file_info.flag and $06) div 2);
        case iLevel of
          0: string_method    := 'Defl:N';
          1: string_method    := 'Defl:X';
          2, 3: string_method := 'Defl:F'; { 2:fast , 3 : extra fast}
          else
            string_method := 'Unkn. ';
        end;
      end;

      WriteLn(file_info.uncompressed_size: 7, '  ',
        string_method: 6, ' ',
        file_info.compressed_size: 7, ' ',
        ratio: 3, '%  ', LeadingZero(longword(file_info.tmu_date.tm_mon) + 1), '-',
        LeadingZero(longword(file_info.tmu_date.tm_mday)): 2, '-',
        LeadingZero(longword(file_info.tmu_date.tm_year mod 100)): 2, '  ',
        LeadingZero(longword(file_info.tmu_date.tm_hour)), ':',
        LeadingZero(longword(file_info.tmu_date.tm_min)), '  ',
        HexToStr(longword(file_info.crc)), '  ',
        filename_inzip);

      if ((i + 1) < gi.number_entry) then
      begin
        err := unzGoToNextFile(uf);
        if (err <> UNZ_OK) then
        begin
          WriteLn('error ', err, ' with zipfile in unzGoToNextFile');
          break;
        end;
      end;
    end;

    do_list := 0;
  end;


  function do_extract_currentfile(uf: unzFile; const popt_extract_without_path: int; var popt_overwrite: int): int;
  var
    filename_inzip: packed array[0..255] of char;
    filename_withoutpath: PChar;
    p:      PChar;
    err:    int;
    fout:   FILEptr;
    buf:    pointer;
    size_buf: uInt;
    file_info: unz_file_info;
  var
    write_filename: PChar;
    skip:   int;
  var
    rep:    char;
    ftestexist: FILEptr;
  var
    answer: string[127];
  var
    c:      char;
  begin
    fout := nil;

    err := unzGetCurrentFileInfo(uf, @file_info, filename_inzip,
      sizeof(filename_inzip), nil, 0, nil, 0);

    if (err <> UNZ_OK) then
    begin
      WriteLn('error ', err, ' with zipfile in unzGetCurrentFileInfo');
      do_extract_currentfile := err;
      exit;
    end;

    size_buf := WRITEBUFFERSIZE;
    buf      := zcalloc(nil, size_buf, 1);
    if (buf = nil) then
    begin
      WriteLn('Error allocating memory');
      do_extract_currentfile := UNZ_INTERNALERROR;
      exit;
    end;

    filename_withoutpath := filename_inzip;
    p := filename_withoutpath;
    while (p^ <> #0) do
    begin
      if (p^ = '/') or (p^ = '\') then
        filename_withoutpath := p + 1;
      Inc(p);
    end;

    if (filename_withoutpath^ = #0) then
    begin
      if (popt_extract_without_path = 0) then
      begin
        WriteLn('creating directory: ', filename_inzip);
        mymkdir(filename_inzip);
      end;
    end
    else
    begin

      skip := 0;
      if (popt_extract_without_path = 0) then
        write_filename := filename_inzip
      else
        write_filename := filename_withoutpath;

      err := unzOpenCurrentFile(uf);
      if (err <> UNZ_OK) then
        WriteLn('error ', err, ' with zipfile in unzOpenCurrentFile');


      if ((popt_overwrite = 0) and (err = UNZ_OK)) then
      begin
        rep := #0;

        ftestexist := fopen(write_filename, fopenread);
        if (ftestexist <> nil) then
        begin
          fclose(ftestexist);
          repeat
            Write('The file ', write_filename,
              ' exist. Overwrite ? [y]es, [n]o, [A]ll: ');
            ReadLn(answer);

            rep := answer[1];
            if ((rep >= 'a') and (rep <= 'z')) then
              Dec(rep, $20);
          until (rep = 'Y') or (rep = 'N') or (rep = 'A');
        end;

        if (rep = 'N') then
          skip := 1;

        if (rep = 'A') then
          popt_overwrite := 1;
      end;

      if (skip = 0) and (err = UNZ_OK) then
      begin
        fout := fopen(write_filename, fopenwrite);

        { some zipfile don't contain directory alone before file }
        if (fout = nil) and (popt_extract_without_path = 0) and
          (filename_withoutpath <> PChar(@filename_inzip)) then
        begin
          c := (filename_withoutpath - 1)^;
          (filename_withoutpath -1)^ := #0;
          makedir(write_filename);
          (filename_withoutpath -1)^ := c;
          fout := fopen(write_filename, fopenwrite);
        end;

        if (fout = nil) then
          WriteLn('error opening ', write_filename);
      end;

      if (fout <> nil) then
      begin
        WriteLn(' extracting: ', write_filename);

        repeat
          err := unzReadCurrentFile(uf, buf, size_buf);
          if (err < 0) then
          begin
            WriteLn('error ', err, ' with zipfile in unzReadCurrentFile');
            break;
          end;
          if (err > 0) then
            if (fwrite(buf, err, 1, fout) <> 1) then
            begin
              WriteLn('error in writing extracted file');
              err := UNZ_ERRNO;
              break;
            end;
        until (err = 0);
        fclose(fout);
        if (err = 0) then
          change_file_date(write_filename, file_info.dosDate,
            file_info.tmu_date);
      end;

      if (err = UNZ_OK) then
      begin
        err := unzCloseCurrentFile(uf);
        if (err <> UNZ_OK) then
          WriteLn('error ', err, ' with zipfile in unzCloseCurrentFile')
        else
          unzCloseCurrentFile(uf); { don't lose the error }
      end;
    end;

    if buf <> nil then
      zcfree(nil, buf);
    do_extract_currentfile := err;
  end;


  function do_extract(uf: unzFile; opt_extract_without_path: int; opt_overwrite: int): int;
  var
    i:   longword;
    gi:  unz_global_info;
    err: int;
  begin
    err := unzGetGlobalInfo(uf, gi);
    if (err <> UNZ_OK) then
      WriteLn('error ', err, ' with zipfile in unzGetGlobalInfo ');

    for i := 0 to gi.number_entry - 1 do
    begin
      if (do_extract_currentfile(uf, opt_extract_without_path,
        opt_overwrite) <> UNZ_OK) then
        break;

      if ((i + 1) < gi.number_entry) then
      begin
        err := unzGoToNextFile(uf);
        if (err <> UNZ_OK) then
        begin
          WriteLn('error ', err, ' with zipfile in unzGoToNextFile');
          break;
        end;
      end;
    end;

    do_extract := 0;
  end;

  function do_extract_onefile(uf: unzFile; const filename: PChar; opt_extract_without_path: int; opt_overwrite: int): int;
  begin
    if (unzLocateFile(uf, filename, CASESENSITIVITY) <> UNZ_OK) then
    begin
      WriteLn('file ', filename, ' not found in the zipfile');
      do_extract_onefile := 2;
      exit;
    end;

    if (do_extract_currentfile(uf, opt_extract_without_path,
      opt_overwrite) = UNZ_OK) then
      do_extract_onefile := 0
    else
      do_extract_onefile := 1;
  end;

  { -------------------------------------------------------------------- }
  function main: int;
  const
    zipfilename: PChar = nil;
    filename_to_extract: PChar = nil;
  var
    i:    int;
    opt_do_list: int;
    opt_do_extract: int;
    opt_do_extract_withoutpath: int;
    opt_overwrite: int;
    filename_try: array[0..512 - 1] of char;
    uf:   unzFile;
  var
    p:    int;
    pstr: string[255];
    c:    char;
  begin
    opt_do_list := 0;
    opt_do_extract := 1;
    opt_do_extract_withoutpath := 0;
    opt_overwrite := 0;
    uf := nil;

    do_banner;
    if (ParamCount = 0) then
    begin
      do_help;
      Halt(0);
    end
    else
      for i := 1 to ParamCount do
      begin
        pstr := ParamStr(i);
        if pstr[1] = '-' then
          for p := 2 to Length(pstr) do
          begin
            c := pstr[p];
            case UpCase(c) of
              'L',
              'V': opt_do_list    := 1;
              'X': opt_do_extract := 1;
              'E':
              begin
                opt_do_extract := 1;
                opt_do_extract_withoutpath := 1;
              end;
              'O': opt_overwrite := 1;
            end;
          end
        else
        begin
          pstr := pstr + #0;
          if (zipfilename = nil) then
            zipfilename := StrNew(PChar(@pstr[1]))
          else
          if (filename_to_extract = nil) then
            filename_to_extract := StrNew(PChar(@pstr[1]));
        end;
      end{ for };

    if (zipfilename <> nil) then
    begin
      strcopy(filename_try, zipfilename);
      uf := unzOpen(zipfilename);
      if (uf = nil) then
      begin
        strcat(filename_try, '.zip');
        uf := unzOpen(filename_try);
      end;
    end;

    if (uf = nil) then
    begin
      WriteLn('Cannot open ', zipfilename, ' or ', zipfilename, '.zip');
      Halt(1);
    end;

    WriteLn(filename_try, ' opened');

    if (opt_do_list = 1) then
    begin
      main := do_list(uf);
      exit;
    end
    else
    if (opt_do_extract = 1) then
      if (filename_to_extract = nil) then
      begin
        main := do_extract(uf, opt_do_extract_withoutpath, opt_overwrite);
        exit;
      end
      else
      begin
        main := do_extract_onefile(uf, filename_to_extract,
          opt_do_extract_withoutpath, opt_overwrite);
        exit;
      end;

    unzCloseCurrentFile(uf);

    strDispose(zipfilename);
    strDispose(filename_to_extract);
    main := 0;
  end;

begin
  main;
  Write('Done...');
  Readln;
end.