package RDA::Output;

# $Id: Output.pm,v 1.40 2009/02/08 23:00:09 mschenke Exp $
# ARCS: $Header: /u02/webapps/workbench/cvs/RDA_4/src/scripting/lib/RDA/Output.pm,v 1.40 2009/02/08 23:00:09 mschenke Exp $
#
# Change History
# 20090208  MSC  Implement free space check.

=head1 NAME

RDA::Output - Class Used for Objects to Manage Output Files

=head1 SYNOPSIS

require RDA::Output;

=head1 DESCRIPTION

The objects of the C<RDA::Output> class are used to manage output files.

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use File::Copy;
  use File::Spec;
  use IO::File;
}

# Define the global public variables
use vars qw($VERSION);
$VERSION = sprintf("%d.%02d", q$Revision: 1.40 $ =~ /(\d+)\.(\d+)/);

# Define the global private constants
my $TYP_INI = 0; # Initialisation function
my $TYP_MOD = 1; # File opening mode
my $TYP_FIL = 2; # File creation error
my $TYP_SHR = 3; # Share indicator

my $RET_BRK = 2;
my $RET_NXT = 3;

# Define the global private variables
my %tb_dir = (
  ref    => 'RDA-00605: Cannot create the ref directory',
  sample => 'RDA-00606: Cannot create the sample directory',
  );
my %tb_typ = (
  A =>  [\&_init_alt,
         '>',
         'RDA-00236: Cannot create the alias file ',
         0,
        ],
  D  => [\&_init_data,
         '>',
         'RDA-00202: Cannot create the output file ',
         1,
        ],
  EF => [\&_init_extern,
         '>>',
         'RDA-00231: Cannot open the external file ',
         0,
        ],
  EN => [\&_init_extern,
         '>',
         'RDA-00202: Cannot create the external file ',
         0,
        ],
  OF => [\&_init_output,
         '>>',
         'RDA-00231: Cannot open the output file ',
         1,
        ],
  ON => [\&_init_output,
         '>',
         'RDA-00202: Cannot create the output file ',
         1,
        ],
  P  => [\&_init_pipe,
         '| ',
         'RDA-00238: Cannot create the output pipe ',
         0,
        ],
  R  => [\&_init_report,
         '>',
         'RDA-00202: Cannot create the output file ',
         1,
        ],
  RF => [\&_init_ref,
         '>>',
         'RDA-00233: Cannot open the reference file ',
         0,
        ],
  RN => [\&_init_ref,
         '>',
         'RDA-00232: Cannot create the reference file ',
         0,
        ],
  SF => [\&_init_sample,
         '>>',
         'RDA-00235: Cannot open the sample file ',
         0,
        ],
  SN => [\&_init_sample,
         '>',
         'RDA-00234: Cannot create the sample file ',
         0,
        ],
  T =>  [\&_init_toc,
         '>',
         'RDA-00203: Cannot create the TOC file ',
         0,
        ],
  );

# Report the module version number
sub Version
{ $VERSION;
}

=head2 S<$h = RDA::Output-E<gt>new($agt[,$rnd])>

The output control object constructor. It takes the agent reference as an
argument.

It is represented by a blessed hash reference. The following special keys are
used:

=over 12

=item S<    B<'afl' > > Autoflush indicator

=item S<    B<'abr' > > Abbreviation of the current module

=item S<    B<'alt' > > Record to post in the alias file

=item S<    B<'bas' > > Maximum length of the report basename

=item S<    B<'cas' > > Indicates a case-sensitive context

=item S<    B<'def' > > Definition file reference of the current module

=item S<    B<'dir' > > Output directory

=item S<    B<'flt' > > Filter control object reference

=item S<    B<'grp' > > Reporting group

=item S<    B<'inc' > > Sequence number increment

=item S<    B<'mod' > > File mode hash

=item S<    B<'rnd' > > Render object reference

=item S<    B<'seq' > > Sequence number for reducing file name length

=item S<    B<'shr' > > Share definition cache

=back

=head2 S<$h-E<gt>new(typ,$top[,$nam])>

The output file object constructor. It takes the output file type, the top
block reference, and a name as arguments.

The following value types are supported:

=over 10

=item S<    B<'A' > > Alias file

=item S<    B<'B' > > Binary data file

=item S<    B<'D' > > Data file

=item S<    B<'OF'> > Existing output file

=item S<    B<'ON'> > New output file

=item S<    B<'P' > > Pipe to a command

=item S<    B<'R' > > Report file

=item S<    B<'RF'> > Existing reference file

=item S<    B<'RN'> > New reference file

=item S<    B<'SF'> > Existing sample file

=item S<    B<'SN'> > New sample file

=item S<    B<'T' > > Table of contents file

=back

It is represented by a blessed hash reference. The following special keys are
used:

=over 12

=item S<    B<'afl' > > Autoflush indicator (copy)

=item S<    B<'alt' > > Record to post in the alias file on open

=item S<    B<'dir' > > Output directory (copy)

=item S<    B<'ext' > > Output file name extension

=item S<    B<'fil' > > Output file name

=item S<    B<'flg' > > Output file flag

=item S<    B<'flt' > > Filter control object reference (copy)

=item S<    B<'mod' > > File mode hash (copy)

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

=item S<    B<'ofh' > > Output file handle

=item S<    B<'pid' > > Process identifier (pipe only)

=item S<    B<'pre' > > Code block to execute before next write operation

=item S<    B<'rnd' > > Rendering pipe handle

=item S<    B<'sig' > > Signature information

=item S<    B<'spc' > > Available space

=item S<    B<'stk' > > String stack

=item S<    B<'sub' > > Output sub directory

=item S<    B<'top' > > Top object reference

=back

=cut

sub new
{ my $cls = shift;
  my $slf;

  if (ref($cls))
  { my $typ = shift;
    my $top = shift;
    my $spc;

    # Create the output file object
    $slf = bless {typ => uc($typ), top => $top, ctl => $cls}, ref($cls);

    # Specific type initialisation
    die "RDA-00230: Invalid output file type '$typ'\n"
      unless exists($tb_typ{$slf->{'typ'}});
    &{$tb_typ{$slf->{'typ'}}->[$TYP_INI]}($slf, $typ, $top, @_);

    # Check for available space
    $slf->{'spc'} = $spc if defined($spc = $cls->{'agt'}->check_free(0));
    
    # Take care about autoflush and file name capitalisation
    $slf->{'afl'} = $cls->{'afl'};
    $slf->{'mod'} = $cls->{'mod'};
    if ($slf->{'typ'} eq 'P')
    { $slf->get_handle;
    }
    else
    { $slf->{'fil'} = lc($slf->{'fil'}) unless $cls->{'cas'};
    }
  }
  else
  { my $agt = shift;
    my $rul;
 
    # Create the output control object
    $slf = bless {inc => 1, seq => 0, shr => {}}, $cls;

    # Get some setup information
    $slf->{'agt'} = $agt;
    $slf->{'afl'} = $agt->get_setting('RDA_FLUSH', 1);
    $slf->{'bas'} = $agt->get_setting('RDA_BASENAME', 38);
    $slf->{'cas'} = $agt->get_setting('RDA_CASE', 1);
    $slf->{'dir'} = $agt->get_setting('RPT_DIRECTORY');
    $slf->{'emu'} = $agt->get_setting('RDA_SHARE', 1);
    $slf->{'grp'} = $agt->get_setting('RPT_GROUP');
    $slf->{'mod'} = $agt->get_info('mod');

    # Prepare output redirection
    if ($agt->get_setting('RDA_FILTER'))
    { eval {
        require RDA::Filter;
        $slf->{'flt'} = RDA::Filter->new($agt);
        };
    }
    elsif ($rul = $agt->get_setting('RDA_RENDER'))
    { $slf->{'rnd'} = $agt->render($rul);
    }
  }

  # Return the object reference
  $slf;
}

sub _init_alt
{ my ($slf, $typ, $top) = @_;
  my ($abr, $ctl);

  $abr = $top->{'_abr'};
  $abr =~ s/_$//;

  $slf->{'dir'} = $top->{'_rpt'};
  $slf->{'fil'} = $top->{'_grp'}.'0'.$abr.'.fil';

  $ctl = $slf->{'ctl'};
  $ctl->{'abr'} = $abr;
  $ctl->{'def'} = $slf;
  $ctl->{'shr'}->{$abr} = [];
}

sub _init_data
{ my ($slf, $typ, $top, $nam, $ext) = @_;

  $ext = '.dat' unless defined($ext);
  $slf->{'dir'} = $top->{'_rpt'};
  $slf->{'ext'} = $ext;
  $slf->{'fil'} =
    _norm_file($slf, $top->{'_grp'}.$top->{'_abr'}.$nam, $ext);
  $slf->{'nam'} = $nam;

  if (exists($slf->{'ctl'}->{'flt'}))
  { $slf->{'flt'} = $slf->{'ctl'}->{'flt'};
  }
}

sub _init_extern
{ my ($slf, $typ, $top, $nam) = @_;

  $slf->{'dir'} = $top->{'_rpt'};
  $slf->{'ext'} = '.txt';
  $slf->{'fil'} = ($slf->{'typ'} eq $typ)
    ? $nam
    : _norm_file($slf, $top->{'_grp'}.$top->{'_abr'}.$nam, $slf->{'ext'});
  $slf->{'nam'} = $nam;
  $slf->{'sub'} = 'extern';

  if (exists($slf->{'ctl'}->{'flt'}))
  { $slf->{'flt'} = $slf->{'ctl'}->{'flt'};
  }
}

sub _init_output
{ my ($slf, $typ, $top, $nam) = @_;

  $slf->{'dir'} = $top->{'_rpt'};
  $slf->{'ext'} = '.txt';
  $slf->{'fil'} = ($slf->{'typ'} eq $typ)
    ? $nam
    : _norm_file($slf, $top->{'_grp'}.$top->{'_abr'}.$nam, $slf->{'ext'});
  $slf->{'nam'} = $nam;

  if (exists($slf->{'ctl'}->{'flt'}))
  { $slf->{'flt'} = $slf->{'ctl'}->{'flt'};
  }
}

sub _init_pipe
{ my ($slf, $typ, $top, $nam) = @_;

  $slf->{'dir'} = $top->{'_rpt'};
  $slf->{'fil'} = $nam;
  $slf->{'nam'} = $nam;
}

sub _init_report
{ my ($slf, $typ, $top, $nam) = @_;
  my ($abr, $ctl, $rph);

  $abr = $top->{'_abr'};
  $slf->{'dir'} = $top->{'_rpt'};
  $slf->{'ext'} = '.txt';
  $slf->{'fil'} =
    _norm_file($slf, $top->{'_grp'}.$abr.$nam, $slf->{'ext'});
  $slf->{'nam'} = $nam;
  $slf->{'sig'} = [$top->{'_rda'}, $top->{'_nam'}, $top->{'_ver'}];

  $ctl = $slf->{'ctl'};
  if (exists($ctl->{'flt'}))
  { $slf->{'flt'} = $ctl->{'flt'};
  }
  elsif (exists($ctl->{'rnd'}))
  { $slf->{'rnd'} = $rph if ($rph = $ctl->{'rnd'}->get_handle($abr, $nam));
  }
}

sub _init_ref
{ my ($slf, $typ, $top, $nam) = @_;

  $slf->{'dir'} = $top->{'_rpt'};
  $slf->{'ext'} = '.txt';
  $slf->{'fil'} = ($slf->{'typ'} eq $typ)
    ? $nam
    : _norm_file($slf, $top->{'_grp'}.$top->{'_abr'}.$nam, $slf->{'ext'});
  $slf->{'nam'} = $nam;
  $slf->{'sub'} = 'ref';

  if (exists($slf->{'ctl'}->{'flt'}))
  { $slf->{'flt'} = $slf->{'ctl'}->{'flt'};
  }
}

sub _init_sample
{ my ($slf, $typ, $top, $nam) = @_;

  $slf->{'dir'} = $top->{'_rpt'};
  $slf->{'ext'} = '.txt';
  $slf->{'fil'} = ($slf->{'typ'} eq $typ)
    ? $nam
    : _norm_file($slf, $top->{'_grp'}.$top->{'_abr'}.$nam, $slf->{'ext'});
  $slf->{'nam'} = $nam;
  $slf->{'sub'} = 'sample';

  if (exists($slf->{'ctl'}->{'flt'}))
  { $slf->{'flt'} = $slf->{'ctl'}->{'flt'};
  }
}

sub _init_toc
{ my ($slf, $typ, $top) = @_;

  $slf->{'dir'} = $top->{'_rpt'};
  $slf->{'ext'} = '.toc';
  $slf->{'fil'} =
    _norm_file($slf, $top->{'_grp'}.$top->{'_nam'}, $slf->{'ext'});

  if (exists($slf->{'ctl'}->{'flt'}))
  { $slf->{'flt'} = $slf->{'ctl'}->{'flt'};
  }
}

# Limit the length of the file name
sub _norm_file
{ my ($slf, $fil, $suf) = @_;
  my $ctl;

  # Truncate the name
  $ctl = exists($slf->{'ctl'}) ? $slf->{'ctl'} : $slf;
  if (length($fil) > $ctl->{'bas'})
  { my $nam = $fil;
    $ctl->{'seq'} += $ctl->{'inc'};
    $fil = sprintf("%s-%04d", substr($nam, 0, $ctl->{'bas'} - 5),
      $ctl->{'seq'});
    $slf->{'alt'} = "R|$nam$suf|$fil$suf|\n";
  }

  # Return the normalized name
  $fil.$suf;
}

=head2 S<$h-E<gt>check_free($siz)>

This method checks whether the specified size is available.

=cut

sub check_free
{ my ($slf, $siz) = @_;

  if (exists($slf->{'spc'}))
  { $slf->{'spc'} -= $siz;
    die "RDA-00208: Not enough free space to complete the output request\n"
      if $slf->{'spc'} < 0;
  }
  $slf->{'spc'};
}

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

This method closes the output file if the file has been opened.

=cut

sub close
{ my ($slf) = @_;

  local $SIG{'PIPE'} = 'IGNORE';
  close($slf->{'ofh'}) if exists($slf->{'ofh'});
}

=head2 S<$h-E<gt>filter($str)>

This method filters sensitive information out of the specified string.

=cut

sub filter
{ my ($slf, $str) = @_;

  exists($slf->{'flt'}) ? $slf->{'flt'}->filter($str) : $str;
}

=head2 S<$h-E<gt>get_file([$flag])>

This method returns the name of the output file. If the flag is set, it returns
the path to the output file.

=cut

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

  my $fil = exists($slf->{'sub'})
    ? File::Spec->catfile($slf->{'sub'}, $slf->{'fil'})
    : $slf->{'fil'};
  $flg ? File::Spec->catfile($slf->{'dir'}, $fil) : $fil;
}

=head2 S<$h-E<gt>get_handle([$siz])>

This method returns the file handle of the output file. It creates the file
on the first call. It also executes prefix blocks when present. It returns
C<undef> in case of an error.

=cut

sub get_handle
{ my ($slf, $siz) = @_;
  my ($mod, $ofh, $pre, $pth, $ret, $sub, $top, $typ, $val);

  # Get the table of contents handler
  if (exists($slf->{'ofh'}))
  { $ofh = $slf->{'ofh'};
  }
  else
  { # Create the output directory when needed
    die "RDA-00200: Cannot create the report directory $pth:\n $!\n"
      unless -d ($pth = $slf->{'dir'}) || mkdir($pth, 0750);

    # Create the sub directory when needed
    if (exists($slf->{'sub'}))
    { $pth = File::Spec->catdir($pth, $slf->{'sub'});
      die $tb_dir{$slf->{'sub'}}." $pth:\n $!\n"
        unless -d $pth || mkdir($pth, 0750);
    }

    # When needed, add the record in the alias file
    print $ofh $slf->{'alt'}
      if exists($slf->{'alt'}) && ($ofh = $slf->{'top'}->{'_alt'}->get_handle);

    # Open the file
    $ofh = exists($slf->{'flt'}) ? $slf->{'flt'}->new :
      exists($slf->{'rnd'}) ? $slf->{'rnd'} : IO::File->new;
    $pth = ($slf->{'typ'} eq 'P')
      ? $slf->{'fil'}
      : File::Spec->catfile($pth, $slf->{'fil'});
    $typ = $tb_typ{$slf->{'typ'}};
    $mod = $typ->[$TYP_MOD];
    die $typ->[$TYP_FIL].$slf->{'fil'}.":\n $!\n"
      unless ($slf->{'pid'} = exists($slf->{'mod'}->{$mod})
        ? $ofh->open($pth, $slf->{'mod'}->{$mod}, 0640)
        : $ofh->open($mod.$pth));
    $ofh->autoflush(1) if $slf->{'afl'};
    $slf->{'ofh'} = $ofh;

    # Put a comment as signature in reports
    if (exists($slf->{'sig'}))
    { print $ofh
        "<!-- Oracle Remote Diagnostic Agent / Data Collection Results ",
        $slf->{'sig'}->[0], " -->\n";
      print $ofh sprintf("<!-- Module:%s Version:%.2f Report:%s OS:%s -->\n",
        $slf->{'sig'}->[1], $slf->{'sig'}->[2], $slf->{'nam'}, $^O);
    }
  }

  # Check for the available space
  $slf->check_free($siz) if defined($siz);

  # When required, execute the prefix code block
  if (exists($slf->{'pre'}))
  { $pre = delete($slf->{'pre'});
    $val = $pre->get_context->{'_val'};
    $pre->_exec;
    $ret = $pre->{'_ret'};
    $ofh = undef if $ret;
    $pre->get_context->{'_val'} = $val;
    if ($ret == $RET_NXT || $ret == $RET_BRK)
    { die "RDA-00240: Break or next used outside a loop\n";
    }
  }
  $slf->{'flg'} = 1;

  # Print the stored strings
  print $ofh @{delete($slf->{'stk'})} if exists($slf->{'stk'});

  # Return the file handle
  return $ofh;
}

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

This method returns the process identifier when piping to command. Otherwise,
it returns an undefined value.

=cut

sub get_pid
{ my ($slf) = @_;

  ($slf->{'typ'} eq 'P') ? $slf->{'pid'} : undef;
}

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

This method returns the report name.

=cut

sub get_report
{ shift->{'nam'};
}

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

This method returns the name of the output file sub directory when applicable.
Otherwise, it returns an undefined value.

=cut

sub get_sub
{ my ($slf) = @_;

  exists($slf->{'sub'}) ? $slf->{'sub'} : undef;
}

=head2 S<$h-E<gt>has_output($flg)>

This method indicates whether lines were written in the output file since the
last prefix command. When the flag is set, any prefix is cleared also.

=cut

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

  if (exists($slf->{'pre'}))
  { delete($slf->{'pre'}) if $flg;
    return 0;
  }
  exists($slf->{'ofh'});
}

=head2 S<$h-E<gt>is_created([$flg])>

This method indicates if the output file was created. It reports if the file
has not been created yet in the prefix block that is executed for the
first line written to the output file.

When the flag is set, it clears any prefix or string stack.

=cut

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

  if ($flg)
  { delete($slf->{'pre'});
    delete($slf->{'stk'});
  }
  exists($slf->{'ofh'}) && exists($slf->{'flg'});
}

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

This method indicates whether sensitive information is filtered out.

=cut

sub is_filtered
{ exists(shift->{'flt'});
}

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

This method indicates whether the output file is rendered immediately. When
applied to the output control object, it indicates if direct rendering has been
requested.

=cut

sub is_rendered
{ exists(shift->{'rnd'});
}

=head2 S<$h-E<gt>reseq($flg)>

This method splits the truncation sequence numbers in two branches. When the
flag is set, the highest branch is considered, otherwise the lowest branch. It
returns the object reference.

=cut

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

  if (exists($slf->{'seq'}))
  { $slf->{'seq'} += $slf->{'inc'} if $flg;
    $slf->{'inc'} <<= 1;
  }
  $slf;
}

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

This method resets the output control object. It returns the object reference.

=cut

sub reset
{ my $slf = shift;

  $slf->{'seq'} = 0;
  $slf->{'inc'} = 1;
  $slf;
}

=head1 PREFIX MANAGEMENT METHODS

=head2 S<$h-E<gt>deprefix($blk)>

This method suppresses the execution of a code block contained in the
specified block.

=cut

sub deprefix
{ my ($slf, $blk) = @_;

  delete($slf->{'pre'})
    if exists($slf->{'pre'}) && $slf->{'pre'}->{'_top'} == $blk;
}

=head2 S<$h-E<gt>prefix($blk)>

This method specifies a code block to execute when writing to the output file.

=cut

sub prefix
{ my ($slf, $blk) = @_;

  $slf->{'pre'} = $blk;
}

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

This method suppresses the execution of a code block when writing to the
output file.

=cut

sub unprefix
{ delete(shift->{'pre'});
}

=head1 STRING STACK MANAGEMENT METHODS

=head2 S<$h-E<gt>pop_string([$flg])>

This method pops a string from the string stack. If the flag is set, then it
deletes the string stack.

=cut

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

  if ($flg)
  { delete($slf->{'stk'});
  }
  elsif (exists($slf->{'stk'}))
  { pop(@{$slf->{'stk'}});
    delete($slf->{'stk'}) unless scalar(@{$slf->{'stk'}});
  }
}

=head2 S<$h-E<gt>push_string($str)>

This method pushes a string into the string stack.

=cut

sub push_string
{ my ($slf, $str) = @_;

  $slf->{'stk'} = [] unless exists($slf->{'stk'});
  push(@{$slf->{'stk'}}, $str);
}

1;

=head1 REPORT SHARING METHODS

=head2 S<add_share($report,$group,$link)>

This method shares the current report and adds it to the specified group with
the specified link text. It returns a true value when the operation is
successful. Otherwise, it returns a false value.

=cut

sub add_share
{ my ($slf, $out, $grp, $lnk) = @_;
  my ($ofh, $rec);

  if (ref($out) && $tb_typ{$out->{'typ'}}->[$TYP_SHR] && $grp && $lnk &&
    exists($slf->{'def'}))
  { $grp =~ s/[_\W]+/_/g;
    $lnk =~ s/[\|\n\r\s]+/ /g;
    $rec = [$grp, $out->{'nam'}, $out->{'ext'}, $out->{'sub'} || '.',
      $out->{'fil'},
      exists($slf->{'flt'}) ? $slf->{'flt'}->filter($lnk) : $lnk];
    push(@{$slf->{'shr'}->{$slf->{'abr'}}}, $rec);
    print $ofh join('|', 'S', @$rec, "\n")
      if ($ofh = $slf->{'def'}->{'top'}->{'_alt'}->get_handle);
  }
}

=head2 S<find_shares($module,$group,$module...)>

This method returns the identifiers of all shared files that belong to the
specified group. It searches the specified modules only.

=cut

sub find_shares
{ my $slf = shift;
  my $grp = shift;
  my ($cnt, $def, $ifh, @rec, @tbl);

  if ($grp)
  { $grp =~ s/[_\W]+/_/g;
    foreach my $mod (@_)
    { # Load the module sharing definitions
      if (exists($slf->{'shr'}->{$mod}))
      { $def = $slf->{'shr'}->{$mod};
      }
      else
      { $slf->{'shr'}->{$mod} = $def = [];
        $ifh = IO::File->new;
        if ($ifh->open('<'.File::Spec->catfile($slf->{'dir'},
          $slf->{'grp'}.'_0'.$mod.'.fil')))
        { while (<$ifh>)
          { next unless m/^S\|/;
            (undef, @rec) = split(/\|/, $_);
            pop(@rec);
            push(@$def, [@rec]);
          }
          $ifh->close;
        }
      }

      # Search for shared files
      $cnt = 0;
      foreach my $rec (@$def)
      { push(@tbl, "$mod:$cnt") if $grp eq $rec->[0];
        ++$cnt;
      }
    }
  }
  @tbl;
}

=head2 S<get_share($id)>

This method returns the link text of the specified shared file.

=cut

sub get_share
{ my ($slf, $id) = @_;
  my ($mod, $off);

  return undef unless $id;
  ($mod, $off) = split(/\:/, $id);
  exists($slf->{'shr'}->{$mod}) && ref($slf->{'shr'}->{$mod}->[$off])
    ? $slf->{'shr'}->{$mod}->[$off]->[5]
    : undef;
}

=head2 S<set_share($id)>

This method creates a link inside the current module to the specified shared
file. It returns the report file name when the operation is successful.
Otherwise, it returns an undefined value.

=cut

sub set_share
{ my ($slf, $id) = @_;
  my ($def, $dst, $fil, $mod, $off, $ofh, $ret, $src, $top);

  # Get the sharing definition record
  return undef unless $id && exists($slf->{'def'});
  ($mod, $off) = split(/\:/, $id);
  return undef unless exists($slf->{'shr'}->{$mod}) &&
    ref($slf->{'shr'}->{$mod}->[$off]);
  $def = $slf->{'shr'}->{$mod}->[$off];

  # Check if the file exists
  return undef
    unless -f ($src = File::Spec->catfile($slf->{'dir'}, $def->[3], $def->[4]));

  # Don't link share inside a module
  return $def->[4] if $mod eq $slf->{'abr'};

  # Link the file
  delete($slf->{'alt'});
  $top = $slf->{'def'}->{'top'};
  $fil = _norm_file($slf, $top->{'_grp'}.$top->{'_abr'}.'_link_'.$def->[1],
    $def->[2]);
  $fil = lc($fil) unless $top->{'_cas'};
  unless (-f ($dst = File::Spec->catfile($slf->{'dir'}, $def->[3], $fil)))
  { eval {$ret = link($src, $dst)};
    eval {$ret = copy($src, $dst)} unless $ret || !$slf->{'emu'};
    return undef unless $ret;
    print $ofh $slf->{'alt'}
      if exists($slf->{'alt'}) && ($ofh = $top->{'_alt'}->get_handle);
  }
  $fil;
}

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>, L<RDA::Daemon|RDA::Block>,
L<RDA::Daemon|RDA::Daemon>, L<RDA::Discover|RDA::Discover>,
L<RDA::Extra|RDA::Extra>, L<RDA::Lock|RDA::Lock>,
L<RDA::Log|RDA::Log>, L<RDA::Module|RDA::Module>,
L<RDA::Pod|RDA::Pod>, L<RDA::Profile|RDA::Profile>,
L<RDA::Remote|RDA::Remote>, L<RDA::Render|RDA::Render>,
L<RDA::Setting|RDA::Setting>, L<RDA::Upgrade|RDA::Upgrade>,
L<RDA::Value|RDA::Value>, L<RDA::Web|RDA::Web>

=head1 COPYRIGHT NOTICE

Copyright (c) 2002-2009, Oracle. All rights reserved.

=head1 TRADEMARK NOTICE

Oracle, JD Edwards, PeopleSoft, and Siebel are registered trademarks of Oracle
Corporation and/or its affiliates. Other names may be trademarks of their
respective owners.

=cut