# Archive.pm: Class Used for Archive Macros

package RDA::Library::Archive;

# $Id: Archive.pm,v 1.8 2015/05/08 18:11:47 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Library/Archive.pm,v 1.8 2015/05/08 18:11:47 RDA Exp $
#
# Change Histhry
# 20150508  MSC  Improve the documentation.

=head1 NAME

RDA::Library::Archive - Class Used for Archive Macros

=head1 SYNOPSIS

 require RDA::Library::Archive;

=head1 DESCRIPTION

The objects of the C<RDA::Library::Archive> class are used to interface with
archive-related macros.

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use RDA::Text qw(get_string);
  use RDA::Driver::Rda;
  use RDA::Object;
  use RDA::Object::Buffer;
  use RDA::Object::Rda;
  use RDA::Value::List;
  use RDA::Value::Scalar qw(:value);
}

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

# Define the global private constants

# Define the global private variables
my %tb_fct = (
  'closeArchive'      => [\&_m_close,       'T'],
  'createArchive'     => [\&_m_create,      'N'],
  'findArchiveItem'   => [\&_m_find,        'N'],
  'getArchiveBuffer'  => [\&_m_get_buffer,  'O'],
  'getArchiveContent' => [\&_m_get_content, 'L'],
  'getArchiveInfo'    => [\&_m_get_info,    'T'],
  'openArchive'       => [\&_m_open,        'T'],
  'scanArchive'       => [\&_m_scan,        'N'],
  );

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

=head2 S<$h = RDA::Library::Archive-E<gt>new($driver,$collector)>

The object constructor. It takes the library driver and collector references as
arguments.

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

=over 12

=item S<    B<'_arc'> > Archive hash

=back

Internal keys are prefixed by an underscore.

=cut

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

  # Create the macro object
  $slf = bless {
    _arc => {},
    }, ref($cls) || $cls;

  # Register the macros
  $drv->register($slf, [keys(%tb_fct)], qw(reset));

  # Return the object reference
  return $slf;
}

=head2 S<$h-E<gt>call($name,...)>

This method executes the macro code.

=cut

sub call
{ my ($slf, $nam, @arg) = @_;

  return &{$tb_fct{$nam}->[0]}($slf, @arg);
}

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

This method deletes the library control object.

=cut

sub delete_object
{ RDA::Object::dump_caller($_[0], 'Library') if $RDA::Object::DELETE;
  undef %{$_[0]};
  undef $_[0];
  return;
}

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

This method resets the library.

=cut

sub reset  ## no critic (Builtin)
{ my ($slf) = @_;

  foreach my $ctl (values(%{$slf->{'_arc'}}))
  { _close($ctl);
  }
  $slf->{'_arc'} = {};
  return;
}

=head2 S<$h-E<gt>run($name,$arg,$ctx)>

This method executes the macro with the specified argument list in a given
context.

=cut

sub run
{ my ($slf, $nam, $arg, $ctx) = @_;
  my ($fct, $ret, $typ);

  $fct = $tb_fct{$nam};
  $typ = $fct->[1];

  # Treat an array context
  return RDA::Value::List::new_from_data(&{$fct->[0]}($slf, $ctx,
    $arg->eval_as_array)) if $typ eq 'L';

  # Treat a scalar context
  return defined($ret = &{$fct->[0]}($slf, $ctx, $arg->eval_as_array))
    ? RDA::Value::Scalar->new($typ, $ret)
    : $VAL_UNDEF;
}

=head1 ARCHIVE CREATION MACROS

=head2 S<createArchive($path,$opt,$dir,[$item,...])>

This macro creates an archive containing the specified items. When you are
specifying a directory as an item, it archives the whole directory. The item
paths must be specified relatively to provided base directory. By default, it
compresses the files.

It supports the following option:

=over 9

=item B<    's' > Stores only

=back

It returns zero for a successful completion.

=cut

sub _m_create
{ my ($slf, $ctx, $pth, $opt, $dir, @fil) = @_;

  return ($pth && $dir && -d $dir)
    ? RDA::Driver::Rda->new($pth)->create($opt, $dir, @fil)
    : -1;
}

=head1 ARCHIVE MANAGEMENT MACROS

=head2 S<closeArchive($name)>

This macro closes the archive associated to the specified name.

=cut

sub _m_close
{ my ($slf, $ctx, $nam) = @_;
  my ($ctl);

  $nam = 'dft' unless defined($nam);
  _close($ctl) if defined($ctl = delete($slf->{'_arc'}->{$nam}));
  return $nam;
}

sub _close
{ my ($ctl) = @_;

  delete($ctl->{'hdr'})->delete_object if exists($ctl->{'hdr'});
  delete($ctl->{'arc'})->delete_object if exists($ctl->{'arc'});
  return;
}

=head2 S<findArchiveItem($name,$path)>

This macro searches the specified file inside the specified archive. A true
value indicates that the file is became the current archive item. It scans the
archive on first call.

=cut

sub _m_find
{ my ($slf, $ctx, $nam, $pth) = @_;
  my ($tbl);

  $nam = 'dft' unless defined($nam);
  $tbl = $slf->{'_arc'};
  return (defined($pth) && exists($tbl->{$nam}))
    ? _find($tbl->{$nam}, $pth)
    : 0;
}

sub _find
{ my ($ctl, $pth) = @_;
  my ($hdr);

  # Analyze the archive on first request
  if (exists($ctl->{'hdr'}))
  { delete($ctl->{'hdr'})->delete_object;
  }
  elsif (!exists($ctl->{'cat'}))
  { $ctl->{'arc'}->scan(\&_content, $ctl->{'cat'} = {});
  }

  # Search the specified file
  return 0 unless exists($ctl->{'cat'}->{$pth})
    && defined($hdr = $ctl->{'arc'}->find(@{$ctl->{'cat'}->{$pth}}));
  $ctl->{'hdr'} = $hdr;
  return 1;
}

=head2 S<getArchiveBuffer($name[,path])>

This macro returns a buffer for the content of the current archive header. It
returns an undefined value when the compression method is not supported or in
absence of current item.

=cut

sub _m_get_buffer
{ my ($slf, $ctx, $nam, $pth) = @_;
  my ($ctl, $ifh, $tbl);

  $nam = 'dft' unless defined($nam);
  $tbl = $slf->{'_arc'};
  return unless exists($tbl->{$nam});
  $ctl = $tbl->{$nam};

  # Find a new header when a path is provided
  _find($ctl, $pth) if defined($pth);

  # Create the buffer
  return (exists($tbl->{$nam}->{'hdr'})
    && defined($ifh = $tbl->{$nam}->{'hdr'}->get_handle))
    ? RDA::Object::Buffer->new('B', $ifh)
    : undef;
}

=head2 S<getArchiveContent($name)>

This macro returns the list of items contained in the archive associated to the
specified name.

=cut

sub _m_get_content
{ my ($slf, $ctx, $nam) = @_;
  my ($ctl, $tbl);

  $nam = 'dft' unless defined($nam);
  $tbl = $slf->{'_arc'};
  return () unless exists($tbl->{$nam});

  # Analyze the archive
  $ctl = $tbl->{$nam};
  $ctl->{'arc'}->scan(\&_content, $ctl->{'cat'} = {})
    unless exists($ctl->{'cat'});

  # Return the archive content
  return (sort keys(%{$ctl->{'cat'}}));
}

sub _content
{ my ($nam, $hdr, $cat) = @_;

  $cat->{$nam} = [$hdr->get_signature, $hdr->get_position];
  return 0;
}

=head2 S<getArchiveInfo($name,$key[,$default])>

This macro returns the value of the specified archive header attribute. If the
header attribute does not exist, then it returns the default value. The most
useful attributes are:

=over 12

=item S<    B<'crc' > > Content cyclic redundancy check

=item S<    B<'dsc' > > Comment field

=item S<    B<'met' > > Compression method

=item S<    B<'nam' > > File name

=item S<    B<'sig' > > Associated signature

=item S<    B<'siz' > > Compressed data size

=item S<    B<'szu' > > Uncompressed data size

=back

=cut

sub _m_get_info
{ my ($slf, $ctx, $nam, $key, $dft) = @_;
  my ($tbl);

  $nam = 'dft' unless defined($nam);
  $tbl = $slf->{'_arc'};
  return exists($tbl->{$nam}) && exists($tbl->{$nam}->{'hdr'})
    ? $tbl->{$nam}->{'hdr'}->get_info($key, $dft)
    : $dft;
}

=head2 S<openArchive($name,$path)>

This macro opens an archive and associates it to the specified name.

=cut

sub _m_open
{ my ($slf, $ctx, $nam, $pth) = @_;
  my ($tbl);

  # Delete any previous entry
  $nam = 'dft' unless defined($nam);
  $tbl = $slf->{'_arc'};
  _close(delete($tbl->{$nam})) if exists($tbl->{$nam});

  # Open the archive
  return unless $pth && -r $pth;
  $tbl->{$nam} = {arc => RDA::Driver::Rda->new($pth, 1)};
  return $nam;
}

=head2 S<scanArchive($name,$macro,@arg)>

This macro scans the archive associated to the specified name.

For each item, it calls the specified macro with the archive name, the item
name, and the specified arguments as arguments. A true return value aborts the
scan.

=cut

sub _m_scan
{ my ($slf, $ctx, $nam, $mac, @arg) = @_;
  my ($blk, $ctl, $tbl, $val);

  # Validate the archive name
  $nam = 'dft' unless defined($nam);
  $tbl = $slf->{'_arc'};
  return -1
    unless exists($tbl->{$nam}) && $mac && $mac =~ m/^(caller:)?(\w+)$/;
  $blk = $1 ? $ctx->get_current : $ctx;
  $mac = $2;

  # Scan the archive
  $ctl = $tbl->{$nam};
  $val = $ctl->{'arc'}->scan(\&_scan, $blk, $ctl, $mac, $nam, @arg);
  delete($ctl->{'hdr'});
  return $val;
}

sub _scan
{ my ($nam, $hdr, $blk, $ctl, $mac, $uid, @arg) = @_;

  $ctl->{'hdr'} = $hdr;
  return $blk->define_operator([$mac, '.macro.'], $blk, $mac,
    RDA::Value::List::new_from_data($uid, $nam, @arg))->eval_as_scalar;
}

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Driver::Header|RDA::Driver::Header>,
L<RDA::Driver::Library|RDA::Driver::Library>,
L<RDA::Driver::Rda|RDA::Driver::Rda>,
L<RDA::Object|RDA::Object>,
L<RDA::Object::Buffer|RDA::Object::Buffer>,
L<RDA::Object::Rda|RDA::Object::Rda>,
L<RDA::SDCL::Block|RDA::SDCL::Block>,
L<RDA::Text|RDA::Text>,
L<RDA::Value::List|RDA::Value::List>,
L<RDA::Value::Scalar|RDA::Value::Scalar>

=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