MINI

C:/app/Administrator/product/11.2.0/dbhome_1/sysman/admin/scripts/siha/
files >> C:/app/Administrator/product/11.2.0/dbhome_1/sysman/admin/scripts/siha/Common.pm
 #
# Copyright (c) 2001, 2007, Oracle. All rights reserved.  
#
#  $Id: Common.pm 06-oct-2007.18:53:02 ajdsouza Exp $ 
#
#
# NAME  
#	 Common.pm
#
# DESC 
#	 Common has subroutines 
#
#
# FUNCTIONS
# AUTOLOADER
#
# NOTES
#
#
# MODIFIED	(MM/DD/YY)
# ajdsouza       10/06/07 - XbranchMerge ajdsouza_bug-6261302 from
#                           st_emagent_10.2.0.1.0
# ajdsouza       09/26/07 - do not delete {name} for a xmlelement even if it is null
#                             it causes 0 not to be shown
# ajdsouza       04/11/07 - moved runsystemcommand code to OSD sCommon.pm
# ajdsouza       01/23/07 - Created 
#
#
package siha::Common;

require v5.6.1;

use Exporter;
use strict;
use warnings;
use locale;
use File::Spec::Functions;
use File::Path;
use Data::Dumper;
use XML::Parser;
require "emd_common.pl";
require "semd_common.pl";
use siha::sCommon;

our @ISA = qw(Exporter);
our @EXPORT = qw( runsystemcommand warn_message error_message exit_fail 
                  save_systemcmdoutput parse_xml 
                  traverse_xml delete_element mark_depth
                  append_element make_element print_xml dump_xml EMD_PERL_DEBUG 
                  EMD_PERL_ERROR EMD_PERL_TRACE EMD_PERL_WARN EMD_PERL_INFO
);

#------------------------------------------------------------------------------
# global package variables 

# variables for saving and reading the system command  output for regression tests
our $has_test_res_ref;
our $has_test_res_filen = 'has.out';

#-----------------------------------------------------------------------------
# package level variables

# variables for xml related parsing
my $has_xref;
my $has_fref;

#-----------------------------------------------------------------------------


#------------------------------------------------------------------------------
# FUNCTION : runsystemcommand($;$\%)
#
# DESC 
# Run a system command , retry n times if it times out
#
# ARGUMENTS
# command to be executed ( e.g. crsctl start crs )
# variable args to the command ( eg nodename)
#  a hash ref with
#  {timeout} in seconds, default 120
#  {tries} no of tries , default 2. 
#  {timeout_return} flag 1 to indicate if function should return 
#   in case of timeout, default is to die
#  {exit_failure_list}
#  {exit_success_list}
#   The lists to indicate failure and sucess exit status if they are other
#   than 0=Success all other exit status are =Fail
#   You can define one of the list of both the lists
#    e.g. for 'crsctl start crs' 
#    {exit_failure_list}=[(1,3,5,6)]
#    {exit_success_list}=[(0,2)]
#
# RETURNS:
#  result set either an array or a arg
#  the $? for the os command as {command_return_status} of the hash ref arg
#  {command_error_message} returns $! $@
#
#------------------------------------------------------------------------------
sub runsystemcommand( $;$\% )
{
  my ($fullcmd,$args,$argref) = @_;

  # fix for bug 6261302
  # go over path and get the full path to the variable

  # Not reqd to do this in regression or capture mode when
  # ENV{HAS_TEST_MODE} = capture or regression
  return siha::sCommon::runsystemcommand($fullcmd,$args,%{$argref}) 
   if $ENV{HAS_TEST_MODE} and $ENV{HAS_TEST_MODE} =~ /capture|regression/i;

  my $cmd;
  my $cmdargs;

  #split any args from command
  ($cmd,$cmdargs) = ( $fullcmd =~ /^([^\s]+) (.*)/ );
  $cmd = $fullcmd and undef $cmdargs unless $cmd;

  $cmd =~ s/^\s+//g if $cmd;

  stat($cmd) if $cmd;

  # $cmd is asolute path , invoke runsystemcommand
  return siha::sCommon::runsystemcommand($fullcmd,$args,%{$argref})
    if -e $cmd and -r $cmd; 

  # command does not have path figure out path from env variable
  my @paths;
  my $fullpath;
  @paths = File::Spec->path();

  # on windows get the appended path
  if ( $^O  =~ /windows|mswin/i )
  {
   if ( @paths and $paths[0] )
   {    
     my @setpaths = split/:[^\\]/,$paths[0];

     if ( @setpaths )
     {
       shift @paths;

       unshift @paths,@setpaths;
     }
   }
  }

  for my $path ( @paths )
  {
   
    for my $extn ( ( '', '.exe', '.bat' ) )
    {
     my $tcmd = "$cmd$extn";

     $fullpath = catfile($path,$tcmd);

     stat($fullpath);

     last if -e $fullpath and -r $fullpath;
     
     undef $fullpath;

     next;
    
    }
    last if $fullpath;
  }

  $fullpath = "$fullpath $cmdargs" if $fullpath and $cmdargs;
  $fullpath = $fullcmd unless $fullpath;

  return siha::sCommon::runsystemcommand($fullpath,$args,%{$argref});

}
#------------------------------------------------------------------------------
# FUNCTION :    warn_message
#
# DESC
# print warning messages
#
# ARGUMENTS
#  message
#------------------------------------------------------------------------------
sub warn_message(@)
{ 
   my ( $message ) = @_; 

   chomp $message; 

   $message =~ s/\n/ /g if $message;

   $message =~ s/^\s+|\s+$//
    if $message;

   $message = '' unless $message;

   # log the message to the log file
   EMD_PERL_WARN("Warning message from script $message");

   # send the warning message to emagent
   print "em_warning=Warning message from script $message\n";

   return 1;

}


#------------------------------------------------------------------------------
# FUNCTION :    error_message
#
# DESC
# print error messages
#
# ARGUMENTS
#  message
#------------------------------------------------------------------------------
sub error_message(@)
{ 
   my ( $message ) = @_; 

   chomp $message; 

   $message =~ s/\n/ /g if $message;

   $message =~ s/^\s+|\s+$// if $message;

   $message = '' unless $message;

   # log the message to the log file
   EMD_PERL_ERROR("Error message from script $message");

   # send the warning message to emagent
   print "em_error=Error message from script $message\n";

   return 1;

}

#------------------------------------------------------------------------------
# FUNCTION :    exit_fail
#
# DESC
# clean up, print errors before failure exit
#
# ARGUMENTS
#  message
#------------------------------------------------------------------------------
sub exit_fail(@)
{ 
   my ( $message ) = @_; 

   error_message($message);

   exit 1;

}


#------------------------------------------------------------------------------
# FUNCTION :    save_systemcmdoutput
#
# DESC
#  save the comd output from os commandinvoked thru runsystemcommand
#  to an os file - can be used for regression tests
#
# ARGUMENTS
#
#------------------------------------------------------------------------------
sub save_systemcmdoutput()
{

  return 1 unless $ENV{HAS_TEST_MODE} and $ENV{HAS_TEST_MODE} =~ /CAPTURE/i;

  $has_test_res_ref->{test_description} = $ENV{HAS_TEST_MODE_DESC}
   if $ENV{HAS_TEST_MODE_DESC};

  $Data::Dumper::Indent = 2;
  my $thewholestrg = Dumper($has_test_res_ref)
   or warn "Failed to save the results for test $has_test_res_ref\n"
    and return;

  my $test_file = 
    catfile(File::Spec->tmpdir(),$has_test_res_filen);

  stat($test_file);

  warn "File $test_file for captured regression test data is not accessible\n"
    and return
     if -e $test_file and not -w $test_file;

  open(TFH,">$test_file")
   or warn " Failed to open file $test_file for capturing test results \n"
    and return;

  print TFH $thewholestrg;

  close(TFH);

  return 1;

}



# name : has_start_handler
# desc : handler to be invoked by perl parser when starting an element
#
# arg :
#  to be passed by the perl parser
sub has_start_handler
{
  my ($pr,$el,%attrs) = @_;

  $pr->{cdata_buffer} = '';

  my %ehash = (element=>$el);

  $has_fref = \%ehash unless  $has_fref;

  for my $name ( keys %attrs )
  {
    $ehash{attrs}{$name}=$attrs{$name};
  }

  $ehash{parent} = $has_xref if $has_xref;
  $ehash{depth} = $ehash{parent}->{depth}+1 if $ehash{parent};
  $ehash{depth} = 0 unless $ehash{depth};

  push @{$has_xref->{child_elements}{$el}},\%ehash if $has_xref;
  push @{$has_xref->{children}},\%ehash if $has_xref;

  $has_xref = \%ehash;
}

# name : has_end_handler
# desc : handler function for perl parser when element closes
#
# arg : 
#  passed by perl parser
sub has_end_handler
{
  my ($pr,$el) = @_;

  $has_xref = $has_xref->{parent};

}

# name : has_char_handler
# desc : handler function for perl parser for char
#
# arg 
#  passed by parser
#
sub has_char_handler
{
  my ($pr,$tag) = @_;

  $has_xref->{name}=$tag unless $has_xref->{name};

  $has_xref->{name} =~ s/^\s|\s+$//g;

  chomp $has_xref->{name};

#  delete $has_xref->{name} unless $has_xref->{name};

}

# name : has_parse_xml
# desc :  parse a xml string to a perl variable
#
# arg  : 
#  xml string to be parsed
#
# return:
#  hash of parsed perl variable
#

sub parse_xml($)
{

 my ( $result ) = @_;

 warn "WARN:No XML content to parse"
  and return 
   unless $result;

 my $p = new XML::Parser(ErrorContext => 2,
                        ProtocolEncoding => 'UTF-8',
                        );

 $p->setHandlers(Start => \&has_start_handler,
	        End => \&has_end_handler,
                Char  => \&has_char_handler);

 undef $has_fref;
 undef $has_xref;

 # save the signal handler defined for die
 my $diesh = $SIG{__DIE__}
   if $SIG{__DIE__};

 # remove any signal handler defined for die
 $SIG{__DIE__}='';

 eval{  $p->parse($result) };

 # restore back the original die signal handler
 $SIG{__DIE__} = $diesh
  if $diesh;

 die  "ERROR: $@ Failed to Parse $result\n" if $@ and $result;
 die  "ERROR: $@ Failed to Parse \n" if $@;

 return %$has_fref;

}

# name : traverse_xml
# desc : traverse the xml tree, execute specificed function for each element
#
# args :
#  ref to hash of root of xml
#  ref to error handlig function
#  ref to traverse function
#  ref to list of args to function
#
sub traverse_xml(\%\&\&@)
{
  my ( $xmlref,$fnerrhndl,$fnref,@args) = @_;

  my @stack;

  # to print the array depth first
  push @stack, $xmlref;

  while ( my $xref = pop @stack )
  {

   next unless $xref;

   # keep error messages in the error stack
   if ( $xref->{element} =~ /^error$/i )
   {
     my $mtype;
     my $message;
     for my $ec ( @{$xref->{children}} )
     {
       $mtype = $ec->{name}
        if $ec->{element} =~ /^type$/i and $ec->{name};

       $message = $ec->{name}
        if $ec->{element} =~ /^message$/i and $ec->{name};
     }
     &{$fnerrhndl}("$mtype:$message") if $mtype and $message and $fnerrhndl;
   }

   # execute function for each element
   &{$fnref}($xref,@args) or die "ERROR:Failed to execute function\n";

   next if $xref->{ignore};

   push @stack, reverse @{$xref->{children}} if $xref->{children};

  }

  return 1;
}


# name : delete_element
# desc :  delete a element , remove it from the xml tree
#
# arg :
#  ref to the hash of the element to be removed
sub delete_element(\%)
{
  my ($elref) = @_;

  # mark it to be ignored
  $elref->{ignore}=1;

  # delete its children
  delete $elref->{children} if  $elref->{children};

  delete $elref->{child_elements} if  $elref->{child_elements};

  # delete it from the parent elements
  if ( $elref->{parent} and 
        $elref->{parent}->{child_elements} and
         $elref->{parent}->{child_elements}{$elref->{element}} )
  {
    my @child_elements = 
      @{$elref->{parent}->{child_elements}{$elref->{element}}};


    for my $i ( 0..@child_elements )
    {
      splice 
       @{$elref->{parent}->{child_elements}{$elref->{element}}},
        $i,1  if $child_elements[$i] == $elref;
    }

  }

  if ( $elref->{parent} and 
        $elref->{parent}->{children} )
  {
    my @child_elements = @{$elref->{parent}->{children}};


    for my $i ( 0..@child_elements )
    {
      splice @{$elref->{parent}->{children}},$i,1
       if $child_elements[$i] == $elref;
    }

  }

  %{$elref}=();

  undef %{$elref};

  return 1;

}

# name : mark_depth
# desc : mark depth of each element in xml var
#
# arg
#  ref to hash of parent var
#
sub mark_depth(\%)
{
  my ( $elref ) = @_;

  die "ERROR: Parent node has no depth defined for ".Dumper($elref)
   if $elref->{parent} and $elref->{parent}->{depth} !~ /\d+/;

  $elref->{depth} = $elref->{parent}->{depth} + 1 if $elref->{parent};

  $elref->{depth} = 0 unless $elref->{depth};

  return 1;

}

# name : append_element
# desc append element
#
# args
#  ref to parent
#  ref to child
# return:
#  ref to parent
sub append_element( \%\% )
{
  my ( $pref, $cref ) = @_;

  push @{$pref->{children}},$cref;
  push @{$pref->{child_elements}{$cref->{element}}},$cref;

  $cref->{parent} = $pref;

  return $pref;
}


# name : make_element
# make a new element
#
# args:
#  element
#  value
#  ref to attributes array
# return:
#  hash of the new element
sub make_element ($;$\%)
{

  my ( $element, $name, $attrs_ref ) = @_;

  my %element;

  $element{element} = $element;
  $element{name}    = $name;

  return %element unless $attrs_ref and 
    ref($attrs_ref) =~ /HASH/i and keys %{$attrs_ref};


  for my $attr ( keys %{$attrs_ref} )
  {
    $element{attrs}{$attr} = $attrs_ref->{$attr};
  }

  return %element;

}



# name : print_xml
# desc : print formatted xml from xml variable
#
# args :
#  xml doc type header
#  ref to hash of root element
#

sub print_xml($\%)
{
  my $xmlstrg = dump_xml(@_);

  print "$xmlstrg";

  return 1;
}



# name : dump_xml
# desc : dump formatted xml from xml variable to string
#
# args :
#  xml doc type header
#  ref to hash of root element
#
# returns:
#  xml dumped to a string
#
sub dump_xml($\%)
{
  my ( $has_xml_doctype,$xmlref ) = @_;

  my @stack;
  my %to_close_at;
  my $xmlstring = '';

  # to close the element
  sub close_elements( \%\@$$ )
  {
   my ($tca_ref,$s_ref,$xref,$xmlstring) = @_;

   # before printing the current element,close any elements that 
   # are to be closed
   for my $dpth ( sort {$b <=> $a} keys %{$tca_ref} )
   {
     last unless $dpth >= $xref->{depth};

     for my $stk( sort {$b <=> $a} keys %{${$tca_ref}{$dpth}} )
     {
       last unless $stk >= @{$s_ref};

       my $temp = sprintf("%*s</${$tca_ref}{$dpth}{$stk}>\n",$dpth,' ');

       $xmlstring= "$xmlstring$temp"  if $temp;

       delete ${$tca_ref}{$dpth}{$stk};
     }

     delete ${$tca_ref}{$dpth};
   }
  
   return $xmlstring;

  }

  $xmlstring = "$has_xml_doctype\n";

  # to print the array depth first
  push @stack, $xmlref;

  while ( my $xref = pop @stack )
  {

   next unless $xref;

   $xmlstring=close_elements(%to_close_at,@stack,$xref,$xmlstring);

   my $temp = sprintf("%*s<$xref->{element}",$xref->{depth},' ');
   # open element
   $xmlstring = "$xmlstring$temp"  if $temp;

   # print attributes
   for my $attr ( keys %{$xref->{attrs}} )
   {
    $xmlstring = 
     "$xmlstring $attr=\'$xref->{attrs}{$attr}\'";
   }

    $xmlstring = 
     "$xmlstring>";

   $xmlstring = 
     "$xmlstring$xref->{name}" if defined $xref->{name};

   if ( $xref->{children} )
   {
    $xmlstring = 
     "$xmlstring\n";

    $to_close_at{$xref->{depth}}{@stack}=$xref->{element};

    push @stack, reverse @{$xref->{children}};
   }
   else
   {
    $xmlstring = 
     "$xmlstring</$xref->{element}>\n";
   }

  }

  $xmlstring=close_elements(%to_close_at,@stack,$xmlref,$xmlstring);

  return $xmlstring;
}



1; #Returning a true value at the end of the module