# @(#)45 1.6 src/bos/usr/lib/kdb/Comm.perlmod, cmdkdb, bos720 12/12/00 08:06:56 # IBM_PROLOG_BEGIN_TAG # This is an automatically generated prolog. # # bos720 src/bos/usr/lib/kdb/Comm.perlmod 1.6 # # Licensed Materials - Property of IBM # # COPYRIGHT International Business Machines Corp. 1999,2000 # All Rights Reserved # # US Government Users Restricted Rights - Use, duplication or # disclosure restricted by GSA ADP Schedule Contract with IBM Corp. # # IBM_PROLOG_END_TAG # # COMPONENT_NAME: kdb # # FUNCTIONS: Comm CLASS # # ORIGINS: 83 # # # (C) COPYRIGHT International Business Machines Corp. 1999 # All Rights Reserved # Licensed Materials - Property of IBM # US Government Users Restricted Rights - Use, duplication or # disclosure restricted by GSA ADP Schedule Contract with IBM Corp. # ################################################################ package Comm; ################################################################ use Carp; use init; ### Import default symbols use integer; ######################################### # # CLASS ATTRIBUTES AND DEFINE # ######################################### my %comfields = ( ### Cache for exposed attributes rawinfo => undef, _errstr => undef, signature => undef, ); ######################################################################## ######################################################################## ############ # # AUTOLOAD # ############ ### Generic method to retrieve object attributes ### Supply the class for a _raw_xxx attribute is REQUIRED sub AUTOLOAD { my $self = shift; ### First argument is always the class ### Check for a proper reference my $type = ref($self) || croak "$self is not an object"; my $name = $AUTOLOAD; $name =~ s/.*://; ### Strip fully-qualified portion ### Check for the attribute in the class exists $self->{$name} or croak "Can't access `$name' attribute in object of class $type"; ### Check it is an external attribute $name =~ /^_.*/ and croak "`$name' not an external attribute in object of class $type"; ### Test the cache for the required ### attribute OR retrieve from raw data unless ( cached $self->{$name} ) { $self->rawinfo; $self->{$name} = $self->infofilter($name) unless $self->{_errstr}; } return $self->{$name}; } ############## # # infofilter # ############## ### Parse _raw_xxx attribute and call the right filter with the right arguments sub infofilter { my $self = shift; ### First argument is always the class my $name = join '','_raw_',shift; ### Which _raw_xxx to be used ? my $filter = $self->{$name}[0]; ### Which filter to be called ? my $pattern = $self->{$name}[1]; ### Which arguments to supply for my $newobj = $self->{$name}[2]; return $self->$filter( $pattern, $newobj); ### Call the filter } ############## # # pattern2obj # ############## ### Create a class object using a pattern ### The matching pattern supplies for the value which will indicate the object. sub pattern2obj { my $self = shift; ### First argument is always the class my $pattern = shift; ### pattern to be used ? my $result = $self->{rawinfo} =~ /$pattern/s; return undef unless ($result); my $create = shift; ### Which class object to be created ? return ($create)->new($1); ### with the backreference of the match } ############## # # pattern2val # ############## ### Return a value using a pattern sub pattern2val { my $self = shift; ### First argument is always the class my $pattern = shift; ### pattern to be used ? $self->{rawinfo} =~ /$pattern/s; return $1; ### Backreference of the match } ################ # # tabfield2val # ################ ### Return a value using a field in a table ### This filter is used to retrieve values of attributes which are displayed ### by the kdb command as a table format ### Note this only concerns the first line of data sub tabfield2val { my $self = shift; ### First argument is always the class my $field = shift; ### Field name to be retrieved my ($ahead,$data) = split m# ^(?=.*\w+\s*\+\s*\w+)#mx, $self->{rawinfo},2; ($data) = split m# (?=\n) #mx, $data, 2; my ($trash,$header) = split m# \n*(?=[^\n]+\n{2}$) #sx, $ahead, 2; my $sign = $self->_searchfield( $field, $header, $data ); return $sign; } ################ # # tabfield2obj # ################ ### Create a class object using a field in a table ### This filter is used to retrieve values of attributes which are displayed ### by the kdb command as a table format ### Note this only concerns the first line of data sub tabfield2obj { my $self = shift; ### First argument is always the class my $field = shift; ### Field name to be retrieved my $create = shift; ### Which class object to be created ? my ($ahead,$data) = split m# ^(?=.*\w+\s*\+\s*\w+)#mx, $self->{rawinfo},2; ($data) = split m# (?=\n) #mx, $data, 2; my ($trash,$header) = split m# \n*(?=[^\n]+\n{2}$) #sx, $ahead, 2; my $sign = $self->_searchfield( $field, $header, $data ); return ($create)->new($sign); } sub _searchfield { my $self = shift; ### First argument is always the class my ( $field, $header, $data ) = @_; ### Initialize a hash on header fields with corresponding index my %hashheader = (); $header =~ s# \n+ ##mx; my @fieldheader = split /\s+/,$header; ### To distinguish between - say CPU and CPUID - ### look for index with pattern 'field name\s' $header .= ' '; ### for the pattern to match the last field for ($i=0; $i <($#fieldheader + 1);$i++) { $hashheader{$fieldheader[$i]} = index $header, (join '', $fieldheader[$i], ' '); } ### Translate $data into a character array my (@firstlchar) = unpack "C" x length $data,$data; ### Initialization my $endline = $#firstlchar + 1; ### first index beyond the array my $fieldvalue =''; my $stop = $endline; ### stop index for a field for $i ( sort { $a <=> $b } values %hashheader ) { if ($i > $hashheader{$field}) { $stop = $i - 1; last; } } ### Manage apart when the field is the last in header if ($firstlchar[$hashheader{$field}] == 0xa ) { return $fieldvalue; } ### EITHER the character in data standing at index in header is a space ### THEN look forward to a first significent character ### - The field could be empty and/or the last in header - ### If not empty : ### look forward for a separator - that is a non-word character ### ( so far could be '*' or '!' or '>' : then the order in which ### it is looked up to exit the loop and improve performances ) if ($firstlchar[$hashheader{$field}] == 0x20) { $i = $hashheader{$field}; do { $i++; } while ( $firstlchar[$i] == 0x20 && $i < $stop ); my $deb = $i; ### index of first character of value while ( $firstlchar[$i] != 0x20 && $firstlchar[$i] != 0x2a && $firstlchar[$i] != 0x21 && $firstlchar[$i] != 0x3e && $i < $endline) { $i++ }; for ($k = $deb; $k < $i; $k++) { $fieldvalue = join '',$fieldvalue,chr $firstlchar[$k]; } } else { ### OR it is not a space ( and thus part of the field value ) THEN ### Look backwards for a separator - that is a non-word character - ### - sure to be found and cannot be beginning of a line - ### Then look forward for subsequent characters til a separator $i = $hashheader{$field}; do { $i-- } while ( $firstlchar[$i] != 0x20 && $firstlchar[$i] != 0x2a && $firstlchar[$i] != 0x21 && $firstlchar[$i] != 0x3e ); $i += 1; my $deb = $i; do { $i++ } while ( $firstlchar[$i] != 0x20 && $firstlchar[$i] != 0x2a && $firstlchar[$i] != 0x21 && $firstlchar[$i] != 0x3e && $i < $endline ); for ($k = $deb; $k < $i; $k++) { $fieldvalue = join '',$fieldvalue,chr $firstlchar[$k]; } } return $fieldvalue; } ########### # # arg2obj # ########### ### Create a class object using an attribute value ### The attribute value supplies for the value which will indicate the object. sub arg2obj { my $self = shift; ### First argument is always the class my $clonattr = shift; ### Which attribute ? $create = shift; ### Which class object to be created ? if ( $clonattr ne 'signature' ) { unless ( cached $self->{$clonattr} ) { eval { $self->$clonattr() }; return undef if $@; } } return ($create)->new( $self->{$clonattr} ); } ############ # # senddata # ############ ### Send the kdb subcommands sub senddata { my $self = shift; ### First argument is always the class my $tabcmd = shift; ### Reference on array my $cmd = $$tabcmd[0]; ### kdb subcommand to be called my $parms = $$tabcmd[1]; ### and its argument my $kdbcmd = join ' ', $cmd, $self->{$parms}; eval{ $Dbg->sendcmd($kdbcmd) }; ### Ask the debugger ### $@ should have been updated - with the die argument if ($@) { return -1 } else { return 0 } } ############ # # readdata # ############ ### Pick up all data in the pipe sub readdata { my $self = shift; ### First argument is always the class my $update = shift; ### attribute to be updated ### should generally be 'rawinfo' if ($$update[0]) { ### something specified to update ? $self->{$$update[0]} = eval{ $Dbg->readcmd }; ### Ask debugger } else { ### default is updating 'rawinfo' $self->{rawinfo} = eval{ $Dbg->readcmd }; ### Ask debugger } ### in case of error eval has set $@ and returned UNDEFINED if ($@) { return -1 } else { return 0 } } ############ # # flushdata # ############ ### Garbage all data in the pipe waiting for being picked up sub flushdata { my $self = shift; ### First argument is always the class eval{ $Dbg->readcmd }; ### Ask the debugger ### $@ should have been updated - with the die argument if ($@) { return -1 } else { return 0 } } ############ # # rawinfo # ############ ### Retrieve the rawinfo attribute sub rawinfo { my $self = shift; ### First argument is always the class ### Check the cache or get info from KDB unless ( cached $self->{rawinfo} ) { $ret = $self->_dbggetinfo; if ($ret) { ### Communication error with KDB ### $self->{rawinfo} already UNDEFINED ### $@ updated by eval $ErrFound = $self->{_errstr} = $@; } else { ### Update error detected by KDB ( $garbage, $self->{_errstr} ) = split /\{ \{ ERR/x, $self->{rawinfo}, 2; $self->{_errstr} =~ s#({{ERR\s*|ERR}}\s*)##g; $ErrFound = $self->{_errstr}; ### Not a communication error then leave 'rawinfo' as is ### that will avoid calling again if error badly managed ### at the script level ### BUT the script SHALL call errorfound(). } }; return $self->{rawinfo}; } ################# # # _dbggetinfo # ################# ### rawinfo is assumed to be defined - error checking is done by rawinfo ### This method should not be called directly anyway... sub _dbggetinfo { my $self = shift; ### First argument is always the class ### Execute the exchanges with KDB ordered by the _rawcmd attribute ### _rawcmd looks like an array of exchanges ### each exchange is itself an array, fitting : ### a flow routine ### a KDB subcommand ### the arguments of the KDB subcommands for ($i=0 ; $i<($#{$self->{_rawcmd}}+1) ; $i++) { my $flow = $self->{_rawcmd}[$i]->[0]; @cmd = ( $self->{_rawcmd}[$i]->[1], $self->{_rawcmd}[$i]->[2] ); $ret = $self->$flow(\@cmd); ### If flow control on error, stop processing last if $ret; } return $ret; } ################# # # errorfound # ################# sub errorfound { my $self = shift; ### First argument is always the class return $self->{_errstr}; } sub DESTROY { ### To prevent from the 'eval' error : DESTROY not found } ############## # # unimport # ############## ### Unload the package sub unimport { my $class = shift; for $key (keys %{"main::".$class."::"}) { delete ${"main::".$class."::"}{$key}; } for $key (keys %INC) { if ( $key =~ /^$class\W+/ ) { delete $INC{$key}; } } for $key (keys %main::) { if ( $main::{$key} =~ /\W+$class\W+/ ) { delete $main::{$key}; } } } 1;