# Archive.pm: Class Used to Manage Archives

package RDA::Object::Archive;

# $Id: Archive.pm,v 1.14 2015/08/20 11:38:35 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Object/Archive.pm,v 1.14 2015/08/20 11:38:35 RDA Exp $
#
# Change History
# 20150820  MSC  Set default compression level.

=head1 NAME

RDA::Object::Archive - Class Used to Manage Archives

=head1 SYNOPSIS

 require RDA::Object::Archive;

=head1 DESCRIPTION

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

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use RDA::Text qw(get_string);
  use RDA::Object::Collect;
  use RDA::Object::Manifest;
  use RDA::Object::Rda qw($DIR_PERMS);
  use RDA::Object::Windows;
  use RDA::Driver::7Zip;
  use RDA::Driver::Header qw($DICT_SIG);
  use RDA::Driver::Jar;
  use RDA::Driver::Pax;
  use RDA::Driver::Rda;
  use RDA::Driver::Tar;
  use RDA::Driver::Zip;
}

# Define the global public variables
use vars qw($STRINGS $VERSION @ISA %SDCL);
$VERSION = sprintf('%d.%02d', q$Revision: 1.14 $ =~ /(\d+)\.(\d+)/);
@ISA     = qw(RDA::Object Exporter);
%SDCL    = (
  beg => \&_begin_zip,
  dep => [qw(RDA::Object::Collect RDA::Object::Manifest)],
  inc => [qw(RDA::Object)],
  met => {
    'create'          => {ret => 0},
    'extract'         => {ret => 0},
    'get_catalog'     => {ret => 0},
    'get_manifest'    => {ret => 0},
    'get_path'        => {ret => 0},
    'get_status'      => {ret => 0},
    'package'         => {ret => 0},
    'set_command'     => {ret => 1},
    'set_compression' => {ret => 0},
    'set_info'        => {ret => 0},
    },
  new => 1,
  syn => [qw(RDA::Driver::Jar
             RDA::Driver::Pax
             RDA::Driver::Rda
             RDA::Driver::Tar
             RDA::Driver::Zip
             RDA::Driver::7Zip)],
  top => 'ARC',
  );

# Define the global private constants
my $CATALOG = 'catalog.xml';

# Define the global private variables
my %tb_chk = (
  Cygwin  => [\&_check_zip,
              \&_check_tar,
              \&_check_jar,
              \&_check_7z_win,
             ],
  Unix    => [\&_check_zip,
              \&_check_pax,
              \&_check_tar,
              \&_check_jar,
              \&_check_7z,
             ],
  Vms     => [\&_check_zip_vms,
             ],
  Windows => [\&_check_zip,
              \&_check_jar,
              \&_check_7z_win,
             ],
  );
my %tb_cls = (
  '7z'  => 'RDA::Driver::7Zip',
  'jar' => 'RDA::Driver::Jar',
  'pax' => 'RDA::Driver::Pax',
  'rda' => 'RDA::Driver::Rda',
  'tar' => 'RDA::Driver::Tar',
  'zip' => 'RDA::Driver::Zip',
  );
my %tb_cmd = map {$_ => 1} qw(rda);

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

=head2 S<$h = RDA::Object::Archive-E<gt>new($col[,key=E<gt>value...])>

The object constructor. This method takes the collector object reference and
extra attributes as arguments.

C<RDA::Object::Archive> is represented by a blessed hash reference. The
following special keys are used:

=over 12

=item S<    B<'agt' > > Reference to the agent object (M)

=item S<    B<'all' > > Are all archiving tool allowed ? (M)

=item S<    B<'arc' > > Archive command (M)

=item S<    B<'col' > > Reference to the collector object (M)

=item S<    B<'cwd' > > Work directory (M,S)

=item S<    B<'dir' > > Archive directory (S)

=item S<    B<'ext' > > Extract command (M)

=item S<    B<'lvl' > > Expected compression level (M)

=item S<    B<'man' > > Manifest object reference (M,S)

=item S<    B<'oid' > > Object identifier (M,S)

=item S<    B<'par' > > Parent object reference (S)

=item S<    B<'pck' > > Optional compression details (M)

=item S<    B<'pth' > > Archive path (S)

=item S<    B<'sep' > > Separator (M)

=item S<    B<'sta' > > Status of the last archive operation (S)

=item S<    B<'typ' > > Archiving type (M)

=item S<    B<'_hdr'> > Header list (S)

=item S<    B<'_inf'> > Object for getting missing object attributes (S)

=item S<    B<'_ofh'> > Archive file handle (S)

=item S<    B<'_tim'> > Archive creation time (formatted) (S)

=back

Internal keys are prefixed by an underscore.

=cut

sub new
{ my ($cls, $arg, @arg) = @_;
  my ($slf);

  if (ref($cls))
  { my ($key, $val);

    # Validate the object identifier
    die get_string('BAD_OID', $arg)
      unless defined($arg) && $arg =~ m/^\w[\w\-]*$/;

    # Create a subobject
    $slf = bless {
      arc  => $cls->{'arc'},
      cwd  => $cls->{'cwd'},
      ext  => $cls->{'ext'},
      oid  => lc($arg),
      par  => $cls,
      sep  => q{},
      typ  => $cls->{'typ'},
      _inf => $cls,
      }, $tb_cls{$cls->{'typ'}};

    # Define extra attributes
    while (($key,$val) = splice(@arg, 0, 2))
    { $slf->{$key} = $val if defined($val);
    }
  }
  else
  { my ($cfg, $tgt, $val);

    # Validate the arguments
    die get_string('NO_COLLECTOR') unless ref($arg) eq 'RDA::Object::Collect';

    # Create the master object
    $cfg = $arg->get_config;
    $slf = bless {
      agt => $arg->get_agent,
      all => $arg[0] ? 0 : 1,
      col => $arg,
      cwd => $cfg->get_group('D_CWD'),
      lvl => $arg->get_first('PACKAGE.N_COMPRESS', 9),
      man => RDA::Object::Manifest->new($cfg->get_version),
      oid => $arg->get_info('oid'),
      typ => 'rda',
      }, $cls;

    # Determine applicable routines
    $tgt = $arg->get_target;
    $tgt = $val if defined($val = $tgt->get_home);
    foreach my $fct (@{$tb_chk{$cfg->get_family}})
    { last if &$fct($slf, $tgt);
    }
  }

  # Return the object reference
  return $slf;
}

sub _can_compress
{ my ($slf, $tgt) = @_;
  my ($exe);

  if ($slf->{'lvl'})
  { if ($exe = _get_command($slf, $tgt, 'GZIP', 'gzip'))
    { $slf->{'pck'} = ['.gz', $exe, q{-}.$slf->{'lvl'}, '-q'];
    }
    elsif ($exe = _get_command($slf, $tgt, 'XZ', 'xz'))
    { $slf->{'pck'} = ['.xz', $exe, q{-}.$slf->{'lvl'}, '-q'];
    }
    elsif ($exe = _get_command($slf, $tgt, 'COMPRESS', 'compress'))
    { $slf->{'pck'} = ['.Z', $exe];
    }
  }
  return;
}

sub _check_7z
{ my ($slf, $tgt) = @_;
  my ($exe);

  return 0 unless ($exe = _get_command($slf, $tgt, '7ZIP', '7z', '7za'));
  $slf->{'typ'} = '7z';
  $slf->{'arc'} = $slf->{'ext'} = $exe;
  return 1;
}

sub _check_7z_win
{ my ($slf, $tgt) = @_;
  my ($dir, $exe, $win);

  unless ($exe = _get_command($slf, $tgt, '7ZIP', '7z', '7za'))
  { return 0 if defined($exe);
    $win = RDA::Object::Windows->new($slf->{'col'});
    ## no critic (Interpolation)
    return 0
      unless -d ($dir = $win->get_registry('HKLM\SOFTWARE\7-Zip', 'Path'))
      && (-r ($exe = RDA::Object::Rda->cat_file($dir, '7z.exe')) ||
          -r ($exe = RDA::Object::Rda->cat_file($dir, '7za.exe')));
    $slf->{'col'}->set_value('PACKAGE.F_7ZIP', $exe, '7z path');
  }
  $slf->{'typ'} = '7z';
  $slf->{'arc'} = $slf->{'ext'} = $exe;
  return 1;
}

sub _check_jar
{ my ($slf, $tgt) = @_;
  my ($exe);

  return 0 unless ($exe = _get_command($slf, $tgt, 'JAR', 'jar'));
  $slf->{'typ'} = 'jar';
  $slf->{'arc'} = $slf->{'ext'} = $exe;
  return 1;
}

sub _check_pax
{ my ($slf, $tgt) = @_;
  my ($exe);

  return 0 unless $slf->{'all'}
    && ($exe = _get_command($slf, $tgt, 'PAX', 'pax'));
  $slf->{'typ'} = 'pax';
  $slf->{'arc'} = $slf->{'ext'} = $exe;
  _can_compress($slf, $tgt);
  return 1;
}

sub _check_tar
{ my ($slf, $tgt) = @_;
  my ($exe);

  return 0 unless $slf->{'all'}
    && ($exe = _get_command($slf, $tgt, 'TAR', 'tar'));
  $slf->{'typ'} = 'tar';
  $slf->{'arc'} = $slf->{'ext'} = $exe;
  _can_compress($slf, $tgt);
  return 1;
}

sub _check_zip
{ my ($slf, $tgt) = @_;
  my ($exe);

  return 0 unless ($exe = _get_command($slf, $tgt, 'ZIP', 'zip'));
  $slf->{'typ'} = 'zip';
  $slf->{'arc'} = $exe;
  $slf->{'ext'} = _get_command($slf, $tgt, 'UNZIP', 'unzip');
  return 1;
}

sub _check_zip_vms
{ my ($slf, $tgt) = @_;

  return 0
    if $slf->{'agt'}->get_env('RDA_NO_ZIP')
    || $slf->{'col'}->get_first('PACKAGE.B_NO_ZIP');
  eval {
    local $SIG{'__WARN__'} = sub { };
    local $SIG{'PIPE'} = 'IGNORE';
    open(PIPE,                       ## no critic (Handle,Open)
      'PIPE zip -h 2>SYS$OUTPUT |')  ## no critic (Interpolation)
      or die "Bad open\n";
    1 while <PIPE>;
    close(PIPE) or die "Bad close\n";
  };
  return 0 if $@ || $?;
  $slf->{'typ'} = 'zip';
  $slf->{'arc'} = 'zip';
  $slf->{'ext'} = 'unzip';
  $slf->{'sep'} = q{"};
  return 1;
}

sub _get_command
{ my ($slf, $tgt, $typ, @cmd) = @_;
  my ($col, $exe);

  $col = $slf->{'col'};
  return q{}
    if $slf->{'agt'}->get_env("RDA_NO_$typ")
    || $col->get_first("PACKAGE.B_NO_$typ");
  unless ($exe = $col->get_primary("PACKAGE.F_$typ"))
  { foreach my $cmd (@cmd)
    { next unless ($exe = $tgt->find_command($cmd, 1));
      $col->set_value("PACKAGE.F_$typ", RDA::Object::Rda->native($exe),
        "$typ path");
      last;
    }
  }
  return $exe;
}

=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.

=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.

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

This method returns a reference to the archive manifest.

=cut

sub get_manifest
{ return shift->{'man'};
}

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

This method returns the archive path.

=cut

sub get_path
{ return shift->{'pth'};
}

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

This method returns the exit status of the last archiving command. It returns
an undefined value, when the command has not been executed.

=cut

sub get_status
{ return shift->{'sta'};
}

=head2 S<$h-E<gt>set_command($typ,$cmd[,$ext])>

This method specifies a specific commands to use for managing archives. It
supports the C<jar> and C<zip> types. It returns a list containing the previous
type and the previous commands)

=cut

sub set_command
{ my ($slf, $typ, $arc, $ext) = @_;

  # Validate the arguments
  die get_string('BAD_TYPE', $typ) unless exists($tb_cls{$typ});
  die get_string('NO_COMMAND')     unless $arc || exists($tb_cmd{$typ});
  $ext = $arc unless defined($ext);

  # Change the command
  $slf = $slf->get_top;
  ($arc, $slf->{'arc'}) = ($slf->{'arc'}, $arc);
  ($ext, $slf->{'ext'}) = ($slf->{'ext'}, $ext);
  ($typ, $slf->{'typ'}) = ($slf->{'typ'}, $typ);
  return ($typ, $arc, $ext);
}

=head2 S<$h-E<gt>set_compression($lvl)>

This method sets the expected compression level and returns the previous level.

=cut

sub set_compression
{ my ($slf, $lvl) = @_;
  my ($old);

  $old = $slf->{'lvl'};
  $slf->{'lvl'} = $1 if defined($lvl) && $lvl =~ m/^(\d)$/;
  return $old;
}

=head2 S<$h-E<gt>set_directory($dir)>

This method returns a reference to an archive object that can extract files to
the specified directory.

=cut

sub set_directory
{ my ($slf, $dir) = @_;

  return $slf->new('XFR', dir => $dir);
}

=head1 RESULTS ARCHIVE METHODS

=head2 S<$h-E<gt>package($oid,$loc[,$dir[,$fil,...]])>

This method creates a new result archive. Unless files are specified as
arguments, it includes recursively the whole directory in the archive. It
returns a reference to the new archive object.

=cut

sub package  ## no critic (Builtin)
{ my ($slf, $oid, $loc, $dir, @fil) = @_;
  my ($arc, $ext);

  # Create the archive object
  $ext = $tb_cls{$slf->{'typ'}}->get_extension;
  $arc = $slf->new($oid,
    dir => $loc,
    man => $slf->{'man'}->clone,
    pth => RDA::Object::Rda->cat_file($loc, $oid.$ext),
    );

  # Create the archive
  if (-d $loc)
  { 1 while unlink($arc->{'pth'},
                   $arc->{'pth'}.'.Z',
                   $arc->{'pth'}.'.gz',
                   $arc->{'pth'}.'.xz');
  }
  else
  { RDA::Object::Rda->create_dir($loc, $DIR_PERMS, 0,
      $slf->{'agt'}->should_align);
  }
  $arc->{'sta'} = $arc->create('m', $dir, @fil);

  # Return the archive reference
  return $arc;
}

# --- SDCL extensions ---------------------------------------------------------

# Initialize the local output control
sub _begin_zip
{ my ($pkg) = @_;

  # Define the global variable
  $pkg->set_top('ARC', RDA::Object::Archive->new($pkg->get_collector));
  return;
}

1;

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Driver::7Zip|RDA::Driver::7Zip>,
L<RDA::Driver::Header|RDA::Driver::Header>,
L<RDA::Driver::Jar|RDA::Driver::Jar>,
L<RDA::Driver::Pax|RDA::Driver::Pax>,
L<RDA::Driver::Rda|RDA::Driver::Rda>,
L<RDA::Driver::Tar|RDA::Driver::Tar>,
L<RDA::Driver::Zip|RDA::Driver::Zip>,
L<RDA::Object|RDA::Object>,
L<RDA::Object::Collect|RDA::Object::Collect>,
L<RDA::Object::Manifest|RDA::Object::Manifest>,
L<RDA::Object::Rda|RDA::Object::Rda>,
L<RDA::Object::Windows|RDA::Object::Windows>,
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