package RDA::Agent; # $Id: Agent.pm,v 1.96 2008/02/25 13:59:09 mschenke Exp $ # ARCS: $Header: /home/cvs/repository/RDA_4/src/scripting/lib/RDA/Agent.pm,v 1.96 2008/02/25 13:59:09 mschenke Exp $ # # Change History # 20080225 MSC Improve the documentation. =head1 NAME RDA::Agent - Class Used for Objects to Interface with the Diagnostic Agent =head1 SYNOPSIS require RDA::Agent; =head1 DESCRIPTION The objects of the C class are used to interface with the Remote Diagnostic Agent. The following methods are available: =cut use strict; BEGIN { use Exporter; use File::Spec; use IO::Handle; use RDA::Log; } autoflush STDOUT 1; autoflush STDERR 1; # Define the global public variables use vars qw($VERSION); $VERSION = sprintf("%d.%02d", q$Revision: 1.96 $ =~ /(\d+)\.(\d+)/); # Define the global private constants my $BLD = '000000'; my $DSC = 'Unknown group'; my $LIN = ('#' x 79)."\n"; my $SEP = '#'.('-' x 78)."\n"; # Define the global private variables my $re_mod = qr/^S(\d{3})([A-Za-z]\w*)\.(ctl|def)$/i; my $re_nam = qr/^S(\d{3})([A-Za-z]\w*)$/i; my $re_tst = qr/^(TL|TST)(\w+)\.(ctl|def)$/i; my %tb_cap = ( 'end' => '_end', 'stat' => '_sta', 'thread' => '_thr', ); my @tb_col = qw(pending skip done); my %tb_col = ( 'pending' => 0, 'skip' => 1, 'done' => 2, ); my %tb_err = ( 'OCM' => 'ocm.txt', 'ODRDA' => 'odrda.txt', 'RDA' => 'err.txt', ); my %tb_fam = ( 'aix' => 'Unix', 'bsdos' => 'Unix', 'cygwin' => 'Win32', 'darwin' => 'Unix', 'dec_osf' => 'Unix', 'dgux' => 'Unix', 'dynixptx' => 'Unix', 'freebsd' => 'Unix', 'hpux' => 'Unix', 'irix' => 'Unix', 'linux' => 'Unix', 'MSWin32' => 'Win32', 'next' => 'Unix', 'openbsd' => 'Unix', 'svr4' => 'Unix', 'sco_sv' => 'Unix', 'solaris' => 'Unix', 'sunos' => 'Unix', 'VMS' => 'VMS', 'Windows_NT' => 'Win32', ); my %tb_fct = ( 'askPassword' => [\&_m_ask_password, 'T'], 'canFork' => [\&can_fork, 'N'], 'displayText' => [\&_m_dsp_text, 'N'], 'explain' => [\&_m_explain, 'L'], 'getDesc' => [\&_m_get_desc, 'L'], 'getFamily' => [\&get_family, 'T'], 'getModules', => [\&get_modules, 'L'], 'getOsName' => [\&get_osname, 'T'], 'getPid' => [\&_m_get_pid, 'N'], 'getSetting' => [\&_m_get_setting, 'T'], 'getTools', => [\&get_tools, 'L'], 'grepSetting' => [\&_m_grep_setting, 'L'], 'isUnix' => [\&is_unix, 'N'], 'isVms' => [\&is_vms, 'N'], 'isWindows', => [\&is_windows, 'N'], 'log' => [\&_m_log, 'N'], 'requestSetting' => [\&_m_req_setting, 'N'], 'setSetting' => [\&_m_set_setting, 'T'], 'setTempSetting' => [\&_m_temp_setting, 'T'], ); my %tb_lib = ( 'aix' => 'LIBPATH', 'darwin' => 'DYLD_LIBRARY_PATH', 'hpux' => 'SHLIB_PATH', 'unix' => 'LD_LIBRARY_PATH', ); my @tb_reg = qw( RDA::Macro::Value RDA::Macro::Env RDA::Macro::Buffer RDA::Macro::Data RDA::Macro::DB RDA::Macro::Expr RDA::Macro::File RDA::Macro::Hcve RDA::Macro::Html RDA::Macro::Http RDA::Macro::Invent RDA::Macro::Remote RDA::Macro::String RDA::Macro::Temp RDA::Macro::Xml RDA::Macro::Unix::Local RDA::Macro::Unix::Remote RDA::Macro::Windows::Local ); # Report the module version number sub Version { $VERSION; } =head2 S<$h = RDA::Agent-Enew([attrname =E $value,...])> The object constructor. This method enables you to specify initial attributes at object creation time. C is represented by a blessed hash reference. The following special keys are used: =over 16 =item B< 'bkp' > Setup backup flag =item B< 'ctl' > Configuration and control directory =item B< 'dir' > Module directory =item B< 'hcv' > HCVE directory =item B< 'lck' > Lock indicator =item B< 'lfn' > Lock file name cache =item B< 'nam' > Setup file name =item B< 'pid' > Process identifier list =item B< 'ver' > Software version =item B< 'yes' > Auto confirmation flag =item B< '_bkp' > Setting definition backup =item B< '_bld' > Current RDA build =item B< '_cfg' > Configuration indicator hash =item B< '_col' > Hash that controls the data collection =item B< '_cur' > Current module name =item B< '_def' > Hash that contains the variable definitions =item B< '_dis' > Auto discovery object =item B< '_dom' > Local domain =item B< '_dsc' > Hash that contains the module descriptions =item B< '_end' > List of libraries requiring end treatment =item B< '_flg' > Indicates if the setup is loaded =item B< '_flk' > Indicates when flock can be used =item B< '_frk' > Indicates if forking can be done =item B< '_lib' > Array of library objects =item B< '_log' > Event log object reference =item B< '_mod' > Hash that contains the module contents =item B< '_nod' > Local node name =item B< '_old' > Original setting hash =item B< '_out' > Output control object reference =item B< '_prf' > Profile object reference =item B< '_rcf' > Reconfiguration indicator hash =item B< '_rnd' > Render object reference =item B< '_run' > Hash that contains persistent sub modules =item B< '_sav' > Incremental save indicator =item B< '_set' > Setting hash =item B< '_sta' > List of libraries that provide statistics =item B< '_thr' > List of libraries that require thread initialization =item B< '_tmp' > Recent temporary settings =item B< '_vms' > VMS indicator =item B< '_win' > Windows indicator =back Internal keys are prefixed by an underscore. =cut sub new { my $slf = shift; my $class = ref($slf) || $slf; my ($key, $val); # Create the macro library object $slf = bless {}, $class; # Set the default attributes $slf->{'bkp'} = 1; $slf->{'ctl'} = '.'; $slf->{'dir'} = 'modules'; $slf->{'hcv'} = 'hcve'; $slf->{'lck'} = 0; $slf->{'lfn'} = {}; $slf->{'nam'} = 'setup'; $slf->{'pid'} = []; $slf->{'ver'} = $VERSION; $slf->{'yes'} = 0; $slf->{'_bld'} = $BLD; $slf->{'_cfg'} = {}; $slf->{'_col'} = {}; $slf->{'_def'} = {}; $slf->{'_dsc'} = {}; $slf->{'_flg'} = 0; $slf->{'_flk'} = is_vms() ? 0 : 1; $slf->{'_frk'} = 0; $slf->{'_mod'} = {}; $slf->{'_lib'} = []; $slf->{'_old'} = {}; $slf->{'_rnd'} = undef; $slf->{'_run'} = {}; $slf->{'_sav'} = 1; $slf->{'_set'} = {}; $slf->{'_sta'} = []; $slf->{'_thr'} = []; $slf->{'_tmp'} = {}; $slf->{'_vms'} = is_vms(); $slf->{'_win'} = $^O eq 'MSWin32'; # Add the initial attributes while (($key, $val) = splice(@_, 0, 2)) { $val = $key unless defined $val; $slf->{$key} = $val; } # Prevent concurrent usage of a same setup file if ($slf->{'lck'}) { eval { require RDA::Lock; if ($slf->{'lck'} > 0) { die "RDA-00111: Setup file already in use\n" unless RDA::Lock::lock($slf, $slf->{'nam'}, 1); } else { RDA::Lock::lock($slf, '-B-'.$slf->{'nam'}); } }; die $@ if $@ =~ m/^RDA-/; } # Determine the current software build number if (open(BLD, '<'.File::Spec->catfile($slf->{'dir'}, 'rda.dat'))) { $val = ; $slf->{'_bld'} = $1 if $val =~ m/#\s+\$Build:\s*\d+\.\d+\-(\d{6})\s*\$/; close(BLD); } # Predefine some settings $slf->set_setting('MOD_DIRECTORY', $slf->{'dir'}, 'D', 'Module directory'); $slf->set_setting('NO_DIALOG', $slf->{'yes'}, 'B', 'Dialog suppressed'); $slf->set_setting('HCVE_DIRECTORY', $slf->{'hcv'}, 'D', 'HCVE directory'); $slf->set_setting('RDA_BASENAME', (is_vms() ? 38 : 64), 'N', 'Maximum length of the report basename'); $slf->set_setting('RDA_CASE', !is_vms(), 'B', 'Case sensitive context'); $slf->set_setting('RDA_COLUMNS', 78, 'N', 'Screen width'); $slf->set_setting('RDA_LEVEL', 0, 'N', 'Setting level'); $slf->set_setting('RDA_PROFILE', 'Default', 'T', 'Setup profile'); $slf->set_setting('RDA_SAVE', $slf->{'_sav'}, 'B', 'Is setup information saved at the end of each module?'); $slf->set_setting('RDA_VERSION', $slf->{'ver'}, 'T', 'RDA Software version'); $slf->set_setting('CUR_BUILD', $slf->{'_bld'}, 'T', 'Current RDA build'); $slf->set_setting('OS_NAME', $^O, 'T', 'Operating system name'); # Use environment variables to control some settings $slf->set_setting('RDA_CASE', $ENV{'RDA_CASE'}) if exists($ENV{'RDA_CASE'}); $slf->set_setting('RDA_COLUMNS', $ENV{'COLUMNS'} - 2) if exists($ENV{'COLUMNS'}); # Determine the machine name $slf->{'_nod'} = 'localhost'; $slf->{'_dom'} = undef; eval { require Sys::Hostname; $val = Sys::Hostname::hostname(); ($slf->{'_nod'}, $slf->{'_dom'}) = ($1, $3) if $val && $val =~ m/^([^\.]+)(\.(.*))?$/; }; $slf->set_setting('MACHINE_NAME', $slf->{'_nod'}, 'T', 'Local machine name'); $slf->set_setting('DOMAIN_NAME', $slf->{'_dom'}, 'T', 'Domain name of this server') if $slf->{'_dom'}; # Initialize the event log $slf->{'_log'} = RDA::Log->new($slf); # Return the object reference $slf; } =head2 S<$h-Eask_password($txt)> This method asks for a password. When supported by the installed Perl version, it suppresses the character echo for password entry. When the character echo is suppressed, the method requests the password twice. If both strings do not match after three attempts, the request is cancelled. It returns the password, or, in case of failure, it returns an undefined value. =cut sub ask_password { my ($slf, $txt, $pwd) = @_; my ($clf, $cnt, $err, $fdi, $str1, $str2, $tio); # Return the default password when the dialog are suppressed return $pwd if $slf->{'yes'}; # Assume a default input prompt $txt = 'Please enter the password: ' unless defined($txt); $txt =~ s/[\s\r\n]+$/ /; # Try to get the password without character echo eval { # Get initial standard input setting require POSIX; $tio = POSIX::Termios->new; $tio->getattr($fdi = fileno(STDIN)); $clf = $tio->getlflag; # Trap Interrupt signal to restore echo sub trap_int { my $tio = POSIX::Termios->new; $tio->getattr(fileno(STDIN)); $tio->setlflag($tio->getlflag | &POSIX::ECHO); $tio->setattr(fileno(STDIN), &POSIX::TCSANOW); exit(1); } local $SIG{'INT'} = \&trap_int; # Suppress character echo $tio->setlflag($clf & ~&POSIX::ECHO); $tio->setattr($fdi, &POSIX::TCSANOW); # Ask for the password and verify string match for ($cnt = 3 ; ;) { print $txt; $str1 = ; print "\nPlease re-enter it to confirm:"; $str2 = ; print "\n"; if ($str1 ne $str2) { $err = "Entries do not match"; } else { $str1 =~ s/[\r\n]+$//; if ($str1 ne '') { $pwd = $str1; last; } $err = "Empty string"; } if (--$cnt < 1) { print "Failure to match a valid entry on 3 attempts\n"; last; } print "$err. Please try again...\n"; } # Restore initial standard input setting $tio->setlflag($clf); $tio->setattr($fdi, &POSIX::TCSANOW); }; # If that is not possible, try it without suppressing character echo if ($@) { for ($cnt = 3 ; ;) { print $txt; $pwd = ; $pwd =~ s/[\r\n]+$//; last if $pwd; if (--$cnt < 1) { print "Failure to provide a valid entry on 3 attempts\n"; last; } print "Empty string. Please try again...\n"; } } # Return the password return $pwd; } =head2 S<$h-Ecan_flock> This method indicates when flock can be used. It returns a null value when flock is not available. The return value is negative when fork is emulated. =cut sub can_flock { shift->{'_flk'}; } =head2 S<$h-Ecan_fork> This method indicates that RDA can fork processes. It returns a positive value to indicate that fork is implemented, a negative value when fork is emulated, and zero otherwise. =cut sub can_fork { shift->{'_frk'}; } =head2 S<$h-Ecan_thread> This method indicates that RDA can use threads. If threads can be used, the method returns the list of references to libraries that require some initialization. Otherwise, it returns an undefined value. =cut sub can_thread { my ($slf) = @_; $slf->{'_frk'} ? $slf->{'_thr'} : undef; } =head2 S<$h-Edsp_string(*OUT,$pre,$txt[,$nxt])> This method displays a string. The string is wrapped according to the screen width and the prefix is added on each screen line. On continuous lines, spaces replace non-space characters. The last argument indicates the number of line feeds to add at the end of the string (1 by default). =cut sub dsp_string { my $slf = shift; local *OUT = shift; my ($pre, $txt, $nxt) = @_; my ($buf, $cnt, $col, $lgt, @lin); $col = $slf->get_setting('RDA_COLUMNS') - length($pre); $cnt = scalar(@lin = split(/\n/, $txt)); $nxt = 1 unless defined($nxt); foreach my $lin (@lin) { --$cnt; $buf = ''; $lgt = $col; $lin =~ s/[\r\s]+$//; foreach my $wrd (split(/\s+/, $lin)) { $wrd =~ s/\\([0-7]{3}|0x[0-9A-Fa-f]{2})/chr(oct($1))/eg; $lgt += length($wrd) + 1; if ($lgt > $col) { if ($buf) { print OUT $pre.$buf."\n"; $pre =~ s/\S/ /g; } $lgt = length($wrd); $buf = $wrd; } else { $buf .= ' '; $buf .= $wrd; } } if ($buf) { $buf .= "\n" if $cnt || $nxt > 0; print OUT $pre.$buf; $pre =~ s/\S/ /g; } elsif ($cnt || $nxt > 0) { print OUT "\n"; } } print OUT "\n" x $nxt if --$nxt > 0; } =head2 S<$h-Edsp_text($nam[,$flg[,%var]])> This method displays text. The text can contain variables that are resolved through the specified hash. When the variable is not defined in the hash, settings are used. When the flag is set, the method requests a user acknowledgement before continuing. =cut sub dsp_text { my ($slf, $nam, $flg, %var) = @_; my ($fil, $key, $pre, $sep, $txt); # Extract the text from the file $sep = '-' x $slf->get_setting('RDA_COLUMNS'); $fil = File::Spec->catfile($slf->{'dir'}, 'rda.txt'); $txt = 0; return 0 unless open(TXT, "<$fil"); while () { s/[\s\r\n]+$//; if (m#^===\s+$nam\s+===$#) { $txt = 1; } elsif ($txt) { last if m#^===\s.*\s===$#; next if m/^#/; if (m/^$/) { print "\n"; } elsif (m/^-{3,}$/) { print $sep, "\n"; } else { $pre = $1 if s/^([\-\s]*)(\S)/$2/; s/\$\{\w+\}/_enc_value($slf, \%var, substr($&, 2, -1))/eg; $slf->dsp_string(*STDOUT, $pre, $_, 1); } } } close(TXT); # Get an user acknowledge when requested if ($txt && $flg && !$slf->{'yes'}) { print "Press 'Enter' to Continue"; $key = ; } # Indicate the result $txt; } sub _enc_value { my ($slf, $tbl, $key) = @_; my $str; $str = $tbl->{$key} || $slf->get_setting($key, '?'); $str =~ s/\\/\\134/g; $str; } =head2 S<$h-Eend> This method terminates open tasks inside the agent. =cut sub end { my $slf = shift; # Apply libraries end treatment foreach my $lib (@{$slf->{'_end'}}) { $lib->end; } # Close the rendering pipe $slf->{'_rnd'}->end if ref($slf->{'_rnd'}); # Log the end event $slf->{'_log'}->end; } =head2 S<$h-Eget_family or get_family()> This method indicates the operating system family. =cut sub get_family { exists($tb_fam{$^O}) ? $tb_fam{$^O} : $^O; } =head2 S<$h-Eget_info($key[,$default])> This method returns the value of the given object key. If it does not exist, RDA returns the default value. =cut sub get_info { my ($slf, $key, $val) = @_; $val = $slf->{$key} if exists($slf->{$key}); $val; } =head2 S<$h-Eget_osname or get_osname()> This method returns the name of the operating system. =cut sub get_osname { $^O; } =head2 S<$h-Eis_unix or is_unix()> This method returns a true value if the operating system belongs to the UNIX family. =cut sub is_unix { exists($tb_fam{$^O}) && $tb_fam{$^O} eq 'Unix'; } =head2 S<$h-Eis_vms or is_vms()> This method returns a true value if the operating system is VMS. =cut sub is_vms { $^O eq 'VMS'; } =head2 S This method encodes a string to be considered as a single argument by a command shell. When the flag is set, variable substitution is also disabled. Note: Variable substitution is disabled on VMS. =cut sub quote { my ($slf, $str, $flg) = @_; return $str unless defined($str); if ($slf->{'_win'}) { return $str unless $str =~ m/[\s\&\(\)\[\]\{\}\|\<\>\^\=\!\"\'\`\+\,\~\*\?\%]/; $str =~ s#"#"^""#g; $str =~ s#\%#"^\%"#g if $flg; } elsif ($slf->{'_vms'}) { return $str unless $str =~ m/[\s\@\"\,]/; $str =~ s#"#""#g; } else { return $str unless $str =~ m/[\s\&\(\)\[\]\{\}\|\<\>\^\!\"\'\`\~\*\?\$\#\\]/; $str =~ s#([\"\`\\])#\\$1#g; $str =~ s#\$#\\\$#g if $flg; } '"'.$str.'"'; } =head2 S<$h-Eis_windows or is_windows()> This method returns a true value if the operating system belongs to the Windows family. =cut sub is_windows { exists($tb_fam{$^O}) && $tb_fam{$^O} eq 'Win32'; } =head2 S<$h-Eset_info($key,$value)> This method assigns the value to the given object key. It returns the previous value. =cut sub set_info { my ($slf, $key, $val) = @_; ($val, $slf->{$key}) = ($slf->{$key}, $val); $val; } =head1 MACRO MANAGEMENT METHODS =head2 S<$h-Eget_macros($ref)> This method initializes a hash with all known macros. The reference to that hash is passed as an argument. =cut sub get_macros { my ($slf, $ref) = @_; foreach my $lib (@{$slf->{'_lib'}}) { my $obj = $lib->[0]; foreach my $nam (@{$lib->[1]}) { $ref->{$nam} = $obj; } } } =head2 S<$h-Einit([$debug[,$log]])> This method initializes the macro library with predefined macros. When the debug flag is set, it reports macro load problems. When the log flag is set, it verifies that the log file is available. If it is not available, then RDA creates the log file. =cut sub init { my ($slf, $dbg, $log) = @_; my $rul; # When not yet done, define the reporting environment $slf->set_temp_setting('RPT_GROUP', 'RDA') unless $slf->get_setting('RPT_GROUP'); $slf->set_temp_setting('RPT_DIRECTORY', File::Spec->catfile($slf->{'ctl'}, 'output')) unless $slf->get_setting('RPT_DIRECTORY'); # Preload Digest::MD5, POSIX, and Socket when available eval "require Digest::MD5"; eval "require POSIX"; eval "require Socket"; # Check if fork can be done if ($slf->get_setting('RDA_FORK', 1)) { eval { my $pid; die "No fork\n" if is_vms() || !defined($pid = fork()); exit(0) unless $pid; waitpid($pid, 0); if ($pid < 0) { $slf->{'_frk'} = -1; $slf->{'_flk'} = -$slf->{'_flk'}; } else { $slf->{'_frk'} = 1; } }; } # Add macros to the libraries $slf->register($slf, [keys(%tb_fct)]); foreach my $cls (@tb_reg) { eval "require $cls"; if ($@) { print $@ if $dbg; } else { $cls->new($slf); } } # Adapt the environment variables so we get the output from all the tools delete($ENV{'LANG'}); $ENV{'NLS_LANG'} = 'AMERICAN_AMERICA.US7ASCII'; delete($ENV{'TWO_TASK'}); delete($ENV{'SQLPATH'}); if ($slf->is_unix) { my ($env, $fil, $flg, $lib, $old, $ora, @tbl, %tbl); # Align the environment and the settings $old = $ENV{'ORACLE_HOME'} if exists($ENV{'ORACLE_HOME'}); $ENV{'ORACLE_HOME'} = $ora if $ora = $slf->get_setting('ORACLE_HOME'); $flg = $old && $ora && $old ne $ora; # Adapt the command path $env = $ENV{'PATH'} || ''; $env =~ s#\Q$old\E#$ora#g if $flg; @tbl = split(/\:/, $env); %tbl = map {$_ => 1} @tbl; if ($ora) { unshift(@tbl, $fil) if -d ($fil = "$ora/bin") && !exists($tbl{$fil}); unshift(@tbl, $fil) if -d ($fil = "$ora/jdk/bin") && !exists($tbl{$fil}); } push(@tbl, $fil) if -d ($fil = "/usr/sbin") && !exists($tbl{$fil}); push(@tbl, $fil) if -d ($fil = "/usr/bin") && !exists($tbl{$fil}); push(@tbl, $fil) if -d ($fil = "/etc") && !exists($tbl{$fil}); push(@tbl, $fil) if -d ($fil = "/usr/ccs/bin") && !exists($tbl{$fil}); push(@tbl, $fil) if -d ($fil = "/sbin") && !exists($tbl{$fil}); $ENV{'PATH'} = join(':', @tbl); # Adapt the shared library path if ($lib = exists($tb_lib{$^O}) ? $tb_lib{$^O} : $tb_lib{'unix'}) { $env = $ENV{$lib} || ''; $env =~ s#\Q$old\E#$ora#g if $flg; @tbl = split(/\:/, $env); %tbl = map {$_ => 1} @tbl; if ($ora) { unshift(@tbl, $fil) if -d ($fil = "$ora/lib") && !exists($tbl{$fil}); } push(@tbl, $fil) if -d ($fil = "/lib") && !exists($tbl{$fil}); push(@tbl, $fil) if -d ($fil = "/usr/lib") && !exists($tbl{$fil}); push(@tbl, $fil) if -d ($fil = "/usr/local/lib") && !exists($tbl{$fil}); $ENV{$lib} = join(':', @tbl); $slf->set_temp_setting('RDA_SHLIB', $lib); } } elsif ($slf->is_windows) { my ($env, $fil, $flg, $old, $ora, $sep, @tbl, %tbl); # Align the environment and the settings $old = $ENV{'ORACLE_HOME'} if exists($ENV{'ORACLE_HOME'}); $ENV{'ORACLE_HOME'} = $ora if $ora = $slf->get_setting('ORACLE_HOME'); $flg = $old && $ora && lc($old) ne lc($ora); # Adapt the command path if ($ora) { $sep = ($^O eq 'MSWin32') ? ';' : ':'; $env = $ENV{'PATH'} || ''; $env =~ s#\Q$old\E#$ora#ig if $flg; @tbl = split(/$sep/, $env); %tbl = map {$_ => 1} @tbl; unshift(@tbl, $fil) if -d ($fil = File::Spec->catdir($ora, 'bin')) && !exists($tbl{$fil}); unshift(@tbl, $fil) if -d ($fil = File::Spec->catdir($ora, 'jdk', 'bin')) && !exists($tbl{$fil}); $ENV{'PATH'} = join($sep, @tbl); } } # Take care that the log file is available $slf->{'_log'}->init($slf->get_setting('RPT_DIRECTORY'), $log); # Return the object reference $slf; } =head2 S<$h-Eregister($obj,$list[,$cap,...])> This method registers a list of macros associated with the specified object. You can specify a list of additional capabilities such as C for statistics, and C for thread initialization. =cut sub register { my $slf = shift; my $obj = shift; my $lst = shift; push(@{$slf->{'_lib'}}, [$obj, $lst]); foreach my $cap (@_) { push(@{$slf->{$tb_cap{$cap}}}, $obj) if exists($tb_cap{$cap}); } } =head2 S<$h-Erun($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); require RDA::Value; $fct = $tb_fct{$nam}; $typ = $fct->[1]; # Treat an array context return RDA::Value::new_list(&{$fct->[0]}($slf, $ctx, $arg->eval_as_array)) if $typ eq 'L'; # Treat a scalar context $ret = &{$fct->[0]}($slf, $ctx, $arg->eval_as_array); $typ = 'U' unless defined($ret); return RDA::Value->new($typ, $ret); } =head1 SETUP MANAGEMENT METHODS =head2 S<$h-Ebackup_settings> This method backs up the setting definition. =cut sub backup_settings { my $slf = shift; my $bkp; # Backup the setting definitions $slf->{'_bkp'} = $bkp = {}; $bkp->{'_def'} = {%{$slf->{'_def'}}}; $bkp->{'_old'} = {%{$slf->{'_old'}}}; $bkp->{'_set'} = {%{$slf->{'_set'}}}; $bkp->{'_tmp'} = {%{$slf->{'_tmp'}}}; $bkp->{'_mod'} = [@{$slf->{'_mod'}->{$bkp->{'_cur'} = $slf->{'_cur'}}}] if exists($slf->{'_cur'}); # Return the reference to the backup hash $bkp; } =head2 S<$h-Eclr_temp_setting($key)> This method restores the original setting value. It returns that value or C if not previously defined. =cut sub clr_temp_setting { my ($slf, $key) = @_; my $old; # Restore the original setting value if (exists($slf->{'_old'}->{$key})) { $old = $slf->{'_old'}->{$key}; if (defined($old)) { $slf->{'_set'}->{$key} = $old; } else { delete($slf->{'_set'}->{$key}); } delete($slf->{'_old'}->{$key}); delete($slf->{'_tmp'}->{$key}); } # Return the previous value $old; } =head2 S<$h-Edel_module($name)> This method deletes a module and adds an event (type 'D') in the event log. It returns the list of settings that were previously associated with the module. =cut sub del_module { my ($slf, $nam) = @_; my (@tbl); # Save the previous definition @tbl = @{$slf->{'_mod'}->{$nam}} if exists($slf->{'_mod'}->{$nam}); # Delete the module delete($slf->{'_dsc'}->{$nam}); delete($slf->{'_mod'}->{$nam}); delete($slf->{'_col'}->{$nam}) unless $slf->is_done($nam); $slf->log('D', $nam); # Delete the module variable definitions foreach my $key (@tbl) { delete($slf->{'_def'}->{$key}); } # Return the variables previously associated with the module @tbl; } =head2 S<$h-Edel_setting($key)> This method deletes a setting from the setup information. It returns the previous value, or C if not previously defined. =cut sub del_setting { my ($slf, $key) = @_; my $old; # Get the previous value $old = $slf->{'_set'}->{$key} if exists($slf->{'_set'}->{$key}); # Delete the variable delete($slf->{'_tmp'}->{$key}); delete($slf->{'_old'}->{$key}); delete($slf->{'_set'}->{$key}); delete($slf->{'_def'}->{$key}); # Return the previous value $old; } =head2 S<$h-Ediscover> This method returns the auto discovery object when product information is available. Otherwise, it returns an undefined value. =cut sub discover { my ($slf) = @_; my ($dir, $obj); # Get the auto discovery object if (exists($slf->{'_dis'})) { $obj = $slf->{'_dis'}; } elsif (($dir = $slf->get_setting('ORACLE_HOME')) && -d $dir) { require RDA::Discover; $slf->{'_dis'} = $obj = RDA::Discover->new($slf, $dir); } # Return it when product information is available ($obj && $obj->get_type) ? $obj : undef; } =head2 S<$h-Edsp_module($name)> This method displays the setup questions of a module. =cut sub dsp_module { my ($slf, $nam) = @_; my $obj; require RDA::Module; $obj = RDA::Module->new($nam, $slf->{'dir'}, $slf); if ($obj->load) { $obj->display($slf); } elsif ($slf->is_defined($nam) && $nam =~ $re_nam) { # Indicate that there are no setup specifications } } =head2 S<$h-Eexists_setting($key)> This method indicates if a setting exists. =cut sub exists_setting { my ($slf, $key) = @_; exists($slf->{'_set'}->{$key}); } =head2 S<$h-Eget_setting($key[,$default[,$flag]])> This method returns the value of the given setup key. If it does not exist, it returns the default value. When the flag is set, it substitutes variables in the value. =cut sub get_setting { my ($slf, $key, $val, $flg) = @_; # Get the setting value $val = $slf->{'_set'}->{$key} if exists($slf->{'_set'}->{$key}); # Replace variables if ($flg) { my ($str, $var); while ($val =~ m/(\$\{(\w+)(\:([^\}]*))?\})/) { $var = $1; $str = defined($4) ? $4 : ''; $str = $slf->get_setting($2, $str); $val =~ s/\Q$var\E/$str/g; } } # Return the value $val; } =head2 S<$h-Eget_title($nam[,$dft])> This method returns a short description (title) of the specified module. It returns the default value when it can retrieve the title. =cut sub get_title { my ($slf, $nam, $ttl) = @_; # Try to extract it from the setup return $slf->{'_dsc'}->{$nam} if exists($slf->{'_dsc'}->{$nam}); # Try to extract it from the definition file if (open(DEF, '<'.File::Spec->catfile($slf->{'dir'}, "$nam.def")) || open(DEF, '<'.File::Spec->catfile($slf->{'dir'}, "$nam.ctl"))) { my $lin = ; close(DEF); return $2 if $lin && $lin =~ m/#\s*$nam(.def)?:\s*(.*)[\s\n\r]+$/i; } # Return the default title $ttl; } =head2 S<$h-Egrep_setting($re,$opt)> This method returns the setting names that match the regular expression. It supports the following options: =over 9 =item B< 'f' > Stops scanning on the first match =item B< 'i' > Ignores case distinctions in both the pattern and the results =item B< 'n' > Sorts the settings by their name =item B< 'v' > Inverts the sense of matching to select non-matching lines =back =cut sub grep_setting { my ($slf, $re, $opt) = @_; my ($flg, $inv, $one, @tbl); # Determine the options $opt = '' unless defined($opt); $one = index($opt, 'f') >= 0; $re = (index($opt, 'i') < 0) ? qr/$re/ : qr/$re/i; $inv = index($opt, 'v') >= 0; # Scan the setting names foreach my $key (keys(%{$slf->{'_set'}})) { $flg = ($key =~ $re); if ($inv ? !$flg : $flg) { push(@tbl, $key); last if $one; } } return sort @tbl if index($opt, 'n') >= 0; @tbl; } =head2 S<$h-Eis_configured([$name])> This method indicates if a module is configured already. When no argument is specified, it indicates whether a setup file has been loaded. =cut sub is_configured { my ($slf, $nam) = @_; return $slf->{'_flg'} unless defined($nam); exists($slf->{'_cfg'}->{$nam}) && $slf->{'_cfg'}->{$nam}; } =head2 S<$h-Eis_reconfigured($name)> This method indicates if a module has been configured already during this RDA execution. =cut sub is_reconfigured { my ($slf, $nam) = @_; $nam && exists($slf->{'_rcf'}->{$nam}) && $slf->{'_rcf'}->{$nam}; } =head2 S<$h-Eload([$file])> This method loads the current setup (if a setup exists). You can specify an alternative setup file as an argument. =cut sub load { my ($slf, $fil) = @_; my ($dsc, $key, $typ, $val); # Determine the setup file name $fil = File::Spec->catfile($slf->{'ctl'}, $slf->{'nam'}.'.cfg') unless defined($fil); # Load and parse the setup information if (open(IN, "<$fil")) { $slf->set_current('?'); while () { # Trim the end of line s/[\r\n]+$//; # Treat the line if (m/^(\w+)='([^']*)'/ || m/^(\w+)="([^"]*)"/) { $key = $1; $val = $2; $val =~ s/&\#10;/\n/g; $val =~ s/&\#34;/"/g; $val =~ s/&\#39;/'/g; $slf->set_setting($key, $val, $typ, $dsc); $dsc = $typ = undef; } elsif (m/^(\w+)=(.*)$/) { $slf->set_setting($1, $2, $typ, $dsc); $dsc = $typ = undef; } elsif (m/^#([\?BDEFNT])\.\s*(.*)$/) { $typ = $1; $dsc = $2; } elsif (m/^#\s*(\w+)=(done|pending|skip)/i) { $slf->{'_col'}->{$1} = $tb_col{lc($2)}; $slf->{'_cfg'}->{$1} = ($2 eq uc($2)) ? -1 : 0 unless exists($slf->{'_cfg'}->{$1}); } elsif (m/^#\s*(\w+):\s*(.*)$/) { $slf->set_current($1, $2 || ''); $slf->{'_col'}->{$1} = 0 unless exists($slf->{'_col'}->{$1}); $slf->{'_cfg'}->{$1} = 1; } elsif (!m/^\s*(#.*)?$/) { die "RDA-00101: Invalid setup file '$fil'\n"; } } close(IN); # Update an old setup file if ($slf->get_setting('RDA_BUILD', $BLD) lt $slf->{'_bld'}) { eval { require RDA::Upgrade; RDA::Upgrade::setup($slf); $slf->set_setting('RDA_BUILD', $slf->{'_bld'}); }; } # Adjust agent attributes $slf->set_current; $slf->{'_flg'} = 1; $slf->{'_dom'} = $slf->get_setting('DOMAIN_NAME'); $slf->{'_sav'} = $slf->get_setting('RDA_SAVE'); $slf->{'ver'} = $slf->get_setting('RDA_VERSION'); # Initialise the log file $slf->{'_log'}->init($slf->get_setting('RPT_DIRECTORY')); } # Return the object reference $slf; } =head2 S<$h-Eren_module($old,$new)> This method renames a module. =cut sub ren_module { my ($slf, $old, $new) = @_; $slf->{'_cfg'}->{$new} = delete($slf->{'_cfg'}->{$old}) if exists($slf->{'_cfg'}->{$old}); $slf->{'_col'}->{$new} = delete($slf->{'_col'}->{$old}) if exists($slf->{'_col'}->{$old}); $slf->{'_dsc'}->{$new} = delete($slf->{'_dsc'}->{$old}) if exists($slf->{'_dsc'}->{$old}); $slf->{'_mod'}->{$new} = delete($slf->{'_mod'}->{$old}) if exists($slf->{'_mod'}->{$old}); $slf->{'_rcf'}->{$new} = delete($slf->{'_rcf'}->{$old}) if exists($slf->{'_rcf'}->{$old}); } =head2 S<$h-Erestore_settings> This method restores the setting definitions. It returns 1 on a successful completion. Otherwise, it returns 0. =cut sub restore_settings { my $slf = shift; my $bkp; # Abort when no backup is available return 0 unless ($bkp = delete($slf->{'_bkp'})); # Backup the setting definitions $slf->{'_def'} = $bkp->{'_def'}; $slf->{'_old'} = $bkp->{'_old'}; $slf->{'_set'} = $bkp->{'_set'}; $slf->{'_tmp'} = $bkp->{'_tmp'}; $slf->{'_mod'}->{$slf->{'_cur'} = $bkp->{'_cur'}} = $bkp->{'_mod'} if exists($bkp->{'_cur'}); # Indicate a successful completion 1; } =head2 S<$h-Esave([$file])> This method saves the setup. You can specify an alternative file name as an argument. When requested, the original setup file is renamed on first call. =cut sub save { my ($slf, $fil) = @_; my ($dsc, $tb_col, $tb_def, $tb_dsc, $tb_old, $tb_set, $tbl, $typ, $val); # Initialisation $tb_def = $slf->{'_def'}; $tb_dsc = $slf->{'_dsc'}; $tb_old = $slf->{'_old'}; $tb_set = $slf->{'_set'}; # Determine the setup file name $fil = File::Spec->catfile($slf->{'ctl'}, $slf->{'nam'}.'.cfg') unless defined($fil); # Temporarily disable signals local $SIG{'HUP'} = 'IGNORE' if exists($SIG{'HUP'}); local $SIG{'INT'} = 'IGNORE' if exists($SIG{'INT'}); local $SIG{'KILL'} = 'IGNORE' if exists($SIG{'KILL'}); local $SIG{'STOP'} = 'IGNORE' if exists($SIG{'STOP'}); local $SIG{'TERM'} = 'IGNORE' if exists($SIG{'TERM'}); local $SIG{'QUIT'} = 'IGNORE' if exists($SIG{'QUIT'}); # Backup the setup file $slf->{'bkp'} = 0 unless -f $fil; if ($slf->{'bkp'}) { my $bkp = $fil; $bkp =~ s/(\.cfg)?$/.bak/i; 1 while unlink($bkp); rename ($fil, $bkp) || die "RDA-00110: Cannot backup the setup file '$fil':\n $!\n"; $slf->{'bkp'} = 0; } # Write the setup file 1 while unlink($fil); open(OUT, ">$fil") || die "RDA-00100: Cannot create the setup file '$fil':\n $!\n"; print OUT $LIN, "# Oracle Remote Diagnostic Agent - Setup Information\n", $LIN, "\n"; print OUT $SEP, "# Data Collection Overview\n", $SEP; $tbl = $slf->{'_col'}; foreach my $mod (sort keys(%$tbl)) { $dsc = $tb_col[$tbl->{$mod}]; $dsc = uc($dsc) if $slf->{'_cfg'}->{$mod} < 0; print OUT '# ', $mod, '=', $dsc, "\n"; } print OUT "\n"; $tbl = $slf->{'_mod'}; foreach my $mod (sort keys(%$tbl)) { next unless $slf->is_configured($mod); $dsc = $tb_dsc->{$mod} || $slf->get_title($mod, ''); print OUT $SEP, '# ', $mod, ': ', $dsc, "\n", $SEP; foreach my $var (@{$tbl->{$mod}}) { next unless exists($tb_def->{$var}); ($typ, $dsc) = @{$tb_def->{$var}}; $val = exists($tb_old->{$var}) ? $tb_old->{$var} : $tb_set->{$var}; if (index('BN', $typ) < 0) { $val =~ s/'/&\#39;/g; $val =~ s/\n/&\#10;/g; $val = "'$val'"; } print OUT '#', $typ, '.', $dsc, "\n", $var, '=', $val, "\n"; } print OUT "\n"; } close(OUT); # Resync agent attributes $slf->{'_dom'} = $slf->get_setting('DOMAIN_NAME'); $slf->{'_sav'} = $slf->get_setting('RDA_SAVE'); $slf->{'ver'} = $slf->get_setting('RDA_VERSION'); # Return the configuration object reference $slf; } =head2 S<$h-Eset_current([$nam[,$dsc]])> This method sets the current module. When you provide a description, it also defines the module in the setup configuration. When no name is provided, the current module is cleared. =cut sub set_current { my ($slf, $nam, $dsc) = @_; if (defined($nam)) { # Set the current module $slf->{'_cur'} = $nam; # Add the module in the setup configuration if (defined($dsc)) { $slf->{'_dsc'}->{$nam} = $dsc; $slf->{'_mod'}->{$nam} = [] unless exists($slf->{'_mod'}->{$nam}); } } else { delete($slf->{'_cur'}); } } =head2 S<$h-Eset_setting($key,$val[,$typ,$dsc])> This method assigns a new value to a setting or creates a new setting. It also permits users to specify the setting type and description. It adds new settings to the current module automatically. You can use a special type, C<->, to store a temporary setting. It returns the previous value or C if it is not defined previously. =cut sub set_setting { my ($slf, $key, $val, $typ, $dsc) = @_; my $old; # Get the previous value $old = $slf->{'_set'}->{$key} if exists($slf->{'_set'}->{$key}); # Discard any saved value delete($slf->{'_old'}->{$key}); # Store the setting value $val = '' unless defined($val); $slf->{'_set'}->{$key} = $val; # Define the setting unless (defined($typ) && $typ eq '-') { # Add the setting definition if (defined($typ) || defined($dsc) || !exists($slf->{'_def'}->{$key})) { $typ = 'T' unless defined($typ); $dsc = $key unless defined($dsc); $slf->{'_def'}->{$key} = [$typ, $dsc]; } # Add a new setting in the content of the current module if ($typ && $dsc && exists($slf->{'_cur'})) { my $mod = $slf->{'_cur'}; for (@{$slf->{'_mod'}->{$mod}}) { return $old if $_ eq $key; } push(@{$slf->{'_mod'}->{$mod}}, $key); } } # Return the previous value $old; } =head2 S<$h-Eset_temp_setting($key,$val)> This method assigns a temporary value to a setting and does not save the change in the setup file. It returns the original setting value or C if it is not defined previously. =cut sub set_temp_setting { my ($slf, $key, $val) = @_; my $old; # Get the previous value $old = $slf->{'_set'}->{$key} if exists($slf->{'_set'}->{$key}); # Store the original setting value unless (exists($slf->{'_old'}->{$key})) { $slf->{'_old'}->{$key} = $old; $slf->{'_tmp'}->{$key} = 0; } # Assign the temporary value $slf->{'_set'}->{$key} = $val; # Return the previous value $old; } =head2 S<$h-Esetup($name[,$trace[,$save]])> This method collects the setup information for a specific module and then adds an event (type 'S') to the event log. When setup is complete, the method deletes all temporary settings created by the module. If the save flag is set, then the setup file is saved. The C setting specifies the default flag value. =cut sub setup { my ($slf, $nam, $trc, $sav) = @_; my ($obj, $val, @req); # When not yet known, attempt to determine the domain unless (defined($slf->{'_dom'})) { $slf->{'_dom'} = $ENV{'RDA_DOMAIN'} || $slf->get_setting('DOMAIN_NAME') || _get_domain("nslookup $slf->{'_nod'}", qr/Name:\s*($slf->{'_nod'})\.(\S*)/) || _get_domain('nslookup localhost', qr/Name:\s*(localhost)\.(\S*)/) || _get_domain('nslookup -debug localhost', qr/(localhost)\.([^,]*),/) || _get_domain('cat /etc/resolv.conf', qr/^(domain|search)\s+(\S*)/,''); $slf->set_setting('DOMAIN_NAME', $slf->{'_dom'}, 'T', 'Domain name of this server') if $slf->{'_dom'}; } # Determine if the setup file must save at setup end $sav = $slf->{'_sav'} unless defined($sav); # Collect the setup for the module require RDA::Module; $obj = RDA::Module->new($nam, $slf->{'dir'}, $slf); if ($obj->load) { # Collect the module settings $slf->{'_cfg'}->{$nam} = $slf->{'_rcf'}->{$nam} = 1; $slf->{'_tmp'} = {}; @req = $obj->setup($slf, $slf->get_setting('RDA_LEVEL', 0), $trc, $slf->{'yes'}, $sav); $slf->log('S', $nam, $obj->get_version); # Delete the temporary settings created by the module foreach my $key (keys(%{$slf->{'_tmp'}})) { $slf->clr_temp_setting($key); } } elsif ($slf->is_defined($nam) && $nam =~ $re_nam) { # Indicate that there are no setup specifications $slf->{'_cfg'}->{$nam} = $slf->{'_rcf'}->{$nam} = -1; $slf->{'_col'}->{$nam} = 0 unless exists($slf->{'_col'}->{$nam}); } # When requested, save the setup file $slf->save if $sav; # Setup the post-requisites foreach my $req (@req) { if ($req =~ s/^\+//) { $slf->setup($req, $trc, $sav) unless $slf->is_described($req) || $slf->is_disabled($nam); } elsif ($req =~ s/^\-//) { $slf->setup($req, $trc, $sav) unless $slf->is_described($req) || !$slf->is_disabled($nam); } else { $slf->setup($req, $trc, $sav) unless $slf->is_described($req); } } # Return the module object reference $obj; } sub _get_domain { my ($cmd, $re, $val) = @_; local $SIG{'__WARN__'} = sub {}; if (open(CMD, "$cmd 2>&1 |")) { while () { last if ($_ =~ $re) && ($val = $2); } close(CMD); } $val; } =head2 S<$h-Eupd_module($name)> This method updates the setting list for the specified module. =cut sub upd_module { my ($slf, $nam) = @_; $slf->{'_mod'}->{$nam} = [grep {exists($slf->{'_def'}->{$_})} @{$slf->{'_mod'}->{$nam}}]; } =head1 DATA COLLECTION METHODS =head2 S<$h-Ecollect($name,$debug,$trace[,$save])> This method collects the diagnostic information for the specified module. It also sets up the module when required. When the data collection is complete, the method deletes all temporary settings created by the module. If the save flag is set, then the setup file is saved. The C setting specifies the default flag value. When the data collection is complete, the method adds a collect event (type 'C') to the event log including the module completion status. When relevant, it includes execution statistics as additional events (type 's'). It returns 0 on successful completion or the number of load errors. Otherwise, it returns the error return status. =cut sub collect { my ($slf, $nam, $dbg, $trc, $sav) = @_; my ($flg, $obj, $ret, $sta); $flg = $nam !~ $re_nam; $sav = $slf->{'_sav'} unless defined($sav); # Collect the diagnostic data for the module $slf->{'_tmp'} = {}; require RDA::Block; $obj = RDA::Block->new($nam, $slf->{'dir'}, $slf); unless ($ret = $obj->load) { # Execute the setup when not yet done $slf->setup($nam, $trc, $sav) unless $flg || $slf->is_configured($nam); # Delete previous reports $slf->del_reports($nam) if $slf->is_done($nam); # Reset the module statistics $slf->set_current($nam); unless ($flg) { foreach my $cls (@{$slf->{'_sta'}}) { $cls->clr_stats($nam); } } # Perform the data collection eval { local $SIG{'INT'} = sub { local $SIG{'__WARN__'} = sub {}; die ("RDA-00206: RDA data collection interrupted\n"); }; $ret = $obj->collect($dbg, $trc); }; $slf->log('C', $nam, $obj->get_version, $ret); # Collect the module statistics unless ($flg) { foreach my $cls (@{$slf->{'_sta'}}) { $cls->get_stats($nam); } } } # Indicate that the data collection has been done unless ($flg || $ret) { $sta = $slf->get_setting("STATUS_$nam", 'done'); $slf->{'_col'}->{$nam} = exists($tb_col{$sta}) ? $tb_col{$sta} : 2; } # Delete the temporary settings created by the module foreach my $key (keys(%{$slf->{'_tmp'}})) { $slf->clr_temp_setting($key); } # When requested, save the setup file $slf->save if $sav; # Return the module completion status $ret; } =head2 S<$h-Edel_reports($nam)> This method deletes the table of contents file and all reports that are associated with the specified module. The collection status is reset also. =cut sub del_reports { my ($slf, $nam) = @_; my ($dir, $fil, $grp, $re1, $re2, $re3); # Scan the output directory to remove reports if ($nam =~ $re_nam) { $grp = $slf->get_setting('RPT_GROUP'); $re1 = qr/^$grp\_$2\_.*\.(dat|htm|txt)$/i; $re2 = qr/^$grp\_$nam(_\d+)?\.(dat|htm|toc|txt)$/i; $re3 = qr/^$grp\_0$2\.fil$/i; if (opendir(DIR, $dir = $slf->get_setting('RPT_DIRECTORY'))) { while (defined($fil = readdir(DIR))) { next unless $fil =~ $re1 || $fil =~ $re2 || $fil =~ $re3; $fil = File::Spec->catfile($dir, $fil); 1 while unlink($fil); } closedir(DIR); } # Remove statistics foreach my $key ("LAST_RUN_$nam", $slf->grep_setting("^(OS|SQL|XML)_STAT_$nam\_")) { $slf->del_setting($key); } # Adjust the data collection status $slf->{'_col'}->{$nam} = 0 if $slf->is_done($nam); } } =head2 S<$h-Eget_block($nam)> This method returns a reference to a previously saved block. It returns C if there is no block saved under the specified name. =cut sub get_block { my ($slf, $nam) = @_; exists($slf->{'_run'}->{$nam}) ? $slf->{'_run'}->{$nam} : undef; } =head2 S<$h-Eget_modules> This method returns the list of existing data collection modules in alphabetical order. It is based on files with names similar to C that are present in the module directory. =cut sub get_modules { my ($slf) = @_; my @tbl; if (opendir(DIR, $slf->{'dir'})) { @tbl = grep {$_ =~ $re_mod} readdir(DIR); closedir(DIR); } @tbl = map {uc($_)} @tbl unless $slf->get_setting('RDA_CASE'); sort @tbl; } =head2 S<$h-Eget_tools> This method returns the list of existing test/tools modules in alphabetical order. It is based on files with names similar to C or C that are present in the module directory. =cut sub get_tools { my ($slf) = @_; my @tbl; if (opendir(DIR, $slf->{'dir'})) { @tbl = grep {$_ =~ $re_tst} readdir(DIR); closedir(DIR); } @tbl = map {uc($_)} @tbl unless $slf->get_setting('RDA_CASE'); sort @tbl; } =head2 S<$h-Eis_collected($name)> This method indicates whether the data collection step is complete for the specified module (that is, it displays whether diagnostic information must be collected or if it can be skipped). =cut sub is_collected { my ($slf, $nam) = @_; exists($slf->{'_col'}->{$nam}) && $slf->{'_col'}->{$nam}; } =head2 S<$h-Eis_defined($name)> This method indicates when the specified module exists (that is, when the corresponding data collection specification file exists). =cut sub is_defined { my ($slf, $nam) = @_; -r File::Spec->catfile($slf->{'dir'}, "$nam.def") || -r File::Spec->catfile($slf->{'dir'}, "$nam.ctl"); } =head2 S<$h-Eis_described($name)> This method indicates whether the module description is available. =cut sub is_described { my ($slf, $nam) = @_; exists($slf->{'_dsc'}->{$nam}); } =head2 S<$h-Eis_disabled($name)> This method indicates whether data collection should be skipped for the specified module. =cut sub is_disabled { my ($slf, $nam) = @_; exists($slf->{'_col'}->{$nam}) && $slf->{'_col'}->{$nam} == 1; } =head2 S<$h-Eis_done($name)> This method indicates whether diagnostic information has been collected effectively for the specified module. =cut sub is_done { my ($slf, $nam) = @_; exists($slf->{'_col'}->{$nam}) && $slf->{'_col'}->{$nam} == 2; } =head2 S<$h-Ekeep_block($nam,$blk)> This method stores a block reference for further reuse. =cut sub keep_block { my ($slf, $nam, $blk) = @_; $slf->{'_run'}->{$nam} = $blk; } =head2 S<$h-Eset_collection($nam,$status)> This method sets the data collection status of the specified module name. =cut sub set_collection { my ($slf, $nam, $sta) = @_; if ($nam =~ $re_nam) { $slf->{'_col'}->{$nam} = $sta; } } =head1 OTHER MANAGEMENT METHODS =head2 S<$h-Edaemon> This method creates the daemon object and returns a reference to it. =cut sub daemon { my $slf = shift; require RDA::Daemon; RDA::Daemon->new($slf); } =head2 S<$h-Eexplain($err)> This method returns the explanation of an error number as a line list. When the error is not found in the error file, it returns an empty list. =cut sub explain { my ($slf, $err) = @_; my ($fil, $grp, $typ, @buf); # Determine the error file name $typ = 'RDA'; ($typ, $err) = ($1, $2) if $err =~ m/^([A-Z]+)-(\d+)$/i; if (($grp = int($err / 100)) < 100) { return @buf unless exists($tb_err{$typ}); $fil = $tb_err{$typ}; } elsif (opendir(DIR, $slf->{'dir'})) { $grp = sprintf("S%03d", $grp); ($fil) = grep {m/^$grp.*\.txt$/i} readdir(DIR); closedir(DIR); } # Get the error explanation if ($fil && open(ERR, '<'.File::Spec->catfile($slf->{'dir'}, $fil))) { while () { s/[\s\r\n]+//; if (m/^(\d+),\d+,\s*"([^"]*)"/ && $err == $1) { push (@buf, "$typ-$1: $2"); while () { s/[\s\r\n]+$//; last unless s#^//\s## && m#\S#; push (@buf, $_) unless m/^\*Mnemonic/; } last; } } close(ERR); } # Return the lines found @buf; } =head2 S<$h-Elog($typ[,$arg...])> This method logs an event in the event log. =cut sub log { shift->{'_log'}->log(@_); } =head2 S<$h-Elog_force> This method forces the creation of the log file. =cut sub log_force { my $slf = shift; $slf->{'_log'}->init($slf->get_setting('RPT_DIRECTORY'), 1); } =head2 S<$h-Elog_resume> This method reopens the log file and restarts event logging. =cut sub log_resume { shift->{'_log'}->resume; } =head2 S<$h-Elog_suspend> This method suspends event logging and closes the log file. =cut sub log_suspend { shift->{'_log'}->suspend; } =head2 S<$h-Elog_timeout($blk,$typ[,$arg...])> This method logs a timeout event in the event log. =cut sub log_timeout { my $slf = shift; my $top = shift->get_top; my $typ = shift; my ($ctl, $mod, $rpt, @tbl); $mod = $top->{'_nam'}; $rpt = exists($top->{'_out'}) ? $top->{'_out'}->get_report : '-'; exists($slf->{'_out'}) ? $slf->{'_log'}->log('t', $mod, $rpt, $typ, map {$slf->{'_out'}->filter($_)} @_) : $slf->{'_log'}->log('t', $mod, $rpt, $typ, @_); } =head2 S<$h-Elogfile> This method returns the filehandle that is associated with the event log. When this is not possible, it returns C. =cut sub logfile { shift->{'_log'}->logfile; } =head2 S<$h-Eoutput> This method creates the object to control the output and returns a reference to it. =cut sub output { my $slf = shift; # When already allocated, return its reference return $slf->{'_out'}->reset if exists($slf->{'_out'}); # When not yet done, create it require RDA::Output; $slf->{'_out'} = RDA::Output->new($slf); } =head2 S<$h-Epod> This method creates the object to display the manual page and returns a reference to it. =cut sub pod { my $slf = shift; require RDA::Pod; RDA::Pod->new($slf->{'dir'}, $slf); } =head2 S<$h-Eprofile> This method creates the object to manage the profiles and returns a reference to it. =cut sub profile { my $slf = shift; # When already allocated, return its reference return $slf->{'_prf'} if ref($slf->{'_prf'}); # When not yet done, define the profile environment require RDA::Profile; $slf->{'_prf'} = RDA::Profile->new($slf->{'dir'}, $slf); } =head2 S<$h-Erender> This method creates the render object and returns a reference to it. =cut sub render { my ($slf, $rul) = @_; # When already allocated, return its reference return $slf->{'_rnd'} if ref($slf->{'_rnd'}); # When not yet done, define the reporting environment $slf->set_temp_setting('RPT_GROUP', 'RDA') unless $slf->get_setting('RPT_GROUP'); $slf->set_temp_setting('RPT_DIRECTORY', File::Spec->catfile($slf->{'ctl'}, 'output')) unless $slf->get_setting('RPT_DIRECTORY'); # Create the render object require RDA::Render; my $obj = RDA::Render->new($slf->{'dir'}, $slf, $rul); $slf->{'_rnd'} = $obj if $rul; $obj; } =head1 MACROS =head2 S This macro requests a password, using the specified text as the prompt. =cut sub _m_ask_password { my ($slf, $ctx, $txt) = @_; $slf->ask_password($txt); } =head2 S This macro displays text. The text can contain variables that are resolved through the specified hash. When the variable is not defined in the hash, settings are used. When the flag is set, a user acknowledgement is requested before continuing. =cut sub _m_dsp_text { my $slf = shift; my $ctx = shift; $slf->dsp_text(@_) unless ref($slf->{'_rnd'}); } =head2 S This macro returns the explanation lines for the specified error. =cut sub _m_explain { my ($slf, $ctx, $err) = @_; $slf->explain($err); } =head2 S This macro returns a list containing the value, description, and type of the specified setting. The value is adjusted according to the type. It returns an empty list if the setting is not defined. =cut sub _m_get_desc { my ($slf, $ctx, $key) = @_; my ($typ, $val); return () unless exists($slf->{'_def'}->{$key}); $typ = $slf->{'_def'}->{$key}->[0]; $val = $slf->{'_set'}->{$key}; $val = $val ? 'Yes' : 'No' if $typ eq 'B'; ($val, $slf->{'_def'}->{$key}->[1], $typ); } =head2 S This macro returns the process number of the Perl process running this script. =cut sub _m_get_pid { $$; } =head2 S This macro returns the current value of a setup attribute. It returns the default value when the attribute does not exist. When the flag is set, references to other settings are resolved in the value. =cut sub _m_get_setting { my ($slf, $ctx, $key, $dft, $flg) = @_; $slf->get_setting($key, $dft, $flg); } =head2 S This macro returns the setting names that match the regular expression. It supports the same options as the C method. =cut sub _m_grep_setting { my ($slf, $ctx, $re, $opt) = @_; $slf->grep_setting($re, $opt); } =head2 S This macro adds an event to the event log. The event type must be composed of two or more alphanumerical characters. Otherwise, the request is ignored. =cut sub _m_log { my $slf = shift; my $ctx = shift; my $typ = shift; $slf->log($typ, @_) if $typ && $typ =~ m/^\w{2,}$/; } =head2 S This macro requests additional settings using the named setup specifications. The current setting level applies. It returns 1 when the setup is performed. Otherwise, it returns 0. =cut sub _m_req_setting { my ($slf, $ctx, $nam) = @_; my ($obj); $nam =~ s/\.cfg$//i; require RDA::Module; $obj = RDA::Module->new($nam, $slf->{'dir'}, $slf); if ($obj->load) { $obj->request($slf, $slf->get_setting('RDA_LEVEL'), $ctx->chk_trace(1), $slf->{'yes'}); return 1; } 0; } =head2 S This macro specifies a value for a setup attribute. If the value is undefined, then it removes the setup attribute. Also you can specify the type and description for a new setting. This macro adds new settings to the current module automatically. It returns the previous value, or an undefined value if it is not previously defined. =cut sub _m_set_setting { my ($slf, $ctx, $key, $val, $typ, $dsc) = @_; if (defined($key)) { if (defined($val)) { die "RDA-00102: Invalid character in setting value\n" if $val =~ m/(&\#\d+;|\n|\r)/; $val = $slf->set_setting($key, $val, $typ, $dsc); } else { $val = $slf->del_setting($key); } } $val; } =head2 S This macro specifies a temporary value for a setup attribute. If the value is undefined, then the original value is restored. It returns the previous value or an undefined value if it is not defined previously. =cut sub _m_temp_setting { my ($slf, $ctx, $key, $val) = @_; if (defined($key)) { if (defined($val)) { die "RDA-00102: Invalid character in setting value\n" if $val =~ m/(&\#\d+;|\n|\r)/; $val = $slf->set_temp_setting($key, $val); } else { $val = $slf->clr_temp_setting($key); } } $val; } 1; __END__ =head1 SEE ALSO See also L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L. =head1 COPYRIGHT NOTICE Copyright (c) 2002-2008, 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