# Admin.pm: Class Used for Administration Macros

package RDA::Library::Admin;

# $Id: Admin.pm,v 1.11 2015/04/29 13:47:40 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Library/Admin.pm,v 1.11 2015/04/29 13:47:40 RDA Exp $
#
# Change History
# 20150424  MSC  Introduce the control agent concept.

=head1 NAME

RDA::Library::Admin - Class Used for Administration Macros

=head1 SYNOPSIS

 require RDA::Library::Admin;

=head1 DESCRIPTION

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

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use RDA::Text qw(get_string);
  use RDA::Object;
  use RDA::Object::Message;
  use RDA::Object::Rda;
  use RDA::SDCL::Block;
  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.11 $ =~ /(\d+)\.(\d+)/);
@ISA     = qw(Exporter);

# Define the global private constants

# Define the global private variables
my $RE_MOD = qr/^S(\d{3})([A-Z]\w*)$/i;

my %tb_fct = (
  'canRequire'    => [\&_m_can_require,    'T'],
  'checkFree'     => [\&_m_check_free,     'N'],
  'checkSpace'    => [\&_m_check_space,    'N'],
  'checkTime'     => [\&_m_check_time,     'N'],
  'convertBundle' => [\&_m_convert_bundle, 'N'],
  'convertFile'   => [\&_m_convert_file,   'T'],
  'getFile'       => [\&_m_get_file,       'T'],
  'hasThreads'    => [\&_m_has_threads,    'N'],
  'inThread'      => [\&_m_in_thread,      'N'],
  'isGraced'      => [\&_m_is_graced,      'N'],
  'isImplemented' => [\&_m_is_implemented, 'T'],
  'isProtected'   => [\&_m_is_protected,   'N'],
  'renderFile'    => [\&_m_render_file,    'T'],
  'renderIndex'   => [\&_m_render_index,   'N'],
  'setDebug'      => [\&_m_set_debug,      'N'],
  'setDefinition' => [\&_m_set_definition, 'O'],
  'setTrace'      => [\&_m_set_trace,      'N'],
  );

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

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

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

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

=over 12

=item S<    B<'_agt'> > Reference to the agent object

=item S<    B<'_col'> > Reference to the collector object

=back

=cut

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

  # Create the library object
  $slf = bless {
    _agt => $col->get_agent,
    }, ref($cls) || $cls;

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

  # Return the object reference
  return refresh($slf, $col);
}

=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>refresh($col)>

This method updates the library control object for a new collector.

=cut

sub refresh
{ my ($slf, $col) = @_;

  $slf->{'_col'} = $col;
  return $slf;
}

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

This method runs 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 ADMINISTRATION MACROS

=head2 S<canRequire($package)>

This macro indicates whether Perl can use the specified package.

=cut

sub _m_can_require
{ my ($slf, $ctx, $pkg) = @_;

  eval "require $pkg";
  return $@;
}

=head2 S<checkFree()>

This macro indicates whether it remains enough free disk space. It always
returns zero when the check is disabled or when the reporting control is not
enabled.

=cut

sub _m_check_free
{ my ($slf, $ctx) = @_;

  return $ctx->check_free;
}

=head2 S<checkSpace()>

This macro indicates whether some time is remaining. It always returns zero
when the time quota is disabled or when the reporting control is not enabled.

=cut

sub _m_check_space
{ my ($slf, $ctx) = @_;

  return $ctx->check_space;
}

=head2 S<checkTime()>

This macro indicates whether some time is remaining. It always returns zero
when the time quota is disabled.

=cut

sub _m_check_time
{ my ($slf, $ctx) = @_;

  return $ctx->check_time;
}

=head2 S<convertBundle($name[,$output])>

This macro produced the specified conversion bundle and returns the number of
converted files or an undefined value in case of conversion problems.

=cut

sub _m_convert_bundle
{ my ($slf, $ctx, $nam, $out) = @_;

  return $slf->{'_agt'}->submit(q{.},
    RDA::Object::Message->new('CONVERT.GEN_BUNDLE',
      name      => $nam,
      output    => $out,
      verbose   => 0))->get_first('count');
}

=head2 S<convertFile([$file])>

This macro converts the specified file. When no argument is specified, it ends
and renders the current report file.

It returns the name of the generated file.

=cut

sub _m_convert_file
{ my ($slf, $ctx, $rpt) = @_;

  # Convert a file
  return $slf->{'_agt'}->submit(q{.},
    RDA::Object::Message->new('CONVERT.GEN_XML',
      directory => $slf->{'_col'}->get_data,
      files     => $rpt,
      verbose   => 0))->get_first('reports')
    if $rpt;

  # Convert a report
  return ($rpt = $ctx->get_report) ? $rpt->convert : undef;
}

=head2 S<getFile([$report[,$module[,$mrc]]])>

This macro returns the name of the report file that is associated with the
specified report. It is possible to refer to another module. When no argument
is specified, it returns the name of the current report file if defined.
Otherwise, it returns an undefined value.

=cut

sub _m_get_file
{ my ($slf, $ctx, $rpt, $mod, $mrc) = @_;
  my ($col, $fil, $out, $pre, $sub);

  $out = $ctx->get_output;
  if (!defined($rpt))
  { return unless ($rpt = $out->get_info('cur'));
    $fil = $rpt->get_report;
  }
  elsif ($rpt eq q{})
  { return unless ($rpt = $out->get_info('cur'));
    $fil = $rpt->get_info('fil');
  }
  elsif ($rpt eq q{.})
  { return unless ($rpt = $out->get_info('cur'));
    $fil = $rpt->get_file;
  }
  elsif ($rpt eq q{/})
  { return unless ($rpt = $out->get_info('cur'));
    $fil = $rpt->get_file(1);
  }
  elsif ($rpt eq q{$})
  { return unless ($rpt = $out->get_info('cur'));
    $fil = RDA::Object::Rda->quote($rpt->get_file(1));
  }
  else
  { $col = $slf->{'_col'};
    if ($mod && $mod =~ m/^(\w+\.)*\w+$/
      && ($pre = $col->get_first("STATUS.$mod.W_ABR")))
    { $fil = ($mrc                               ? '%MRC:'.$mod.q{%} :
              defined($sub = $col->get_sub('C')) ? $sub.q{/} :
                                                   q{}
             ).$pre.$rpt.'.htm';
    }
    else
    { $fil = (defined($sub = $col->get_sub('C'))
        ? $sub.q{/}
        : q{}).$out->get_prefix.$rpt.'.htm';
    }
  }
  return $out->get_info('cas') ? $fil : lc($fil);
}

=head2 S<hasThreads()>

This macro indicates whether threads are running.

=cut

sub _m_has_threads
{ my ($slf, $ctx) = @_;

  return ref($ctx->get_threads) ? 1 : 0;
}

=head2 S<inThread()>

This macro indicates whether the code belongs to a thread.

=cut

sub _m_in_thread
{ my ($slf, $ctx) = @_;

  return $slf->{'_col'}->get_info('job') ? 1 : 0;
}

=head2 S<isGraced()>

This macro indicates whether the thread has not been killed due to timeout
because the thread is executing protected code.

=cut

sub _m_is_graced
{ my ($slf, $ctx) = @_;

  return ($slf->{'_col'}->get_info('job')
    && -f $slf->{'_col'}->prefix_job('.kil')) ? 1 : 0;
}

=head2 S<isImplemented($name)>

This macro indicates whether the specified macro or operator is implemented.

=cut

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

  return exists($ctx->get_package('als')->{$nam})      ? 'ALIAS' :
         $ctx->get_package('lng')->find_operator($nam) ? 'OPERATOR' :
         $ctx->get_lib->find_macro($nam)               ? 'MACRO' :
                                                         q{};
}

=head2 S<isProtected()>

This macro indicates whether the code execution is protected.

=cut

sub _m_is_protected
{ my ($slf, $ctx) = @_;

  return $ctx->get_top('pro') ? 1 : 0;
}

=head2 S<renderFile([$file[,$title]])>

This macro renders the specified file. When no argument is specified, it closes
and renders the current report file.

It returns the name of the generated file.

=cut

sub _m_render_file
{ my ($slf, $ctx, $rpt, $ttl) = @_;

  # Render a file
  return $slf->{'_agt'}->submit(q{.},
    RDA::Object::Message->new('RENDER.GEN_HTML',
      directory => $slf->{'_col'}->get_data,
      files     => $rpt,
      title     => $ttl,
      verbose   => 0))->get_first('reports')
    if $rpt;

  # Render a report
  return ($rpt = $ctx->get_report) ? $rpt->render($ttl) : undef;
}

=head2 S<renderIndex([$flag])>

This macro generates the index. When the flag is set, it re-creates the
cascading style sheet file.

=cut

sub _m_render_index
{ my ($slf, $ctx, $flg) = @_;

  $slf->{'_agt'}->submit(q{.}, RDA::Object::Message->new('RENDER.GEN_INDEX',
    css       => $flg,
    verbose   => 0));
  return 1;
}

=head2 S<setDebug([$flg])>

This macro enables or disables the debug mode. It is disabled when the output
is suppressed. It remains unchanged when the flag is undefined.

It returns the previous flag setting.

=cut

sub _m_set_debug
{ my ($slf, $ctx, $flg) = @_;
  my ($top);

  $top = $ctx->get_top;
  return $top->get_info('out') ? $top->set_info('dbg', 0) :
         defined($flg)         ? $top->set_info('dbg', $flg) :
                                 $top->get_info('dbg');
}

=head2 S<setDefinition([$def])>

This macro associates a module definition to a tool or a test module and
returns the previous definition. An undefined argument clears any previous
definition.

=cut

sub _m_set_definition
{ my ($slf, $ctx, $def) = @_;
  my ($top);

  $top = $ctx->get_top;
  die get_string('NOT_TOOL')
    unless $top->get_info('tst');
  die get_string('NOT_ITEM')
    if defined($def) && ref($def) ne 'RDA::Object::Item';
  return $top->set_info('def', $def);
}

=head2 S<setTrace([$lvl])>

This macro sets the trace level:

=over 7

=item B<    0 > No trace

=item B<    1 > Trace the command execution.

=item B<    2 > Trace the variable assignment also.

=back

The tracing is disabled when the output is suppressed. The level is unchanged
when the new level is not defined.

It returns the previous trace level.

=cut

sub _m_set_trace
{ my ($slf, $ctx, $lvl) = @_;

  return $ctx->get_info('out') ? $ctx->get_context->set_trace(0) :
         defined($lvl)         ? $ctx->get_context->set_trace($lvl) :
                                 $ctx->get_context->get_trace;
}

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Driver::Library|RDA::Driver::Library>,
L<RDA::Object|RDA::Object>,
L<RDA::Object::Collect|RDA::Object::Collect>,
L<RDA::Object::Message|RDA::Object::Message>,
L<RDA::Object::Rda|RDA::Object::Rda>,
L<RDA::Object::Report|RDA::Object::Report>,
L<RDA::Request::CONVERT|RDA::Request::CONVERT>,
L<RDA::Request::RENDER|RDA::Request::RENDER>,
L<RDA::SDCL::Block|RDA::SDCL::Block>,
L<RDA::SDCL::Context|RDA::SDCL::Context>,
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