File Coverage

blib/lib/Cisco/UCS.pm

Criterion	Covered	Total	%
statement	42	253	16.6
branch	0	132	0.0
condition	0	34	0.0
subroutine	14	56	25.0
pod	36	36	100.0
total	92	511	18.0

package Cisco::UCS;

use warnings;
use strict;

use Cisco::UCS::Chassis;
use Cisco::UCS::Interconnect;
use Cisco::UCS::FEX;
use Cisco::UCS::Blade;
use Cisco::UCS::Fault;
use Cisco::UCS::MgmtEntity;
use Cisco::UCS::ServiceProfile;
use LWP;
use XML::Simple;
use Carp qw(croak carp cluck);

use vars qw($VERSION);

our $VERSION		= '0.50';

our @ATTRIBUTES		= qw(dn cluster cookie);

our %ATTRIBUTES		= ();

sub new {
        my ( $class, %args ) = @_;

	my $self = {};
        bless $self, $class;

        defined $args{cluster}
		? $self->{cluster} = $args{cluster}
		: croak 'cluster not defined';

        defined $args{username}
		? $self->{username} = $args{username}
		: croak 'username not defined';

        defined $args{passwd}
		? $self->{passwd} = $args{passwd}
		: croak 'passwd not defined';

        defined $args{verify_hostname}
		? $self->{verify_hostname} = $args{verify_hostname}
		: 0;

	$self->{port}	= ( $args{port}	or 443      );
	$self->{proto}	= ( $args{proto} or 'https' );
	$self->{dn}	= ( $args{dn} or 'sys'      );

        return $self;
}

{
        no strict 'refs';

        while ( my ($pseudo, $attribute) = each %ATTRIBUTES ) {
                *{ __PACKAGE__ . '::' . $pseudo } = sub {
                        my $self = shift;
                        return $self->{$attribute}
                }
        }

        foreach my $attribute (@ATTRIBUTES) {
                *{ __PACKAGE__ . '::' . $attribute } = sub {
                        my $self = shift;
                        return $self->{$attribute}
                }
        }
}

sub login {
	my $self = shift;

	undef $self->{error};

	$self->{ua} = LWP::UserAgent->new(
				ssl_opts => {
					verify_hostname => $self->{verify_hostname}
				}
			);

	$self->{uri} = $self->{proto}. '://' .$self->{cluster}
				. ':' .$self->{port}. '/nuova';

	$self->{req} = HTTP::Request->new(
					POST => $self->{uri}
			);

	$self->{req}->content_type( 'application/x-www-form-urlencoded' );

	$self->{req}->content( '
93
				.'" inPassword="'. $self->{passwd} .'"/>' );

	my $res	= $self->{ua}->request( $self->{req} );

	unless ( $res->is_success ) {
		$self->{error} = 'Login failure: '.$res->status_line;
		return 0
	}

	$self->{parser}	= XML::Simple->new;
	my $xml         = $self->{parser}->XMLin( $res->content );

	if ( defined $xml->{'errorCode'} ) {
		$self->{error}	= 'Login failure: '
				. ( defined $xml->{'errorDescr'}
					? $xml->{'errorDescr'}
					: 'Unspecified error'
				);
		return 0
	}

	$self->{cookie}	= $xml->{'outCookie'};

	return 1
}

sub refresh {
	my $self = shift;

	undef $self->{error};
	$self->{req}->content( '
124
				.'" inPassword="'. $self->{passwd}
				.'" inCookie="' . $self->{cookie} . '"/>'
	);

	my $res	= $self->{ua}->request( $self->{req} );

	unless ( $res->is_success ) {
		$self->{error}	= 'Refresh failed: '. $res->status_line;
		return 0
	}

	my $xml	= $self->{parser}->XMLin( $res->content() );

	if ( defined $xml->{'errorCode'} ) {
		$self->{error}	= 'Refresh failure: '
				. ( defined $xml->{'errorDescr'}
					? $xml->{'errorDescr'}
					: 'Unspecified error'
				);
		return 0
	}

        $self->{cookie}	= $xml->{'outCookie'};

	return 1
}

sub logout {
	my $self = shift;

	return unless $self->{cookie};

	undef $self->{error};

	return ( $self->_ucsm_request( '
159
				. $self->{cookie} .'" />' ) ? 1 : 0
	)
}

sub _ucsm_request {
	my ( $self, $content, $class_id ) = @_;

	undef $self->{error};
	$self->{req}->content( $content );
	my $res	= $self->{ua}->request( $self->{req} );

	$self->error( $res->status_line ) unless $res->is_success;

	my $xml = ( $class_id
			? $self->{parser}->XMLin(
						$res->content,
						KeyAttr => $class_id
						)
			: $self->{parser}->XMLin(
						$res->content,
						KeyAttr => [ 'name', 'key', 'id', 'intId' ]
						)
		);

	return ( $xml->{errorCode}
			? do {
				$self->{error} = ( $xml->{'errorDescr'}
							? $xml->{'errorDescr'}
							: 'Unspecified error'
						);
				undef
			  }
			: $xml
		);
}

# This private method provides an abstract factory-type constructor for resolved child
# objects of the specified dn.  To maintain compatibility with existing methods and to
# provide a single method for all child objects, there are a few important design
# considerations that have been made.
#
# Importantly we check for a 'class_filter' argument to the method which if present is
# used to call the 'resolve_class_filter' method rather than the 'resolve_children' method.
# This is necessary due to limitations and difficulties present in resolving child objects
# for some objects can lead to incorrect results.  For example, resolving the child objects
# for a chassis to retrieve the blades in the chassis is difficult, instead we can use a much
# more efficient and simpler method of retrieving the blades in a specified chassis by
# resolving all objects in the specified class (i.e. computeBlade) and restricting the
# results returned using a filter method.
#
# The implication of doing this is that the call to 'resolve_class_filter' returns an array
# which cannot be processed using the same logic as for a hash returned by the 'resolve_children'
# method.  Therefore we perform extra processing to convert the returned array results to a
# hash using a nominated attribute in the object as the hash index for the objects.
#
# SYNOPSIS
#	get_child_object ( %ARGS )
#
# PARAMETERS
#	id	The optional identifier of a specific child object.  This identifier is context
#		dependent and may be either numerical (as in the case of a chassis) or alphanumeric
#		(as is the case with a fabric interconnect - A or B).
#
#	type	The desired child object type to be resolved as according to the UCSM information
#		management hierarchy name. e.g. etherPIo is the ethernet port child object type for line cards.
#
#	class	The class into which the child object will be blessed.
#
#	attr	The pseudo-namespace in the Cisco::UCS object in which the retrieved child onjects will be cached.
#		For example; attr => 'interconnect' will mean that Cisco::UCS::Interconnect objects retrieved in
#		a $ucs->get_interconnects method call will be stored in $ucs->{interconnects}->{$OBJ}.
#
#	self	A reference to a Cisco::UCS object.  If not present $self is assumed to be a Cisco::UCS object.
#
#	uid	Where results are returned and parsed into an array and the array index is not aligned to an identifying
#		attribute of the object (i.e. the array index has no relation to a unique identifier for the object) then
#		the uid may be used to refer to a unique identifying attribute of the object that should be used.
#		For example, in resolving all blades for a Cisco::UCS object, the uid value of bladeId is used to uniquely
#		identify all Cisco::UCS::Blade objects as the array index has no relation to a uniquely identifying feature
#		of the blade and is not guaranteed to be consistent.
#
#	class_filter (%ARGS)
#			A class filter may be specified to filter the results to a particular subset.  This is useful for
#			operations like retrieving all blades in a particular chassis rather than retrieving all blades and
#			manually filtering the results.
#
#	Where %ARGS:
#
#	classId	The UCSM class which should be used for the UCSM query.  For example: classId => etherPio.
#
#	filter	Where filter is composed of any number of valid attribute/value pairs.  For example: slotId => 1, switchId => $self->{id}.
#

sub _get_child_objects {
        my ( $self,%args ) = @_;

	my $ucs = ( defined $self->{ucs}
			? $self->{ucs}
			: $self
		);

	my $ref = ( defined $args{self}
			? $args{self}
			: $self
		);

        my $xml = ( defined $args{class_filter}
			? $ucs->resolve_class_filter( %{ $args{class_filter} } )
			: $ucs->resolve_children( dn => $ref->{dn} )
		  );

	if ( ref( $xml->{outConfigs}->{ $args{type} } ) eq 'ARRAY' ) {
		$args{uid} ||= 'id';
		my $res;

		foreach my $obj ( @{ $xml->{outConfigs}->{ $args{type} } } ) {
			$res->{ $obj->{ $args{uid} } } = $obj
		}

		$xml->{outConfigs}->{ $args{type} } = $res
	}
	elsif ( ( ref( $xml->{outConfigs}->{ $args{type} } ) eq 'HASH' )
			and ( exists $xml->{outConfigs}->{ $args{type} }->{dn} ) ) {
		$args{uid} ||= 'id';
		my $res;
		$res->{ $xml->{outConfigs}->{ $args{type} }->{ $args{uid} } }
			= $xml->{outConfigs}->{ $args{type} };

		$xml->{outConfigs}->{ $args{type} } = $res
	}

        return ( defined $xml->{outConfigs}->{ $args{type} }
                ? do {  my @res;
                        foreach my $res ( keys %{ $xml->{outConfigs}->{ $args{type} } } ) {
                                my $obj = $args{class}->new(
							ucs => $ucs,
							dn  => $xml->{outConfigs}->{ $args{type} }->{$res}->{dn},
							id  => $res
				);

                                $ref->{ $args{attr} }->{$res} = $obj;
                                push @res, $obj;
                        }

                        return @res unless $args{id};

                        return $ref->{ $args{attr} }->{ $args{id} }
				if $args{id} and $ref->{ $args{attr} }->{ $args{id} };

                        return
                     }
                : ()
                );

}

sub get_error_id {
	warn "get_error_id has been deprecated in future releases";
	return get_error( @_ )
}

sub error {
	my ( $self, $id ) = @_;

	return (
		defined $self->{fault}->{$id}
			? $self->{fault}->{$id}
			: $self->get_error($id)
	)
}

sub get_error {
	my ( $self, $id ) = @_;

	return $self->get_errors( $id )
}

sub get_errors {
	my ( $self, $id ) = @_;

	return $self->_get_child_objects(
				id           => $id,
				type         => 'faultInst',
				class        => 'Cisco::UCS::Fault',
				uid          => 'id',
				attr         => 'fault',
				class_filter => {
						classId => 'faultInst'
						}
			);
}

sub _isInHierarchical {
	my $inHierarchical = lc shift;

	return 'false' unless ( $inHierarchical =~ /true|false|0|1/ );

	return $inHierarchical if ( $inHierarchical =~ /^true|false$/ );

	return ( $inHierarchical == 0 ? 'false' : 'true' );
}

sub _createFilter {
	my ( $self, %args ) = @_;

	unless ( defined $args{classId} ) {
		$self->{error} = 'No classId specified';
		return
	}

	my $filter = '';

	while ( my( $property,$value ) = each %args ) {
		next if ( $property eq 'inHierarchical' or $property eq 'classId' );
		$filter	.= '
374
			. $property . '" value="' . $value . '" />';
	}

	$filter	.= '';

	return $filter;
}

sub resolve_class {
	my ( $self, %args ) = @_;

	unless ( defined $args{classId} ) {
		$self->{error} = 'No classId specified';
		return
	}

	$args{inHierarchical} = (
		defined $args{inHierarchical}
			? _isInHierarchical( $args{inHierarchical} )
			: 'false'
	);

	my $xml	= $self->_ucsm_request( '
397
					. $args{inHierarchical} .'" cookie="'
					. $self->{cookie} .'" classId="'
					. $args{classId} .'" />' ) or return;

	return $xml
}

sub resolve_classes {
	my ( $self, %args ) = @_;

	unless ( defined $args{classId} ) {
		$self->{error} = 'No classID specified';
		return
	}

	$args{inHierarchical} = (
		defined $args{inHierarchical}
			? _isInHierarchical( $args{inHierarchical} )
			: 'false'
	);

	my $xml	= $self->_ucsm_request(	'
419
					. $args{inHierarchical}
					. '" cookie="'. $self->{cookie} .'">'
					. '
422
					. '" />', 'classId'
	) or return;

	return $xml
}

sub resolve_dn {
	my ( $self, %args ) = @_;

	unless ( defined $args{dn} ) {
		$self->{error} = 'No dn specified';
		return
	}

	$args{inHierarchical} = (
		defined $args{inHierarchical}
			? _isInHierarchical( $args{inHierarchical} )
			: 'false'
	);

	my $xml	= $self->_ucsm_request(	'
443
					. '" inHierarchical="'. $args{inHierarchical}
					. '" cookie="'. $self->{cookie} .'" />'
				) or return;

	return $xml;
}

sub resolve_children {
	my ( $self, %args ) = @_;

	unless ( defined $args{dn} ) {
		$self->{error} = 'No dn specified';
		return
	}

	$args{inHierarchical} = (
		defined $args{inHierarchical}
			? _isInHierarchical( $args{inHierarchical} )
			: 'false'
	);

	my $xml	= $self->_ucsm_request(	'
465
					. $args{inHierarchical} .'" cookie="'
					. $self->{cookie} .'" inDn="'
					. $args{dn} .'">'
				) or return;

	return $xml
}

sub resolve_class_filter {
	my( $self, %args ) = @_;

	$args{inHierarchical} = (
		defined $args{inHierarchical}
			? _isInHierarchical( $args{inHierarchical} )
			: 'false'
	);

	my $filter	= $self->_createFilter( %args ) or return;

	my $xml		= $self->_ucsm_request( '
485
						. $args{classId} .'" inHierarchical="'
						. $args{inHierarchical} .'" cookie="'
						. $self->{cookie} .'">' . $filter
						. '', $args{classId}
					) or return;

	return $xml
}

sub get_cluster_status {
	my $self = shift;

	my $xml	= $self->resolve_dn( dn => 'sys' ) or return;

	return (
		defined $xml->{outConfig}->{topSystem}
			? $xml->{outConfig}->{topSystem}
			: undef
	)
}

sub version {
	my $self = shift;

	my $xml	= $self->resolve_dn( dn => 'sys/mgmt/fw-system' ) or return;

	return (
		defined $xml->{outConfig}->{firmwareRunning}->{version}
			? $xml->{outConfig}->{firmwareRunning}->{version}
			: undef
	)
}

sub mgmt_entity {
	my ( $self, $id ) = @_;

	return (
		defined $self->{mgmt_entity}->{$id}
			? $self->{mgmt_entity}->{$id}
			: $self->mgmt_entity($id)
	)
}

sub get_mgmt_entity {
	my ( $self, $id ) = @_;

	return $self->get_mgmt_entities( $id )
}

sub get_mgmt_entities {
        my ( $self, $id ) = @_;

	return $self->_get_child_objects(
				id    => $id,
				type  => 'mgmtEntity',
				class => 'Cisco::UCS::MgmtEntity',
				attr  => 'mgmt_entity'
			);
}

sub get_primary_mgmt_entity {
	my $self = shift;

	my $xml	= $self->resolve_class_filter(
				classId    => 'mgmtEntity',
				leadership => 'primary'
			) or return;

	return (
		defined $xml->{outConfigs}->{mgmtEntity}
			? $xml->{outConfigs}->{mgmtEntity}
			: undef
	)
}

sub get_subordinate_mgmt_entity {
	my $self = shift;

	my $xml	= $self->resolve_class_filter(
				classId    => 'mgmtEntity',
				leadership => 'subordinate'
			) or return;

	return (
		defined $xml->{outConfigs}->{mgmtEntity}
			? $xml->{outConfigs}->{mgmtEntity}
			: undef
	);
}

sub service_profile {
	my ( $self, $id ) = @_;

	return (
		defined $self->{service_profile}->{$id}
			? $self->{service_profile}->{$id}
			: $self->get_service_profile($id)
	)
}

sub get_service_profile {
	my ( $self, $id ) = @_;

	return $self->get_service_profiles( $id )
}

sub get_service_profiles {
	my ( $self, $id ) = @_;

	return $self->_get_child_objects(
				id           => $id,
				type         => 'lsServer',
				class        => 'Cisco::UCS::ServiceProfile',
				uid          => 'name',
				attr         => 'service_profile',
				class_filter => {
						classId => 'lsServer'
						}
			);
}

sub interconnect {
	my ( $self, $id ) = @_;

	return (
		defined $self->{interconnect}->{$id}
			? $self->{interconnect}->{$id}
			: $self->get_interconnect($id)
	)
}

sub get_interconnect {
	my ( $self, $id ) = @_;

	return $self->get_interconnects( $id )
}

sub get_interconnects {
	my ( $self, $id ) = @_;

	return $self->_get_child_objects(
				id    => $id,
				type  => 'networkElement',
				class => 'Cisco::UCS::Interconnect',
				attr  => 'interconnect'
			);
}

sub blade {
	my ( $self, $id ) = @_;

	return (
		defined $self->{blade}->{$id}
			? $self->{blade}->{$id}
			: $self->get_blade($id)
	)
}

sub get_blade {
	my ( $self, $id ) = @_;

	return $self->get_blades( $id )
}

sub get_blades {
	my ( $self, $id, %args ) = @_;

	return $self->_get_child_objects(
				id           => $id,
				type         => 'computeBlade',
				class        => 'Cisco::UCS::Blade',
				attr         => 'blade',
				uid          => 'serverId',
				class_filter => {
						classId => 'computeBlade'
						}
			);
}

sub chassis {
	my ( $self, $id ) = @_;

	return (
		defined $self->{chassis}->{$id}
			? $self->{chassis}->{$id}
			: $self->get_chassis($id)
	)
}

sub get_chassis {
	my ( $self, $id ) = @_;

	return $self->get_chassiss( $id )
}

sub get_chassiss {
	my ( $self, $id ) = @_;

	return $self->_get_child_objects(
				id    => $id,
				type  => 'equipmentChassis',
				class => 'Cisco::UCS::Chassis',
				attr  => 'chassis'
			);
}

sub full_state_backup {
	my ( $self, %args ) = @_;

	$args{backup_type} = 'full-state';

	return ( $self->_backup( %args ) );
}
sub all_config_backup {
	my ( $self, %args ) = @_;

	$args{backup_type} = 'config-all';

	return ( $self->_backup( %args ) );
}

sub system_config_backup {
	my ( $self, %args ) = @_;

	$args{backup_type} = 'config-system';

	return ( $self->_backup( %args ) );
}

sub logical_config_backup {
	my ( $self, %args ) = @_;

	$args{backup_type} = 'config-logical';

	return ( $self->_backup( %args ) );
}

sub _backup {
	my ( $self, %args ) = @_;

	unless( defined $args{backup_type} 	and
		defined $args{backup_proto}	and
		defined $args{backup_host}	and
		defined $args{backup_target}	and
		defined $args{backup_passwd}	and
		defined $args{backup_username} )
	{
		$self->{error} = 'Bad argument list';
		return
	}

	$args{admin_state} = (
		defined $args{admin_state}
			? $args{admin_state}
			: 'enabled'
	);

	$args{preserve_pooled_values} = (
		defined $args{preserve_pooled_values}
			? $args{preserve_pooled_values}
			: 'yes'
	);

	unless ( $args{backup_type} =~ /(config-all|full-state|config-system|config-logical)/i ) {
		$self->{error} = "Bad backup type ($args{backup_type})";
		return
	}

	unless ( $args{backup_proto} =~ /^((t|s)?ftp)|(scp)$/i ) {
		$self->{error} = "Bad backup proto' ($args{backup_proto})";
		return
	}

	my $address	= $self->get_cluster_status->{address};

	my $data = <<"XML";





          proto="$args{backup_proto}" pwd="$args{backup_passwd}" remoteFile="$args{backup_target}"
          rn="backup-$args{backup_host}" type="$args{backup_type}"
          user="$args{backup_username}" policyOwner="local">





XML

	my $xml = $self->_ucsm_request( $data ) or return;

	if ( defined $xml->{'errorCode'} ) {
		my $self->{error} = ( defined $xml->{'errorDescr'}
					? $xml->{'errorDescr'}
					: "Unspecified error"
				);
		return
	}

	return 1;
}

1;

__END__