# Zip.pm: Class Used to Manage Archives using Zip

package RDA::Driver::Zip;

# $Id: Zip.pm,v 1.13 2015/08/10 14:09:38 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Driver/Zip.pm,v 1.13 2015/08/10 14:09:38 RDA Exp $
#
# Change History
# 20150810  MSC  Control the compression level.

=head1 NAME

RDA::Driver::Zip - Class Used to Manage Archives using Zip

=head1 SYNOPSIS

 require RDA::Driver::Zip;

=head1 DESCRIPTION

The objects of the C<RDA::Driver::Zip> class are used to manage archives using
F<zip>. It is a subclass of L<RDA::Object::Archive|RDA::Object::Archive>.

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use IO::Handle;
  use RDA::Text qw(get_string);
  use RDA::Object::Archive;
  use RDA::Object::Rda qw($DIR_PERMS);
}

# Define the global public variables
use vars qw($STRINGS $VERSION @ISA);
$VERSION = sprintf('%d.%02d', q$Revision: 1.13 $ =~ /(\d+)\.(\d+)/);
@ISA     = qw(RDA::Object::Archive RDA::Object Exporter);

# Define the global private constants

# Define the global private variables

# Report the package version
sub Version
{ return $VERSION;
}

=head2 S<$h-E<gt>create($opt[,$dir[,$fil,...]])>

This method creates the archive file. Unless files are specified as arguments,
it includes recursively the whole directory in the archive. By default, it
compresses the files but does not create a manifest file.

It supports the following request options:

=over 9

=item B<    'm' > Creates a manifest file.

=item B<    's' > Stores only.

=back

It returns the exit code.

=cut

sub create
{ my ($slf, $req, $dir, @fil) = @_;
  my ($cmd, $cwd, $lvl, $man, $msk, $pth, $sep);

  # Determine the archive path
  $cwd = $slf->{'cwd'};
  $dir = RDA::Object::Rda->current_dir unless defined($dir);
  $pth = RDA::Object::Rda->cat_file($cwd, $pth)
    unless RDA::Object::Rda->is_absolute($pth = $slf->{'pth'});

  # Prepare the command
  $sep = $slf->get_info('sep');
  $lvl = $slf->get_info('lvl', 9);
  $cmd = RDA::Object::Rda->quote($slf->get_info('arc'))
    .((index($req, 's') < 0) ? qq{ $sep-q${lvl}D\@$sep } : qq{ $sep-q0D\@$sep })
    .RDA::Object::Rda->quote($pth);

  # Treat manifest file
  unless (index($req, 'm') < 0)  ## no critic (Unless)
  { $man = RDA::Object::Rda->create_dir(
      RDA::Object::Rda->cat_dir($dir, 'META-INF'), $DIR_PERMS);
    $slf->get_info('man')->save(RDA::Object::Rda->cat_file($man,
      'MANIFEST.MF'));
  }

  # Execute the command
  chdir($dir) or die get_string('CD_PKG', $dir, $!);
  $msk = umask(027);        ## no critic (Number)
  open(ZIP, "| $cmd 1>&2")  ## no critic (Handle,Open)
    or die get_string('ERR_EXEC', $!);
  umask($msk);
  _zip_file(RDA::Object::Rda->cat_file('META-INF', 'MANIFEST.MF'))
    if defined($man);
  if (@fil)
  { foreach my $fil (@fil)
    { (-d $fil) ? _zip_dir($fil, $fil) : _zip_file($fil);
    }
  }
  else
  { _zip_dir(RDA::Object::Rda->current_dir);
  }
  chdir($cwd) or die get_string('CD_WRK', $cwd, $!);

  # Wait for the command completion and return the exit code
  close(ZIP);
  return $?;
}

sub _zip_dir
{ my ($dir, @dir) = @_;
  my ($pth, @sub);

  if (opendir(DIR, $dir))
  { # Treat the directory
    foreach my $fil (sort readdir(DIR))
    { next if $fil =~ m/^\./ || $fil =~ m/^(CVS|META\-INF)(\.dir)?$/i;
      $pth = RDA::Object::Rda->cat_file(@dir, $fil);
      if (-f $pth)
      { _zip_file($pth) if -r $pth;
      }
      elsif (-d $pth)
      { push(@sub, RDA::Object::Rda->cat_dir(@dir, $fil));
      }
    }
    closedir(DIR);

    # Treat the subdirectories
    foreach my $sub (@sub)
    { _zip_dir($sub, $sub);
    }
  }
  return;
}

sub _zip_file
{ my ($fil) = @_;

  my $buf = "$fil\n";
  syswrite(ZIP, $buf, length($buf)) or die get_string('ERR_PIPE', $!);
  return;
}

=head2 S<$h-E<gt>extract($arc,$flg,$fil...)>

This method extracts files from the specified archive file. It stores the files
in the directory associated to the current archive.

=cut

sub extract
{ my ($slf, $arc, $flg, @fil) = @_;
  my ($msk, $sta);

  $msk = umask(027);
  $sta = system(RDA::Object::Rda->native($slf->get_info('ext')), '-qoC', $arc,
    @fil, '-d', $slf->{'dir'});
  umask($msk);
  return $sta;
}

=head2 S<$h-E<gt>get_extension>

This method returns the usual archive extension.

=cut

sub get_extension
{ return '.zip';
}

1;

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Object::Archive|RDA::Object::Archive>,
L<RDA::Object::Rda|RDA::Object::Rda>,
L<RDA::Text|RDA::Text>

=head1 COPYRIGHT NOTICE

Copyright (c) 2002, 2016, Oracle and/or its affiliates. All rights reserved.

=head1 TRADEMARK NOTICE

Oracle and Java are registered trademarks of Oracle and/or its
affiliates. Other names may be trademarks of their respective owners.

=cut