# Module.pm: Class Used for Objects to Setup Modules package RDA::SDSL::Module; # $Id: Module.pm,v 1.24 2015/07/23 23:36:11 RDA Exp $ # ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/SDSL/Module.pm,v 1.24 2015/07/23 23:36:11 RDA Exp $ # # Change History # 20150717 MSC Change handle. =head1 NAME RDA::SDSL::Module - Class Used for Objects to Setup Modules =head1 SYNOPSIS require RDA::SDSL::Module; =head1 DESCRIPTION The objects of the C class are used to manage module setup. The following methods are available: =cut use strict; BEGIN { use Exporter; use IO::File; use RDA::Text qw(debug get_string); use RDA::Agent qw($INTERRUPT); use RDA::Error; use RDA::Handle::Vector; use RDA::Object; use RDA::Object::Content qw($RE_DC); use RDA::Object::Message; use RDA::Object::Rda; use RDA::SDCL::Block qw($CONT $RET_RET $SPC_REF $SPC_VAL); use RDA::SDSL::Setting; use RDA::Value::Scalar qw(:value); } # Define the global public variables use vars qw($STRINGS $VERSION @DUMP @EXPORT_OK @ISA); $VERSION = sprintf('%d.%02d', q$Revision: 1.24 $ =~ /(\d+)\.(\d+)/); @DUMP = ( hsh => { 'RDA::SDSL::Setting' => 1, }, ); @EXPORT_OK = qw(declare); @ISA = qw(RDA::Error Exporter); # Define the global private constants my $MRC = 'RDA::Object::Mrc'; my $DFT_CFM = 2; my $RPT_NXT = ".N1\n"; my $RPT_SUB = " \001 "; my $RPT_TXT = q{ }; my $RPT_XRF = q{ }; # Define the global private variables my @tb_cls = qw(RDA::Object::Collect RDA::Object::Content RDA::Object::Env RDA::Object::Item RDA::Object::Rda RDA::Object::Target RDA::Object::View RDA::Object::Windows ); my %tb_alt = ( 'end' => 'brk', ); my %tb_aux = ( B_ISOLATED => [-1, 'yes'], B_SELECTED => [-1, 'sel'], K_CONTEXT => [-1, 'ctx'], M_MODULE => [-1, 'oid'], M_PACKAGE => [-1, 'oid'], N_DEPTH => [-1, 'dpt'], W_PREFIX => [-1, 'abr'], W_NEXT => [ 1, '_nxt'], ); my %tb_cmd = ( 'require' => [\&_exe_require, \&_get_require, 0, 0], ); my %tb_cur = ( D_DATA => sub {return shift->{'col'}->get_data}, D_DIRECTORY => sub {return shift->get_dir}, K_CONTEXT => sub {return shift->{'ctx'}}, K_GROUP => sub {my ($slf) = @_; return $slf->{'col'}->get_info('set')->find( $slf->{'_grp'}, 1)->get_path}, K_MODULE => sub {return shift->{'def'}->get_path}, K_NAME => sub {return shift->{'nam'}}, M_MODULE => sub {return shift->{'oid'}}, N_DEPTH => sub {return shift->{'dpt'}}, # ( N_EGID => sub {return (split(/ /, $)))[0]}, N_EUID => sub {return $>}, N_GID => sub {return (split(/ /, $())[0]}, # ) N_LEVEL => sub {return shift->{'col'}->get_degree}, N_UID => sub {return $<}, W_COLLECTOR => sub {return shift->{'col'}->get_oid}, W_GROUP => sub {return shift->{'_grp'}}, W_MODULE => sub {return shift->{'def'}->get_oid}, ); my %tb_dsc = ( B_DFT => 'Default collection indicator', B_FRK => 'Parallel execution indicator', B_MRC => 'Multi-run collection indicator', G_CFG => 'Module setup date/time', G_RUN => 'Last collection date/time', I_TGT => 'Default collection target', M_NAM => 'Module name', M_TRG => 'Modules to trigger', N_CFM => 'Customer file management level', N_SEC => 'Execution time limit', R_CFG => 'Setup sequence', R_MIB => 'Report space limit', R_RUN => 'Collect sequence', S_CFG => 'Module setup status', S_RUN => 'Last collection status', T_DSC => 'Module description', W_ABR => 'Associated abbreviation', W_RPT => 'Settings to report', ); my %tb_fmt = ( C => \&_fmt_val_comma, D => \&_fmt_val_dot, F => \&_fmt_val_first, L => \&_fmt_val_last, N => \&_fmt_val_none, P => \&_fmt_val_pipe, Q => \&_fmt_val_quote, S => \&_fmt_val_space, T => \&_fmt_val_text, ); my %tb_grp = ( AS => [1, 'V', 'F', \&_get_var_as], CFG => [1, 'V', 'F', \&_get_var_cfg], CNT => [1, 'V', 'F', \&_get_var_cnt], COL => [1, 'CDELMPTVlptv', 'CDFLNPQST', \&_get_var_col], CTX => [1, 'CDELMPTVlptv', 'CDFLNPQST', \&_get_var_ctx], CUR => [1, 'V', 'F', \&_get_var_cur], DFT => [1, 'CDELMPTVlptv', 'CDFLNPQST', \&_get_var_dft], ENV => [RDA::Object::Rda->is_windows ? 1 : 0, 'V', 'F', \&_get_var_env], GRP => [1, 'CDELMPTVlptv', 'CDFLNPQST', \&_get_var_grp], INC => [1, 'V', 'F', \&_get_var_inc], MOD => [1, 'CDELMPTVlptv', 'CDFLNPQST', \&_get_var_mod], NXT => [1, 'V', 'F', \&_get_var_nxt], OS => [1, 'V', 'F', \&_get_var_os], OUT => [1, 'V', 'F', \&_get_var_out], PRF => [1, 'V', 'F', \&_get_var_prf], RDA => [1, 'V', 'F', \&_get_var_rda], REG => [1, 'V', 'F', \&_get_var_reg], RUN => [1, 'CDELMPTVlptv', 'CDFLNPQST', \&_get_var_run], SET => [1, 'CDELMPTVlptv', 'CDFLNPQST', \&_get_var_set], STA => [1, 'CDELMPTVlptv', 'CDFLNPQST', \&_get_var_sta], SYS => [RDA::Object::Rda->is_windows ? 1 : 0, 'V', 'F', \&_get_var_sys], q{-} => [1, 'CDELMPTVlptv', 'CDFLNPQST', \&_get_var_mod], ); my %tb_lng = ( sdcl => \&_end_sdcl, ); my %tb_mod = ( 'cfm' => \&_parse_number, 'col' => \&_parse_number, 'def' => \&_parse_string, 'dft' => \&_parse_value, 'dsc' => \&_parse_string, 'fam' => \&_parse_words, 'frk' => \&_parse_value, 'lim' => \&_parse_value, 'man' => \&_parse_string, 'mrc' => \&_parse_value, 'obj' => \&_parse_objects, 'pre' => \&_parse_list, 'req' => \&_parse_list, 'rpt' => \&_parse_words, 'tgt' => \&_parse_value, 'trg' => \&_parse_list, 'use' => \&_parse_classes, 'var' => \&_parse_words, ); my %tb_num = ( false => 0, true => 1, ); my %tb_sta = ( '_cfm' => 'N_CFM', '_dft' => 'B_DFT', '_frk' => 'B_FRK', '_lst' => 'M_TRG', '_mrc' => 'B_MRC', '_rpt' => 'W_RPT', '_spc' => 'R_MIB', '_tgt' => 'I_TGT', '_tim' => 'N_SEC', ); my %tb_var = ( 'add' => \&_parse_value, 'aft' => \&_parse_text, 'alt' => \&_parse_words, 'ask' => \&_parse_number, 'bef' => \&_parse_text, 'cas' => \&_parse_number, 'clr' => \&_parse_text, 'cls' => \&_parse_text, 'col' => \&_parse_number, 'ctx' => \&_parse_value, 'def' => \&_parse_text, 'del' => \&_parse_text, 'dft' => \&_parse_text, 'dsc' => \&_parse_text, 'dup' => \&_parse_text, 'end' => \&_parse_text, 'err' => \&_parse_text, 'fam' => \&_parse_words, 'fmt' => \&_parse_string, 'hlp' => \&_parse_text, 'inp' => \&_parse_text, 'itm' => \&_parse_text, 'lvl' => \&_parse_number, 'key' => \&_parse_text, 'man' => \&_parse_string, 'mnu' => \&_parse_text, 'nam' => \&_parse_name, 'one' => \&_parse_text, 'opt' => \&_parse_number, 'par' => \&_parse_text, 'pck' => \&_parse_number, 'raw' => \&_parse_number, 'ref' => \&_parse_text, 'rsp' => \&_parse_text, 'syn' => \&_parse_text, 'typ' => \&_parse_type, 'val' => \&_parse_validation, 'var' => \&_parse_next, 'vis' => \&_parse_number, ); # Report the package version sub Version { return $VERSION; } =head2 S<$h = RDA::SDSL::Module-Enew($lang,$group,$name)> The object constructor. It takes the language descriptor, the module group and name as arguments. C is represented by a blessed hash reference. The following special keys are used: =over 12 =item S< B<'abr' > > Module abbreviation =item S< B<'agt' > > Reference to the agent object =item S< B<'cfg' > > Reference to the RDA software configuration =item S< B<'col' > > Reference to the collector object =item S< B<'def' > > Reference to the module definition =item S< B<'dir' > > Module directory =item S< B<'dpt' > > Current setup depth =item S< B<'err' > > Error buffer =item S< B<'grp' > > Group restrictions =item S< B<'lng' > > Reference to the language object =item S< B<'lvl' > > Trace level =item S< B<'mrc' > > Reference to the multi-run collection control object =item S< B<'nam' > > Module definition name =item S< B<'oid' > > Object identifier =item S< B<'pre' > > Trace prefix =item S< B<'reg' > > Reference to an object for accessing registry =item S< B<'sel' > > Explicit selection indicator =item S< B<'shr' > > Shared class hash =item S< B<'tie' > > Tied hashes =item S< B<'ver' > > Specification version number =item S< B<'xml' > > XML file hash =item S< B<'yes' > > Dialogue suppression indicator =item S< B<'_all'> > Setting object list =item S< B<'_aux'> > Auxiliary properties =item S< B<'_bkp'> > Attribute backup hash =item S< B<'_cfm'> > Customer file management level =item S< B<'_col'> > Indicates whether the data collection should be done =item S< B<'_cur'> > Current setup object reference =item S< B<'_dft'> > Indicates whether the module must be selected by default =item S< B<'_dsc'> > Description string =item S< B<'_err'> > Number of load errors =item S< B<'_evt'> > Pending events stack =item S< B<'_exe'> > Associated package =item S< B<'_fam'> > Optional list of operating system families =item S< B<'_fct'> > Function hash =item S< B<'_frk'> > Parallel collection indicator =item S< B<'_grp'> > Module group =item S< B<'_lim'> > Indicates whether execution limits are allowed =item S< B<'_lin'> > Line number =item S< B<'_lst'> > List of the modules to trigger =item S< B<'_man'> > Module manual text =item S< B<'_mrc'> > Multi-run collection indicator =item S< B<'_nam'> > Package name =item S< B<'_nxt'> > List of next settings =item S< B<'_obj'> > List of related objects =item S< B<'_pkg'> > Reference to the associated SDCL package =item S< B<'_pre'> > List of prerequisite modules =item S< B<'_req'> > List of required modules =item S< B<'_rpt'> > List of settings to include in setting report =item S< B<'_set'> > Setting definition hash =item S< B<'_spc'> > Space limit =item S< B<'_src'> > SDCL package source =item S< B<'_tbl'> > Current attribute table =item S< B<'_tgt'> > Default collection target =item S< B<'_tim'> > Time limit =item S< B<'_trg'> > Trigger rule =item S< B<'_var'> > Setting array =item S< B<'_xrf'> > Value hash =back The following keys are used to store SDCL expressions: =over 12 =item S< B<'-cfm'> > Customer file management level =item S< B<'-col'> > Collection indicator =item S< B<'-dft'> > Default module indicator =item S< B<'-frk'> > Parallel collection indicator =item S< B<'-ini'> > Library reload indicator =item S< B<'-lim'> > Execution limits indicator =item S< B<'-mrc'> > Multi-run collection indicator =item S< B<'-tgt'> > Default collection target =back Internal keys are prefixed by an underscore or a dash. =cut sub new { my ($cls, $lng, $grp, $nam) = @_; my ($agt, $col, $slf); # Create the module definition object $nam = '_sdsl_' unless defined($nam); $agt = $lng->get_agent; $col = $agt->get_collector; $slf = bless { agt => $agt, cfg => $lng->get_config, col => $col, dpt => 0, err => [], lng => $lng, lvl => $lng->get_level % 10, prv => {}, sel => 0, set => {}, tie => {}, ver => q{?}, xml => {}, yes => $col->is_isolated, _aux => {}, _bkp => {}, _cfm => $DFT_CFM, _col => 1, _dsc => $nam, _env => [], _exe => [\&_exe_sdcl, 'init'], _fct => {}, _grp => $grp, _lim => 1, _nam => $nam, _obj => [], _pre => [], _req => [], _var => [], }, ref($cls) || $cls; # Add data collection module attributes if (defined($grp)) { $slf->{'grp'} = ($grp eq 'RDA') ? [$grp] : [$grp, 'RDA']; $slf->{'oid'} = $grp.q{:}.$nam; if ($nam =~ $RE_DC) { $slf->{'abr'} = uc($grp.q{_}.$3.q{_}); $slf->{'nam'} = uc($grp.q{.}.$3); $slf->{'ctx'} = 'SETUP.'.$slf->{'nam'}; } } else { $slf->{'grp'} = ['RDA']; $slf->{'oid'} = $nam; } # Return the object reference return $slf; } =head2 S This method collects the setup information for the module. =cut sub declare { my ($col, $grp, $pth, $abr) = @_; my ($agt, $dsc, $ifh, $lin, $nam, $nxt, $slf, $seq, $sta); # Abort when not a data collection module $col->get_agent->abort(get_string('BAD_MODULE', $pth)) unless defined($abr); # Extract the sequence, the description, and the name ($seq, $dsc) = RDA::Object::Content->get_sequence($pth); $nam = RDA::Object::Rda->basename($pth); $nam =~ s/\.\w+$//; # Create the module description $slf = { abr => uc($grp.q{_}.$abr.q{_}), col => $col, dir => RDA::Object::Rda->dirname($pth), grp => $grp, nam => uc($grp.q{.}.$abr), oid => $grp.q{:}.$nam, _dsc => defined($dsc) ? $dsc : $nam, _req => [], }; # Display the module title _display($col, qq{.S\n.P1\n}.$slf->{'nam'}.q{: }.get_desc($slf).qq{\n\n.S\n}) unless $col->is_isolated; # Update the status information _set_status($slf, $sta, 1) if ($sta = $col->get_info('sta')); # Return the module name return $slf->{'oid'}; } =head2 S<$h-Edelete_object> This method deletes an object and all subobjects, thus handling circular references. =cut sub delete_object ## no critic (Unpack) { RDA::Object::dump_caller($_[0], 'MODULE') if $RDA::Object::DELETE; # Delete the associated logic $_[0]->{'_pkg'}->delete_object if exists($_[0]->{'_pkg'}); # Delete settings if (exists($_[0]->{'_all'})) { foreach my $obj (@{$_[0]->{'_all'}}) { $obj->delete_object; } } # Remove references to other objects and next delete the object undef %{$_[0]}; undef $_[0]; return; } =head2 S<$h-Edisplay($level[,$all])> This method extracts the setup questions of a module. When the second argument is set, it disables family restrictions. =cut sub display { my ($slf, $lvl, $all, $flg) = @_; my ($buf, $grp, $lng, $mod, @dep, %dep); $lvl = 0 unless defined($lvl); # Display the module section $buf = _dsp_title(get_string('TtlName')) ._dsp_text($RPT_TXT, q{``}.$slf->{'oid'}.q{`` - }.$slf->get_desc, 1); $buf .= _dsp_title(get_string('TtlSetup')) ._dsp_block($RPT_TXT, $slf->{'_man'}, 1) if exists($slf->{'_man'}); # Display the setting section if (exists($slf->{'_all'})) { my ($cnt, $fam, @rec); $cnt = 0; $fam = $slf->{'cfg'}->get_family; foreach my $obj (@{$slf->{'_all'}}) { # Determine if the setting contributes to the report next unless $all || $obj->is_valid($fam); @rec = $obj->get_detail; next unless @rec && $lvl >= $rec[1]; ## no critic (Unless) # Provide the setting details $buf .= _dsp_title(get_string('TtlSettings')) unless $cnt++; $buf .= _dsp_text($RPT_TXT, q{``}.$rec[0].q{``}); $buf .= _dsp_text($RPT_SUB, $rec[2]) if defined($rec[2]); $buf .= _dsp_text($RPT_SUB, $rec[3]) if defined($rec[3]); $buf .= $RPT_NXT; } } # Display the dependencies $lng = $slf->{'lng'}; $grp = $slf->{'grp'}; foreach my $dep (@{$slf->{'_pre'}}, map {m/^(?:\?\!?\w+\:|[\+\-]+)?(.*)$/ ? $1 : $_} @{$slf->{'_req'}}) { if (defined($mod = $lng->norm_package($grp, $dep))) { $dep{$mod} = qq{!!setup:$mod!$mod!!}; } else { $dep{$dep} = $dep; } } $buf .= _dsp_title(get_string('TtlDependencies'))._dsp_text($RPT_TXT, join(q{, }, map {$dep{$_}} sort @dep), 1) if (@dep = keys(%dep)); # Display the copyright and trademark notices $buf .= _dsp_title(get_string('TtlCopyright')) ._dsp_text($RPT_TXT, get_string('Copyright'), 1) ._dsp_title(get_string('TtlTrademark')) ._dsp_text($RPT_TXT, get_string('Trademark')) unless $flg; # Return the result return $buf; } =head2 S<$h-Eeval_value($expr,$last)> This method evaluates the SDCL expression and returns its result as scalar. =cut sub eval_value { my ($slf, $obj, $val) = @_; my ($err, $rec, $ret, $trc); # Evaluate the SDCL expression as a scalar eval { $slf->{'_pkg'}->get_context->set_internal('val', RDA::Value::Scalar::new_text($val)); $ret = $obj->eval_as_scalar; }; # Report the error when the trace is enabled $rec = $slf->add_error($@)->pop_error; if (($trc = $slf->{'pre'}) && defined($err = $rec->[0])) { $err =~ s/:$//; $rec->[0] = get_string('Validation', $err); debug(join(qq{\n}, $trc, $slf->format_error($rec, -1, q{ }))); } # Return the result value return $ret; } =head2 S<$h-Efind($name)> This method returns a reference to the specified item object from the context or a result set definition. =cut sub find { my ($slf, $nam) = @_; return $slf->{'agt'}->get_item($1)->find($2, 1) if $nam =~ m/^(\w+)\/(.*)$/; return exists($slf->{'ctx'}) ? $slf->{'col'}->find($slf->{'ctx'}.q{.}.$1, 1) : $slf->{'def'}->find($1, 1) if $nam =~ m/^\^\/(.*)$/; return $slf->{'def'}->find($1, 1) if $nam =~ m/^\.\/(.*)$/; return $slf->{'col'}->get_info('set')->find($nam, 1); } =head2 S<$h-Eget_definition([$name])> This method determines the setting definition and aligns the associate logic to it. =cut sub get_definition { my ($slf, $nam) = @_; my ($def); $def = (defined($nam) && length($nam)) ? $slf->find($nam) : $slf->{'def'}; $slf->{'_pkg'}->set_info('def', $def); return $def; } =head2 S<$h-Eget_desc> This method returns the module description. =cut sub get_desc { return shift->{'_dsc'}; } =head2 S<$h-Eget_dir> It returns the directory containing the package specifications. =cut sub get_dir { my ($slf) = @_; return exists($slf->{'dir'}) ? $slf->{'dir'} : $slf->{'cfg'}->get_dir('D_RDA_COL', $slf->{'grp'}->[0]); } =head2 S<$h-Eget_pre> This method returns the list of prerequisites. =cut sub get_pre { return @{shift->{'_pre'}}; } =head2 S<$h-Eget_tie($definition,$name[,$raw])> This method returns the hash reference associated to the specified property. =cut sub get_tie { my ($slf, $def, $nam, $raw) = @_; my ($val); # Check if the property value is already tied if (exists($slf->{'tie'}->{$nam})) { foreach my $rec (@{$slf->{'tie'}->{$nam}}) { return $rec->[1] if $rec->[0] == $def; } } # Tie the property value push(@{$slf->{'tie'}->{$nam}}, [$def, $val = $def->tie_value($nam, {}, $raw)]); # Return the value return $val; } =head2 S<$h-Eget_version> This method returns the version number of the specifications. =cut sub get_version { return shift->{'ver'}; } =head2 S<$h-Eis_isolated> This method indicates whether customer interactions are disabled. =cut sub is_isolated { return shift->{'yes'}; } =head2 S<$h-Eis_valid($family)> This method indicates whether the module is applicable for the specified operating system family. =cut sub is_valid { my ($slf, $fam) = @_; # Check the family when there are no parsing errors unless ($slf->{'_err'}) { # Accept it directly if there is no restriction return 1 unless exists($slf->{'_fam'}); # Check if the family is included in the list for (@{$slf->{'_fam'}}) { return 1 if $_ eq $fam; } } # Otherwise, reject it return 0; } =head2 S<$h-Eisolate> This method disables customer interactions. =cut sub isolate { return shift->{'yes'} = 1; } =head2 S<$h-Eparse($ifh)> This method parses the SDSL code from the specified input handle. It closes the file handle at the end of parsing. It stores the errors in the request object. It returns the object reference. =cut sub parse ## no critic (Complex) { my ($slf, $ifh, $flg) = @_; my ($blk, $buf, $err, $lin, $nam, $obj, $pkg, $pth, $tbl, $xrf); # Load and parse the code $slf->{'_lin'} = 0; $slf->{'_xrf'} = $xrf = []; if ($ifh) { # Initialize the associated package and the operators $obj = $slf->{'agt'}->get_lang('SDCL'); $obj->get_operators; $slf->{'_src'} = [0, ['section init']]; $slf->{'_pkg'} = $pkg = RDA::SDCL::Block->new($obj, $slf->{'_grp'}, $slf->{'_nam'}); foreach my $cls (@tb_cls) { $pkg->load_class($cls, 2, $cls); } $tbl = $pkg->get_info('cmd'); foreach my $cmd (keys(%tb_cmd)) { $tbl->{$cmd} = $tb_cmd{$cmd}; } $pkg = $pkg->new('S',q{.}); # Treat all lines $blk = undef; $lin = q{}; $obj = $slf; $tbl = \%tb_mod; while (defined($buf = $ifh->getline)) { # Trim leading spaces $slf->{'_lin'}++; $buf =~ s/[\r\n]+$//; # Treat inline code if ($blk) { if ($buf =~ m/^\175(\s*\#.*)?$/) { # Complete the attribute definition $obj->{'_exe'} = $flg ? $blk->[1] : &{$blk->[0]}($slf, $blk); $blk = undef; } else { # Take all lines without other processing $buf =~ s/^\s*"?//; push(@{$blk->[1]}, $buf); } next; } # Join continuation line $buf =~ s/^\s+//; $lin .= $buf; next if $lin =~ s/\\$//; $lin =~ s/\s+$//; # Parse the line eval { if ($lin =~ s/^exe\s*=\s*//) { # Treat an associate logic die get_string('BAD_CODE') unless $lin =~ s/^([a-z]+)\s*(\d+(\.\d+)*)?\s*\173//; die get_string('BAD_LANG') unless exists($tb_lng{$1}); $blk = [$tb_lng{$1}, [], $slf->{'_lin'}, $2]; } elsif ($lin =~ s/^(\w+)\s*=\s*//) { # Treat a setting attribute $nam = lc($1); die get_string('BAD_KEY', $nam) unless exists($tbl->{$nam}); &{$tbl->{$nam}}($obj, $nam, \$lin, $pkg, $flg); die get_string('BAD_VALUE') unless $lin =~ m/^\s*(#.*)?$/; if ($lin =~ m/#.*Flow:(\w+(,\w+)*)/) { $slf->{'_dyn'} = [{}, []] unless exists($slf->{'_dyn'}); $slf->{'_dyn'}->[0]->{$nam} = [split(/,/, $1)]; } push(@{$xrf}, [$obj->{"-$nam"}, $slf->{'_lin'}]) if exists($obj->{"-$nam"}); } elsif ($lin =~ s/^\[(\w+)\]$//) { # Treat a setting definition $nam = $1; $slf->{'_set'}->{$nam} = $obj = RDA::SDSL::Setting->new($nam); $tbl = \%tb_var; push(@{$slf->{'_all'}}, $obj); } elsif ($lin !~ m/^(?:#.*)?$/) { die get_string('BAD_SPEC'); } elsif ($lin =~ m/\$[Ii]d\:\s+\S+\s+(\d+)(\.(\d+))?\s/) { # Extract the version $slf->{'ver'} = sprintf('%d.%02d', $1, $3 || 0); } }; # Report an error if ($@) { my $msg = $@; $msg =~ s/[\n\r\s]+$//; $msg = get_string('Error', $msg, $slf->{'_lin'}) if $slf->{'_lin'}; $slf->add_error($msg); } # Prepare the next line $lin = q{}; } $ifh->close; # Parse the associated logic $err = $flg ? 0 : $slf->{'agt'}->switch_context($slf, undef, \&_parse_logic, $slf); # Abort when there are errors $slf->{'agt'}->abort($slf->purge_errors, get_string('ERR_PARSE', $slf->{'_err'}, $slf->{'oid'})) if ($slf->{'_err'} = $err + $slf->has_errors); } # Return the object reference return $slf; } sub _parse_classes { my ($obj, $key, $buf, $pkg) = @_; for (;;) ## no critic (Loop) { if ($$buf =~ s/^(RDA::Object::[A-Z]\w+)\s*//i) { $pkg->{'_pkg'}->load_class($1, 1, $1); } elsif ($$buf =~ s/^([A-Z]\w+)\s*//i) { $pkg->{'_pkg'}->load_class($1, 1, "RDA::Object::$1"); } last unless $$buf =~ s/^,\s*//; } return; } sub _parse_list { my ($obj, $key, $buf) = @_; $$buf =~ s/\s*\#.*$//; $obj->{"_$key"} = [split(/\s*,\s*/, $$buf)]; $$buf = q{}; return; } sub _parse_logic { my ($slf) = @_; my ($pkg); eval { $pkg = $slf->{'_pkg'}; if (exists($slf->{'-mrc'})) { $pkg->load_class($MRC, 2, $MRC); $slf->{'mrc'} = $slf->{'col'}->get_mrc->new($slf->{'col'}); } $pkg->parse(RDA::Handle::Vector->new($slf->{'_src'}->[1]), []); }; return $@ ? (scalar @{$slf->get_errors->[-1]}) - 2 : 0; } sub _parse_name { my ($obj, $key, $buf, $pkg) = @_; if ($$buf =~ s/^(\-|[\-&]?\w+|[A-Z][A-Z\d]*\/(\w+\.)*\w+)\s*(\#.*)?$//) { $obj->{"_$key"} = $1; } else { $obj->{"-$key"} = $pkg->resolve_string($buf); } return; } sub _parse_next { my ($obj, $key, $buf) = @_; my ($rec, $str); $obj->{"_$key"} = $rec = [{}, []]; while ($$buf =~ s/^([^:]*?)\s*:\s*//) { $str = $1; $str =~ s/(\\[0-3][0-7]{2}|\\0x[0-9A-Fa-f]{2})/chr(oct(substr($1,1)))/eg; $rec->[0]->{$str} = ($$buf =~ s/^((\w+\s*,\s*)*\w+)\s*//) ? [split(/\s*,\s*/, $1)] : []; return unless $$buf =~ s/:\s*//; } push(@{$rec->[1]}, split(/\s*,\s*/, $1)) if $$buf =~ s/^((\w+\s*,\s*)*\w+)\s*//; return; } sub _parse_objects { my ($obj, $key, $buf) = @_; while ($$buf =~ s/^((COL|RUN)\/(\w+\.)*\w+)\s*//) { push(@{$obj->{"_$key"}}, $1); last unless $$buf =~ s/,\s*//; } return; } sub _parse_number { my ($obj, $key, $buf, $pkg) = @_; my ($val); if ($$buf =~ s/^(\d+)\s*//) { $obj->{"_$key"} = $1; } elsif ($$buf =~ s/^(false|true)\s*//) { $obj->{"_$key"} = $tb_num{$1}; } else { $obj->{"-$key"} = defined($val = $pkg->parse_value($buf)) ? $val : $VAL_UNDEF; } return; } sub _parse_string { my ($obj, $key, $buf) = @_; my ($str); if ($$buf =~ s/^'([^']*)'\s*//) { $str = $1; } elsif ($$buf =~ s/^"([^"]*)"\s*// || $$buf =~ s/(\`.*?\`)//) { $str = $1; $str =~ s/(\\[0-3][0-7]{2}|\\0x[0-9A-Fa-f]{2})/chr(oct(substr($1,1)))/eg; $str =~ s/\\n/\n/g; } else { $$buf =~ s/\s*\#.*$//; $str = $$buf; $$buf = q{}; } $obj->{"_$key"} = $str; return; } sub _parse_text { my ($obj, $key, $buf, $pkg, $flg) = @_; my $str; if ($$buf =~ s/^'([^']*)'//) { $obj->{"_$key"} = $1; } elsif ($$buf =~ s/^"([^"]*)"//) { $str = $1; if ($flg || $str =~ m/^<<[A-Za-z]+\d*:/ || $str !~ m/\$\173.*\175/) { $str =~ s/^<{"_$key"} = $str; } else { $obj->{"-$key"} = $pkg->resolve_string(\$str); } } elsif ($$buf =~ s/(\`.*?\`)//) { $str = $1; $str =~ s/(\\[0-3][0-7]{2}|\\0x[0-9A-Fa-f]{2})/chr(oct(substr($1,1)))/eg; $str =~ s/\\n/\n/g; } elsif ($flg) { $$buf =~ s/\s*\#.*$//; $obj->{"_$key"} = $$buf; $$buf = q{}; } else { $obj->{"-$key"} = defined($str = $pkg->parse_value($buf)) ? $str : $VAL_UNDEF; } return; } sub _parse_type { my ($obj, $key, $buf) = @_; die get_string('BAD_TYPE') unless $$buf =~ s/^([BCDEFILMNST])//; $obj->{"_$key"} = $1; return; } sub _parse_validation { my ($obj, $key, $buf) = @_; die get_string('BAD_RULE') unless $$buf =~ s/^(E\d*|[FW])//; $obj->{"_$key"} = $1; return; } sub _parse_value { my ($obj, $key, $buf, $pkg) = @_; my ($val); $obj->{"-$key"} = defined($val = $pkg->parse_value($buf)) ? $val : $VAL_UNDEF; return; } sub _parse_words { my ($obj, $key, $buf) = @_; die get_string('BAD_WORD') unless $$buf =~ s/^((\w+\s*,\s*)*\w+)\s*//; $obj->{"_$key"} = [split(/\s*,\s*/, $1)]; return; } =head2 S<$h-Elog($str)> This method adds an event to the event stack. =cut sub log ## no critic (Builtin) { my ($slf, $str) = @_; $slf->{'_evt'} = [] unless exists($slf->{'_evt'}); return push(@{$slf->{'_evt'}}, $str); } =head2 S<$h-Erequest($item[,$trace])> This method requests additional settings. The module context is unchanged and it preserves temporary settings. No requisites are considered. =cut sub request { my ($slf) = @_; return $slf->{'agt'}->switch_context($slf, get_string('ERR_SETUP', $slf->{'oid'}), \&_request, @_); } sub _request ## no critic (Complex) { my ($slf, $def, $trc) = @_; my ($blk, $dbg, $fam, $lng, $lvl, $nam, $pre, $ptr, $val, $var); # Check if the setup is relevant for the current OS family return unless $slf->is_valid($fam = $slf->{'cfg'}->get_family); # Get the request definition and reset module counters $trc = $slf->{'lvl'} unless defined($trc); $dbg = $trc > 1; $nam = $slf->{'oid'}; $lvl = $slf->{'col'}->get_degree; $slf->{'def'} = $def; if (exists($slf->{'_def'})) { $val = $slf->resolve_string($slf->{'_def'}); die get_string('BAD_DEFINITION', $val) unless $val =~ m/^((\w+|[\^\.])\/)?(\w+\.)*\w+$/; $slf->{'def'} = $slf->find($val) } $slf->{'pre'} = undef; $slf->{'tie'} = {}; # Apply setting level alterations if (ref($val = $slf->{'col'}->{'SETUP.N_PRF'}) eq 'HASH' && exists($val->{$slf->{'oid'}})) { $ptr = $slf->{'_set'}; $val = $val->{$slf->{'oid'}}; foreach my $key (keys(%{$val})) { $ptr->{$key}->{'_lvl'} = $val->{$key}; } } # Initialize the associated logic $blk = $slf->{'_pkg'}; $blk->set_info('aux', $slf); $blk->set_info('cnt', {}); $blk->set_info('def', $slf->{'def'}); $blk->set_info('del', 1); $blk->set_info('err', $slf->{'err'}); $blk->set_info('lvl', $trc); $blk->set_info('shr', $slf->{'shr'}); # Execute the associated logic if (exists($slf->{'_exe'})) { $slf->{'_cur'} = $slf; $slf->{'_tbl'} = \%tb_mod; eval {&{$slf->{'_exe'}->[0]}($slf, $slf->{'_exe'}, get_string('ERR_INIT'))}; trace_logic($slf, $@, $dbg ? "REQUEST/$nam: " : undef) if $@; } $slf->{'_tbl'} = \%tb_var; # Collect the variables $slf->{'_nxt'} = [@{$slf->{'_var'}}]; while (defined($var = shift(@{$slf->{'_nxt'}}))) { $slf->{'pre'} = $pre = "REQUEST/$nam/$var:" if $dbg; # Ignore variables without definitions unless (exists($slf->{'_set'}->{$var})) { debug($pre, get_string('Missing')) if $dbg; next; } # Check if the definition is relevant for the current OS family $slf->{'_cur'} = $ptr = $slf->{'_set'}->{$var}; unless ($ptr->is_valid($fam)) { debug($pre, get_string('Skipped')) if $dbg; next; } # Perform the variable setting $blk->set_info('def', $slf->{'def'}); $ptr->setup($slf, $lvl, $slf->{'_nxt'}, $pre); } # Untie the variables foreach my $key (keys(%{$slf->{'tie'}})) { foreach my $rec (@{delete($slf->{'tie'}->{$key})}) { eval {$rec->[0]->untie_value($key)}; debug("SETUP/$nam:", get_string('Untie', $rec->[1], $@)) if $@ && $dbg; } } $slf->{'xml'} = {}; # Indicate the completion status return 0; } =head2 S<$h-Esetup([$selected])> This method collects the setup information for the module. =cut sub setup { my ($slf) = @_; # Abort when not a data collection module $slf->{'agt'}->abort(get_string('BAD_MODULE', $slf->{'oid'})) unless exists($slf->{'nam'}); # Perform the setup in a new context return $slf->{'agt'}->switch_context($slf, get_string('ERR_SETUP', $slf->{'oid'}), \&_setup, @_); } sub _setup ## no critic (Complex) { my ($slf, $sel) = @_; my ($col, $dbg, $fam, $flg, $lvl, $nam, $sta); # Perform the setup $flg = 0; $col = $slf->{'col'}; $dbg = $slf->{'lvl'} > 1; $fam = $slf->{'cfg'}->get_family; $nam = $slf->{'nam'}; $lvl = $col->get_degree; $sta = $col->get_info('sta'); if ($slf->is_valid($fam)) { my ($blk, $def, $grp, $lng, $pre, $ptr, $val, $var, @bkp, @tbl); # Get the module definition $slf->{'def'} = $def = $col->find("SETUP.$nam", 1); if (exists($slf->{'_def'})) { $val = $slf->resolve_string($slf->{'_def'}); die get_string('BAD_DEFINITION', $val) unless $val =~ m/^((\w+|[\^\.])\/)?(\w+\.)*\w+$/; $slf->{'def'} = $def = $slf->find($val, 1) } $slf->{'sel'} = $sel ? 1 : 0; # Apply setting level alterations if (ref($val = $col->get_value('SETUP.N_PRF')) eq 'HASH' && exists($val->{$slf->{'oid'}})) { $ptr = $slf->{'_set'}; $val = $val->{$slf->{'oid'}}; foreach my $key (keys(%{$val})) { $ptr->{$key}->{'_lvl'} = $val->{$key}; } } # Initialize the associated logic $blk = $slf->{'_pkg'}; $blk->set_info('aux', $slf); $blk->set_info('del', 1); $blk->set_info('err', $slf->{'err'}); $blk->set_info('lvl', $slf->{'lvl'}); $blk->set_info('shr', $slf->{'shr'}); # Display the start of the definition _display($slf, ".S\n.I'$nam: '\n".$slf->get_desc."\n\n.S\n") unless $slf->is_isolated; # Collect the properties allowing interruptions for (;;) ## no critic (Loop) { # Backup the current definition @bkp = ([$def, $def->backup(1)]); BACKUP: foreach my $oid (@{$slf->{'_obj'}}) { $ptr = $slf->find($oid); foreach my $rec (@bkp) { next BACKUP if $ptr == $rec->[0]; } push(@bkp, [$ptr, $ptr->backup(1)]); } # Reset module $blk->set_info('cnt', {}); $blk->set_info('def', $def); foreach my $key (keys(%{$val = $slf->{'_bkp'}})) { $slf->set_info($key, delete($val->{$key})); } # Execute the associated logic $slf->{'pre'} = undef; $slf->{'tie'} = {}; $slf->{'_cur'} = $slf; $slf->{'_tbl'} = \%tb_mod; if (exists($slf->{'_exe'})) { eval {&{$slf->{'_exe'}->[0]}($slf, $slf->{'_exe'}, get_string('ERR_INIT'))}; trace_logic($slf, $@, $dbg ? "SETUP/$nam: " : undef) if $@; } $slf->{'_tbl'} = \%tb_var; # Collect the variables delete($slf->{'_evt'}); eval { local $SIG{'INT'} = sub { die "$INTERRUPT\n"; }; $slf->{'_nxt'} = [@{$slf->{'_var'}}]; while (defined($var = shift(@{$slf->{'_nxt'}}))) { $slf->{'pre'} = $pre = "SETUP/$nam/$var: " if $dbg; # Ignore variables without definitions unless (exists($slf->{'_set'}->{$var})) { debug($pre, get_string('Missing')) if $dbg; next; } # Perform the variable setting if relevant for the current OS family $slf->{'_cur'} = $ptr = $slf->{'_set'}->{$var}; if ($ptr->is_valid($fam)) { $blk->set_info('def', $def); $ptr->setup($slf, $lvl, $slf->{'_nxt'}, $pre) } else { debug($pre, get_string('Skipped')) if $dbg; } } # Untie the variables foreach my $key (keys(%{$slf->{'tie'}})) { foreach my $rec (@{delete($slf->{'tie'}->{$key})}) { eval {$rec->[0]->untie_value($key)}; debug(join(qq{\n}, "SETUP/$nam:".get_string('Untie', $rec->[0]->get_path), $slf->format_error($@, -1, q{ }))) if $@ && $dbg; } } }; # Determine the next action last unless $@; die $@ unless $@ =~ m/^$INTERRUPT/; $var = get_string('Yes'); die get_string('ABORTED') unless _ask($slf, ".N2\n.P0\n".get_string('Restart')."\\040\n\n", 'N') =~ m/^\s*$var/i; # Restore the initial status foreach my $rec (@bkp) { $rec->[0]->restore($rec->[1]); } foreach my $obj (@{$slf->{'_all'}}) { $obj->reset; } } # Restore the module definition $blk->set_info('def', $def); # Delete previous indicators delete($slf->{'_dft'}); delete($slf->{'_frk'}); delete($slf->{'_lst'}); delete($slf->{'_mrc'}); delete($slf->{'_spc'}); delete($slf->{'_tim'}); if ($flg = exists($slf->{'-col'}) ? $slf->{'-col'}->eval_as_scalar : $slf->{'_col'}) { # Manage the execution limits if (exists($slf->{'-lim'}) && $slf->{'-lim'}->eval_as_scalar) { if (defined($val = $def->get_first('R_SPACE_QUOTA'))) { $slf->{'_spc'} = $val; debug("QUOTA/$nam: space limit = $val MiB") if $dbg; } if (defined($val = $def->get_first('N_TIME_QUOTA'))) { $slf->{'_tim'} = $val; debug("QUOTA/$nam: time limit = $val sec") if $dbg; } } else { debug("QUOTA/$nam: inactive") if $dbg; } # Check if the module must be selected by default $slf->{'_dft'} = 1 if $slf->{'nam'} =~ m/^RDA\./ && exists($slf->{'-dft'}) && $slf->{'-dft'}->eval_as_scalar; # Adjust the customer file management level $val = exists($slf->{'-cfm'}) ? $slf->{'-cfm'}->eval_as_number : $slf->{'_cfm'}; $slf->{'_cfm'} = ($val =~ m/^(\d)$/) ? $1 : $DFT_CFM; # Determine the parallel execution $slf->{'_frk'} = 1 if exists($slf->{'-frk'}) && $slf->{'-frk'}->eval_as_scalar; # Determine the default collection target if (exists($slf->{'-tgt'})) { $val = $slf->{'-tgt'}->eval_as_scalar; $slf->{'_tgt'} = $val if ref($val) eq 'RDA::Object::Item' && $val->is_included($col->find('TARGET')); } } # Analyze the trigger specification if (exists($slf->{'_trg'})) { $lng = $slf->{'lng'}; $grp = $slf->{'grp'}; @tbl = (); foreach my $trg (@{$slf->{'_trg'}}) { if ($trg =~ s/^\+//) { push(@tbl, $lng->norm_package($grp, $trg)) if $flg; } elsif ($trg =~ s/^\-//) { push(@tbl, $lng->norm_package($grp, $trg)) unless $flg; } elsif ($trg =~ s/^\?(\!)?((\w+\.)*\w+)\://) { push(@tbl, $lng->norm_package($grp, $trg)) if defined($1) xor $def->get_first($2, 0); } else { push(@tbl, $lng->norm_package($grp, $trg)); } } $slf->{'_lst'} = [@tbl] if @tbl; } # Store the pending events if ($ptr = delete($slf->{'_evt'})) { foreach my $evt (@{$ptr}) { my ($typ, @det) = split(/\|/, $evt); $col->log($typ, @det) if $typ && $typ =~ m/^\w{2,}$/; } } # Delete obsolete variables foreach my $rec (@bkp) { $rec->[0]->clean; } # Update the status information if ($sta) { debug("STATUS/$nam: ", get_string($flg ? 'Enabled' : 'Disabled')) if $dbg; $def = _set_status($slf, $sta, $flg); $slf->{'_mrc'} = $def->get_first('B_MRC', 0) if exists($slf->{'-mrc'}) && $slf->{'-mrc'}->eval_as_scalar; foreach my $key (sort keys(%tb_sta)) { $var = $tb_sta{$key}; if (exists($slf->{$key})) { $def->set_value($var, $slf->{$key}, $tb_dsc{$var}); debug("STATUS/$nam: $var=" ._debug_scalar(scalar $def->get_text($var))) if $dbg; } elsif ($def->is_defined($var)) { $def->set_value($var); debug("STATUS/$nam: ", get_string('Removed', $var)) if $dbg; } } # Add the postrequisites to the setup queue $col->add_setup([], 0, 0, @tbl) if (@tbl = map {_norm_req($slf, $_, $flg)} @{$slf->{'_req'}}); } } elsif ($sta) { # Clear the status information debug("STATUS/$nam: skipped") if $dbg; _clear_status($slf, $sta); } # Indicate a successful completion return 1; } sub _ask { my ($slf, $txt, $dft) = @_; my ($lin, $rsp); $rsp = $slf->{'agt'}->submit(q{.}, RDA::Object::Message->new('ASK.ASK_LINE')->add_data($txt)); return ($rsp->is_success && length($lin = $rsp->get_data)) ? $lin : $dft; } sub _clear_status { my ($slf, $sta) = @_; my ($cur, $mod, $tim, %val); # Remove the module from the setup queue $mod = $slf->{'oid'}; %val = map {$_ => delete($sta->tie_value($_, {})->{$mod})} qw(R_CFG R_RUN B_SEL N_TRC); # Update the status information $cur = $sta->find($slf->{'nam'}, 1); $tim = time; $cur->set_value('G_CFG', $tim, $tb_dsc{'G_CFG'}); $cur->set_value('R_CFG'); $cur->set_value('S_CFG', 'skip', $tb_dsc{'S_CFG'}); $cur->set_value('T_DSC', get_desc($slf), $tb_dsc{'T_DSC'}); $cur->set_value('M_NAM', $slf->{'oid'}, $tb_dsc{'M_NAM'}); $cur->set_value('G_RUN', $tim, $tb_dsc{'G_RUN'}); $cur->set_value('R_RUN'); $cur->set_value('S_RUN', 'skip', $tb_dsc{'S_RUN'}); $cur->set_value('W_ABR'); # Return a reference to the status item return $cur; } sub _debug_array { my ($val) = @_; return q{(}.join(q{,}, map {_debug_scalar($_)} @{$val}).q{)}; } sub _debug_hash { my ($val) = @_; return '{'.join(q{,}, map {$_.q{=>}._debug_scalar($val->{$_})} sort keys(%{$val})).'}'; } sub _debug_scalar { my ($val) = @_; my ($ref); $ref = ref($val); return ($ref eq 'ARRAY') ? _debug_array($val) : ($ref eq 'HASH') ? _debug_hash($val) : !defined($val) ? 'undef' : ($val =~ m/^\[.*\]$/) ? $val : "'$val'"; } sub _display { return shift->{'agt'}->submit(q{.}, RDA::Object::Message->new('DISPLAY.DSP_REPORT', page => 0)->add_data(@_)); } sub _norm_req { my ($slf, $dep, $flg) = @_; my ($col, $grp, $mod, $val); $col = $slf->{'col'}; $grp = $slf->{'grp'}; if ($dep =~ s/^\+//) { $mod = $slf->{'lng'}->norm_package($grp, $dep); return ($mod) if defined($mod) && !$col->is_configured($mod) && $flg; } elsif ($dep =~ s/^\-//) { $mod = $slf->{'lng'}->norm_package($grp, $dep); return ($mod) if defined($mod) && !$col->is_configured($mod) && !$flg; } elsif ($dep =~ s/^\?(\!)?((\w+\.)*\w+)\://) { $mod = $slf->{'lng'}->norm_package($grp, $dep); $val = (defined($1) xor $slf->{'def'}->get_first($2, 0)); return ($mod) if defined($mod) && !$col->is_configured($mod) && $val; } else { $mod = $slf->{'lng'}->norm_package($grp, $dep); return ($mod) if defined($mod) && !$col->is_configured($mod); } return (); } sub _set_status { my ($slf, $sta, $flg) = @_; my ($cur, $mod, $seq, $tim, %val); # Remove the module from the setup queue $mod = $slf->{'oid'}; %val = map {$_ => delete($sta->tie_value($_, {})->{$mod})} qw(R_CFG R_RUN B_SEL N_TRC); # Update the status information $cur = $sta->find($slf->{'nam'}, 1); $tim = time; $cur->set_value('G_CFG', $tim, $tb_dsc{'G_CFG'}); $cur->set_value('G_RUN', $tim, $tb_dsc{'G_RUN'}); $cur->set_value('M_NAM', $slf->{'oid'}, $tb_dsc{'M_NAM'}); $cur->set_value('R_CFG', $val{'R_CFG'}, $tb_dsc{'R_CFG'}); $cur->set_value('R_RUN', $val{'R_RUN'}, $tb_dsc{'R_RUN'}); $cur->set_value('S_CFG', 'done', $tb_dsc{'S_CFG'}); $cur->set_value('T_DSC', get_desc($slf), $tb_dsc{'T_DSC'}); if ($flg && defined($seq = $val{'R_RUN'})) { $cur->set_value('S_RUN', ($cur->get_first('S_RUN', 'pending') eq 'pending') ? 'pending' : 'obsolete', $tb_dsc{'S_RUN'}); $cur->set_value('W_ABR', $slf->{'abr'}, $tb_dsc{'W_ABR'}); } else { $cur->set_value('S_RUN', 'skip', $tb_dsc{'S_RUN'}); $cur->set_value('W_ABR'); } # Return a reference to the status item return $cur; } sub trace_logic { my ($slf, $err, $pre) = @_; my ($rec); $rec = $slf->add_error($err)->pop_error; debug(join(qq{\n}, $pre, $slf->format_error($rec, -1, q{ }))) if $pre; return; } =head2 S<$h-Esubmit($dest,$message)> This method finds the agent corresponding to the destination, submits it the request, and returns a response message. =head2 S<$h-Esubmit($dest,$command,$attribute...)> This method generates the request message from the arguments, finds the agent corresponding to the destination, submits it the request, and returns a response message. =cut sub submit { return shift->{'agt'}->submit(@_); } =head2 S<$h-Exref([$flag])> This method produces a cross-reference of the setting definitions and their references. When the flag is set, it produces the associated logic cross-reference instead of the setting cross-reference. =cut sub xref { my ($slf, $flg) = @_; my ($buf, $obj, $typ, $xrf, @tb_mis, @tb_not, @tb_use, %tb_def); # Analyze the associated logic return $slf->{'_pkg'}->xref($slf->{'_xrf'}) if $flg; # Analyze the module $xrf = {}; _xref_def($xrf, $slf, '', 'var', 'dyn'); _xref_ref($xrf, $slf, 'var', ''); _xref_ref($xrf, $slf, 'dyn', ''); foreach my $nam (sort keys(%{$slf->{'_set'}})) { $obj = $slf->{'_set'}->{$nam}; $typ = $obj->{'_typ'}; _xref_def($xrf, $obj, "$nam($typ)", 'alt', 'var', 'dyn'); _xref_ref($xrf, $obj, 'var', $nam); _xref_ref($xrf, $obj, 'alt', $nam); _xref_ref($xrf, $obj, 'dyn', $nam); } # Classify the setting definitions foreach my $nam (sort keys(%{$xrf->{'-def'}})) { if ($nam eq '' || exists($xrf->{'-use'}->{substr($nam, 0, -3)})) { push(@tb_use, $nam); } else { push(@tb_not, $nam); } $tb_def{substr($nam, 0, -3)} = 1 unless $nam eq ''; } foreach my $nam (sort keys(%{$xrf->{'-use'}})) { push(@tb_mis, $nam) unless exists($tb_def{$nam}); } # Display the cross-reference # Text:XrefUsed Text:XrefUnused Text:XrefMissing Text:XrefReferences $buf = _dsp_name(get_string('Xref', $slf->{'oid'})).$RPT_NXT; $buf .= _dsp($xrf, \@tb_use, '-def', 'XrefUsed'); $buf .= _dsp($xrf, \@tb_not, '-def', 'XrefUnused'); $buf .= _dsp($xrf, \@tb_mis, '-use', 'XrefMissing'); $buf .= _dsp($xrf, $xrf->{'-use'}, '-use', 'XrefReferences'); return $buf; } # Analyse a definition sub _xref_def { my ($xrf, $obj, $nam, @arg) = @_; my ($hsh, $key, $rec, $tbl); $xrf->{'-def'}->{$nam} = $hsh = {}; foreach my $arg (@arg) { $key = "_$arg"; if (ref($rec = $obj->{$key}) && @{$rec}) { if (ref($tbl = $rec->[0]) eq 'HASH') { foreach my $str (sort keys(%{$tbl})) { $hsh->{"$arg/$str: "} = $tbl->{$str}; } $rec = $rec->[1]; } $hsh->{"$arg: "} = $rec if @{$rec}; } } return; } # Determine the references sub _xref_ref { my ($xrf, $obj, $key, $nam) = @_; my ($rec, $tbl); if (ref($rec = $obj->{"_$key"}) && @{$rec}) { if (ref($tbl = $rec->[0]) eq 'HASH') { foreach my $str (sort keys(%{$tbl})) { foreach my $arg (@{$tbl->{$str}}) { push(@{$xrf->{'-use'}->{$arg}}, "$nam($key/$str)"); } } $rec = $rec->[1]; } foreach my $arg (@{$rec}) { push(@{$xrf->{'-use'}->{$arg}}, "$nam($key)"); } } return; } =head1 VARIABLE MANAGEMENT METHODS =head2 S<$h-Eget_var($name[,$default])> This method resolves a variable. It supports the following property groups: =over 11 =item S< B<'AS' > > Add a platform-specific extension to the path =item S< B<'CFG'> > RDA configuration directory definitions =item S< B<'CNT'> > Modules counters =item S< B<'COL'> > Collector definition =item S< B<'CTX'> > Properties from the current setup context =item S< B<'CUR'> > Current execution context properties =item S< B<'DFT'> > Collector default properties =item S< B<'ENV'> > Environment variables (Internal Copy) =item S< B<'GRP'> > Module group properties =item S< B<'INC'> > Incremented module counters =item S< B<'MOD'> > Module properties =item S< B<'NXT'> > Incremented target counters =item S< B<'OS' > > Operating system indicators =item S< B<'OUT'> > Output/report directory definitions =item S< B<'PRF'> > Profile settings =item S< B<'RDA'> > RDA software configuration =item S< B<'REG'> > Agent registry entries =item S< B<'RUN'> > Run-time properties =item S< B<'SET'> > Collector setup properties =item S< B<'STA'> > Collector status properties =item S< B<'SYS'> > Environment variables (System view) =back =cut sub get_var { my ($slf, $nam, $val) = @_; my ($ctl, $fmt, $grp, $mod, @val); $nam =~ s/\001/\//g; # Determine the property group ($grp, $nam) = ($nam =~ m/^([A-Z]+|\-)\.(.*)$/i && exists($tb_grp{$1})) ? ($1, $2) : (q{-}, $nam); $ctl = $tb_grp{$grp}; # Extract the mode $fmt = 'F'; $mod = 'V'; if ($nam =~ s/\/([A-Za-z])([A-Z])?$//) { die get_string('INVALID_MODE', $1) if index($ctl->[1], $1) < 0; $mod = $1; if ($2) { die get_string('INVALID_LIST', $2) if index($ctl->[2], $2) < 0; $fmt = $2; } } # Get the value (in a scalar context) $val = &{$tb_fmt{$fmt}}($ctl->[3], $slf, $ctl->[0] ? uc($nam) : $nam, $mod, $val) if length($nam); return $val; } sub _fmt_val_comma { my ($fct, @arg) = @_; return join(q{,}, &$fct(@arg)); } sub _fmt_val_dot { my ($fct, @arg) = @_; return join(q{.}, &$fct(@arg)); } sub _fmt_val_first { my ($fct, $slf, $nam, $mod, $val) = @_; my (@val); return (@val = &$fct($slf, $nam, $mod, $val)) ? $val[0] : $val; } sub _fmt_val_last { my ($fct, $slf, $nam, $mod, $val) = @_; my (@val); return (@val = &$fct($slf, $nam, $mod, $val)) ? $val[-1] : $val; } sub _fmt_val_none { my ($fct, @arg) = @_; return join(q{}, &$fct(@arg)); } sub _fmt_val_pipe { my ($fct, @arg) = @_; return join(q{|}, &$fct(@arg)); } sub _fmt_val_quote { my ($fct, @arg) = @_; return join(q{ }, map {RDA::Object::Rda->quote($_)} &$fct(@arg)); } sub _fmt_val_space { my ($fct, @arg) = @_; return join(q{ }, &$fct(@arg)); } sub _fmt_val_text { my ($fct, @arg) = @_; return join(q{, }, &$fct(@arg)); } sub _get_var_as { my ($slf, $nam, $mod, $val) = @_; return ($nam eq 'BAT') ? RDA::Object::Rda->as_bat($val) : ($nam eq 'BATCH') ? RDA::Object::Rda->as_bat($val, 1) : ($nam eq 'CMD') ? RDA::Object::Rda->as_cmd($val) : ($nam eq 'COMMAND') ? RDA::Object::Rda->as_cmd($val, 1) : ($nam eq 'EXE') ? RDA::Object::Rda->as_exe($val) : ($nam eq 'STRING') ? $val : $val.q{.}.lc($nam); } sub _get_var_cfg { my ($slf, $nam) = @_; return $slf->{'cfg'}->get_group($nam); } sub _get_var_cnt { my ($slf, $nam) = @_; return $slf->{'_pkg'}->get_info('cnt', {})->{lc($nam)} || 0; } sub _get_var_col { my ($slf, $nam, $mod, $val) = @_; return $slf->{'col'}->get_element($mod, $nam, $val); } sub _get_var_ctx { my ($slf, $nam, $mod, $val) = @_; return exists($slf->{'ctx'}) ? $slf->{'col'}->get_element($mod, $slf->{'ctx'}.q{.}.$nam, $val) : $slf->{'agt'}->get_run->get_element($mod, "SETUP.$val", $val); } sub _get_var_cur { my ($slf, $nam, $mod, $val) = @_; return exists($tb_cur{$nam}) ? &{$tb_cur{$nam}}($slf) : $val; } sub _get_var_dft { my ($slf, $nam, $mod, $val) = @_; return $slf->{'col'}->get_element($mod, "DEFAULT.$nam", $val); } sub _get_var_env { my ($slf, $nam, $mod, $val) = @_; return $slf->{'agt'}->get_env($nam, $val); } sub _get_var_grp { my ($slf, $nam, $mod, $val) = @_; return $slf->{'col'}->get_info('set')->find($slf->{'_grp'}, 1)->get_element($mod, $nam, $val); } sub _get_var_inc { my ($slf, $nam) = @_; return ++$slf->{'_pkg'}->get_info('cnt', {})->{lc($nam)}; } sub _get_var_mod { my ($slf, $nam, $mod, $val) = @_; if ($nam =~ m/^(\w+)\/(.*)$/) { if ($1 eq 'PRF') { return $slf->{'col'}->get_change($2, $val) if $mod eq 'V'; die get_string('INVALID_MODE'); } return $slf->{'agt'}->get_item($1)->get_element($mod, $2, $val); } return $slf->{'def'}->get_element($mod, $nam, $val); } sub _get_var_nxt { my ($slf, $nam, $mod, $val) = @_; return $slf->{'col'}->get_element($mod, $nam, $val); } sub _get_var_os { my ($slf, $nam) = @_; return uc($slf->{'cfg'}->get_os) eq uc($nam); } sub _get_var_out { my ($slf, $nam) = @_; return $slf->{'col'}->get_dir($nam); } sub _get_var_prf { my ($slf, $nam, $mod, $val) = @_; my ($def); $def = $slf->{'def'}->get_path; return ($def =~ s/^SETUP\.//) ? $slf->{'col'}->get_change($def.q{.}.$nam, $val) : $val; } sub _get_var_rda { my ($slf, $nam, $mod, $val) = @_; return $slf->{'cfg'}->get_value($nam, $val); } sub _get_var_reg { my ($slf, $nam, $mod, $val) = @_; return $slf->{'agt'}->get_registry($nam) || $val; } sub _get_var_run { my ($slf, $nam, $mod, $val) = @_; return $slf->{'agt'}->get_run->get_element($mod, $nam, $val); } sub _get_var_set { my ($slf, $nam, $mod, $val) = @_; return $slf->{'col'}->get_element($mod, "SETUP.$nam", $val); } sub _get_var_sta { my ($slf, $nam, $mod, $val) = @_; return $slf->{'col'}->get_element($mod, "STATUS.$nam", $val); } sub _get_var_sys { my ($slf, $nam, $mod, $val) = @_; return $slf->{'agt'}->get_system($nam, $val); } =head2 S<$h-Eresolve_string($string[,$flag])> This method resolves variables in a string and executes operating system commands placed between back quotes. When the flag is set, it replaces some legacy characters. =cut sub resolve_string { my ($slf, $str, $flg) = @_; my ($val, $var); if (defined($str)) { # Replace special characters if ($flg) { $str =~ s/\\n/\n/g; $str =~ s/&\#10;/\n/g; $str =~ s/&\#34;/"/g; $str =~ s/&\#39;/'/g; } # Replace variables 1 while ($str =~ s/\$\{(([A-Z]+[\/\001])?(\w+\.)*\w+([\/\001][A-Z]{1,2})?)(\:([^\{\}]*))?\}/ $slf->get_var($1, defined($5) ? $6 : q{})/egi); # Treat commands local $SIG{'__WARN__'} = sub {}; $str =~ s/`(.*?)`/eval { $val = $1; if ($val && $^O eq 'VMS' && $val =~ m#[\<\>]# && $val !~ m#^PIPE #i) { $val = "PIPE $val"; $val =~ s#2>&1#2>SYS\$OUTPUT#g; } $val = `$val`; $val =~ s#[\n\r]$##; }; ($@ || $?) ? undef : $val;/eg; } # Return the result return $str; } =head1 CODE EXECUTION INTERFACE =head2 S<$h-Eexec_code($name,$value)> This method executes the specified function with the value provided. =cut sub exec_code { my ($slf, $nam, $val) = @_; my ($fct, @arg); if (exists($slf->{'_fct'}->{$nam})) { ($fct, @arg) = @{$slf->{'_fct'}->{$nam}}; &$fct(@arg, $val); } return; } =head2 S<$h-Eset_code($name[,$function,@arg])> This method associates some code to execute with the specified name. When you do not specified a code reference, it clears any previous definition. =cut sub set_code { my ($slf, $nam, $fct, @arg) = @_; if (ref($fct) eq 'CODE') { $slf->{'_fct'}->{$nam} = [$fct, @arg]; } else { delete($slf->{'_fct'}->{$nam}); } return; } =head1 SDCL PROPERTY INTERFACE =head2 S<$h-Eget_element($mode,$name)> This method returns the value of the specified attribute as a list. Depending on the context, it considers the attribute from the module or from the current setting. It supports the mode C only. =cut sub get_element { my ($slf, $mod, $nam) = @_; my ($cur, $rec); die get_string('BAD_MODE', $mod) unless $mod eq 'V'; if (exists($tb_aux{$nam})) { $rec = $tb_aux{$nam}; return @{$slf->{$rec->[1]}} if $rec->[0] > 0; return $slf->{$rec->[1]}; } $cur = $slf->{'_cur'}; if (exists($cur->{'_aux'}->{$nam})) { $rec = $cur->{'_aux'}->{$nam}; return @{$rec->[1]} if $rec->[0] > 0; return ($rec->[1]); } unless ($nam =~ m/^[A-Z]_/) { die get_string('BAD_PROPERTY', $nam) unless exists($slf->{'_tbl'}->{$nam = lc($nam)}); return ($cur->{"-$nam"}->eval_as_array) if exists($cur->{"-$nam"}); return ($cur->{"_$nam"}) if exists($cur->{"_$nam"}); } return (); } =head2 S<$h-Eset_element($mode,$name,$value)> This method provides a new value for the specified attribute. Depending on the context, it considers the attribute from the module or from the current setting. It supports the mode C only. =cut sub set_element { my ($slf, $mod, $nam, $val) = @_; my ($bkp, $cur, $key); die get_string('BAD_MODE', $mod) unless $mod eq 'V'; if (exists($tb_aux{$nam})) { die get_string('BAD_PROPERTY', $nam) if $tb_aux{$nam}->[0] < 0; $slf->{$tb_aux{$nam}->[1]} = $val; } elsif (exists($slf->{'_tbl'}->{$nam = lc($nam)})) { $cur = $slf->{'_cur'}; $bkp = $cur->{'_bkp'}; unless (exists($bkp->{"_$nam"})) { $bkp->{"-$nam"} = delete($cur->{"-$nam"}); $bkp->{"_$nam"} = delete($cur->{"_$nam"}); } $cur->{"_$nam"} = $val; } else { die get_string('BAD_PROPERTY', $nam); } return; } # --- Internal inline routines ------------------------------------------------ sub _end_sdcl { my ($slf, $blk) = @_; my ($rec, $sct); $rec = $slf->{'_src'}; $sct = sprintf('sdsl%04d', ++$rec->[0]); push(@{$rec->[1]}, join(q{ }, 'section', $sct, $blk->[2]), @{$blk->[1]}); return [\&_exe_sdcl, $sct]; } sub _exe_sdcl { my ($slf, $rec, $txt) = @_; return $slf->{'_pkg'}->exec($txt, undef, $rec->[1]); } # --- Internal reporting routines --------------------------------------------- sub _dsp { my ($xrf, $tbl, $key, $ttl) = @_; my ($buf, $ref, $str); return q{} unless ($ref = ref($tbl)); $tbl = [sort keys(%{$tbl})] if $ref eq 'HASH'; return q{} unless @{$tbl}; # Display the table $buf = _dsp_table(get_string($ttl)); foreach my $nam (@{$tbl}) { next unless defined($xrf->{$key}->{$nam}); if (ref($xrf->{$key}->{$nam}) eq 'HASH') { $str = join(qq{\n|}, map {q{**}.$_.q{**``}.join(q{``, ``},@{$xrf->{$key}->{$nam}->{$_}}) .q{``}} keys(%{$xrf->{$key}->{$nam}})); $str = q{\040} ## no critic (Interpolation) unless defined($str) && length($str); } else { $str = q{``}.join(q{``, ``}, @{$xrf->{$key}->{$nam}}).q{``}; $str =~ s/\(/``\(**/g; $str =~ s/\)``/**\)/g; } $buf .= qq{``$nam``|$str\n}; } return $buf.qq{\n}.$RPT_NXT; } sub _dsp_block { my ($pre, $txt, $nxt) = @_; my $buf = q{}; foreach my $str (split(/\\n|\n/, $txt)) { if ($str =~ m/^(\s*[o\*\-]\s+)(.*)$/) { $buf .= qq{.I '$pre\001$1'\n$2\n\n}; } else { $buf .= qq{.I '$pre'\n$str\n\n}; } } $buf .= qq{.N $nxt\n} if $nxt; return $buf; } sub _dsp_name { my ($ttl) = @_; return qq{.R '$ttl'\n}; } sub _dsp_text { my ($pre, $txt, $nxt) = @_; $txt =~ s/\n{2,}/\n\\040\n/g; $txt =~ s/(\\n|\n)/\n\n.I '$pre'\n/g; return qq{.I '$pre'\n$txt\n\n}.($nxt ? qq{.N $nxt\n} : q{}); } sub _dsp_table { my ($ttl) = @_; return qq{.M 2 '$ttl'\n}; } sub _dsp_title { my ($ttl) = @_; return qq{.T '$ttl'\n}; } # --- SDCL extensions --------------------------------------------------------- # Define the parse methods sub _get_require { my ($slf, $spc, $str) = @_; $spc->[$SPC_REF] = ($$str =~ s/^(\!\?{0,1}|\?)\s*//) ? $1 : q{}; $spc->[$SPC_VAL] = [$slf->parse_value($str)]; $spc->[$SPC_VAL]->[1] = $slf->parse_list($str) if $$str =~ s/,\s*//; return; } # Test a requirement sub _exe_require { my ($slf, $spc) = @_; my ($ctx, $val); # Evaluate the requirement $ctx = $slf->{'ctx'}; $val = $ctx->set_internal('val', $spc->[$SPC_VAL]->[0]->eval_value(1)); $val = $val->as_scalar; $val = defined($val) if $spc->[$SPC_REF] =~ m/\?/; $val = !$val if $spc->[$SPC_REF] =~ m/\!/; return $CONT if $val; # When specified, set the error message $slf->get_top('aux')->set_element('V', 'err', $val->eval_as_line) if defined($val = $spc->[$SPC_VAL]->[1]); # Specify the return value and return to the previous context $ctx->set_internal('val', $VAL_ZERO); return $RET_RET; } 1; __END__ =head1 SEE ALSO L, L, L, L, L, L, L, L, L, L, L, L =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