Commit c72ef653 authored by Kirk Webb's avatar Kirk Webb

Merge branch 'snmpit-portfix'

parents 5d8082f0 f3ffa644
...@@ -6557,6 +6557,7 @@ outfiles="$outfiles Makeconf GNUmakefile \ ...@@ -6557,6 +6557,7 @@ outfiles="$outfiles Makeconf GNUmakefile \
tbsetup/GNUmakefile tbsetup/console_setup tbsetup/spewlogfile \ tbsetup/GNUmakefile tbsetup/console_setup tbsetup/spewlogfile \
tbsetup/snmpit_test/GNUmakefile \ tbsetup/snmpit_test/GNUmakefile \
tbsetup/snmpit_old/GNUmakefile \ tbsetup/snmpit_old/GNUmakefile \
tbsetup/snmpit_portfix/GNUmakefile \
tbsetup/spewrpmtar tbsetup/gentopofile tbsetup/power_sgmote.pm \ tbsetup/spewrpmtar tbsetup/gentopofile tbsetup/power_sgmote.pm \
tbsetup/console_reset tbsetup/bwconfig tbsetup/power_rpc27.pm \ tbsetup/console_reset tbsetup/bwconfig tbsetup/power_rpc27.pm \
tbsetup/power_mail.pm tbsetup/power_whol.pm \ tbsetup/power_mail.pm tbsetup/power_whol.pm \
......
...@@ -1093,6 +1093,7 @@ outfiles="$outfiles Makeconf GNUmakefile \ ...@@ -1093,6 +1093,7 @@ outfiles="$outfiles Makeconf GNUmakefile \
tbsetup/GNUmakefile tbsetup/console_setup tbsetup/spewlogfile \ tbsetup/GNUmakefile tbsetup/console_setup tbsetup/spewlogfile \
tbsetup/snmpit_test/GNUmakefile \ tbsetup/snmpit_test/GNUmakefile \
tbsetup/snmpit_old/GNUmakefile \ tbsetup/snmpit_old/GNUmakefile \
tbsetup/snmpit_portfix/GNUmakefile \
tbsetup/spewrpmtar tbsetup/gentopofile tbsetup/power_sgmote.pm \ tbsetup/spewrpmtar tbsetup/gentopofile tbsetup/power_sgmote.pm \
tbsetup/console_reset tbsetup/bwconfig tbsetup/power_rpc27.pm \ tbsetup/console_reset tbsetup/bwconfig tbsetup/power_rpc27.pm \
tbsetup/power_mail.pm tbsetup/power_whol.pm \ tbsetup/power_mail.pm tbsetup/power_whol.pm \
......
...@@ -169,6 +169,11 @@ use vars qw(@ISA @EXPORT); ...@@ -169,6 +169,11 @@ use vars qw(@ISA @EXPORT);
TBDB_WIDEAREA_LOCALNODE TBDB_WIDEAREA_LOCALNODE
TBDB_WIRETYPE_NODE TBDB_WIRETYPE_SERIAL TBDB_WIRETYPE_POWER
TBDB_WIRETYPE_DNARD TBDB_WIRETYPE_CONTROL TBDB_WIRETYPE_TRUNK
TBDB_WIRETYPE_OUTERCONTROL TBDB_WIRETYPE_UNUSED
TBDB_WIRETYPE_MANAGEMENT
TBDB_IFACEROLE_CONTROL TBDB_IFACEROLE_EXPERIMENT TBDB_IFACEROLE_CONTROL TBDB_IFACEROLE_EXPERIMENT
TBDB_IFACEROLE_JAIL TBDB_IFACEROLE_FAKE TBDB_IFACEROLE_OTHER TBDB_IFACEROLE_JAIL TBDB_IFACEROLE_FAKE TBDB_IFACEROLE_OTHER
TBDB_IFACEROLE_GW TBDB_IFACEROLE_OUTER_CONTROL TBDB_IFACEROLE_GW TBDB_IFACEROLE_OUTER_CONTROL
...@@ -560,6 +565,17 @@ sub TBDB_IFACEROLE_OTHER() { "other"; } ...@@ -560,6 +565,17 @@ sub TBDB_IFACEROLE_OTHER() { "other"; }
sub TBDB_IFACEROLE_OUTER_CONTROL(){ "outer_ctrl"; } sub TBDB_IFACEROLE_OUTER_CONTROL(){ "outer_ctrl"; }
sub TBDB_IFACEROLE_MANAGEMENT() { "mngmnt"; } sub TBDB_IFACEROLE_MANAGEMENT() { "mngmnt"; }
# Wire types.
sub TBDB_WIRETYPE_NODE() { "Node"; }
sub TBDB_WIRETYPE_SERIAL() { "Serial"; }
sub TBDB_WIRETYPE_POWER() { "Power"; }
sub TBDB_WIRETYPE_DNARD() { "Dnard"; }
sub TBDB_WIRETYPE_CONTROL() { "Control"; }
sub TBDB_WIRETYPE_TRUNK() { "Trunk"; }
sub TBDB_WIRETYPE_OUTERCONTROL() { "OuterControl"; }
sub TBDB_WIRETYPE_UNUSED() { "Unused"; }
sub TBDB_WIRETYPE_MANAGEMENT() { "Management"; }
# Routertypes. # Routertypes.
sub TBDB_ROUTERTYPE_NONE() { "none"; } sub TBDB_ROUTERTYPE_NONE() { "none"; }
sub TBDB_ROUTERTYPE_OSPF() { "ospf"; } sub TBDB_ROUTERTYPE_OSPF() { "ospf"; }
......
...@@ -34,7 +34,8 @@ use vars qw(@ISA @EXPORT); ...@@ -34,7 +34,8 @@ use vars qw(@ISA @EXPORT);
use libdb; use libdb;
use libtestbed; use libtestbed;
use Node; use Node;
use Port; # Doesn't seem to be used presently...
# use Port;
use English; use English;
use Data::Dumper; use Data::Dumper;
use overload ('""' => 'Stringify'); use overload ('""' => 'Stringify');
......
...@@ -35,7 +35,7 @@ SYSTEM := $(shell uname -s) ...@@ -35,7 +35,7 @@ SYSTEM := $(shell uname -s)
include $(OBJDIR)/Makeconf include $(OBJDIR)/Makeconf
SUBDIRS = checkpass ns2ir nseparse checkup template_cvsroot \ SUBDIRS = checkpass ns2ir nseparse checkup template_cvsroot \
snmpit_test snmpit_old snmpit_test snmpit_old snmpit_portfix
ifeq ($(NSVERIFY),1) ifeq ($(NSVERIFY),1)
SUBDIRS += nsverify SUBDIRS += nsverify
endif endif
...@@ -175,6 +175,9 @@ snmpit_test: ...@@ -175,6 +175,9 @@ snmpit_test:
snmpit_old: snmpit_old:
@$(MAKE) -C snmpit_old all @$(MAKE) -C snmpit_old all
snmpit_portfix:
@$(MAKE) -C snmpit_portfix all
nsverify: nsverify:
@$(MAKE) -C nsverify all @$(MAKE) -C nsverify all
...@@ -231,6 +234,7 @@ endif ...@@ -231,6 +234,7 @@ endif
@$(MAKE) -C checkup install @$(MAKE) -C checkup install
@$(MAKE) -C snmpit_test install @$(MAKE) -C snmpit_test install
@$(MAKE) -C snmpit_old install @$(MAKE) -C snmpit_old install
@$(MAKE) -C snmpit_portfix install
script-install: $(addprefix $(INSTALL_BINDIR)/, $(BIN_STUFF)) \ script-install: $(addprefix $(INSTALL_BINDIR)/, $(BIN_STUFF)) \
$(addprefix $(INSTALL_SBINDIR)/, $(SBIN_STUFF)) \ $(addprefix $(INSTALL_SBINDIR)/, $(SBIN_STUFF)) \
...@@ -343,6 +347,7 @@ subdir-clean: ...@@ -343,6 +347,7 @@ subdir-clean:
@$(MAKE) -C checkup clean @$(MAKE) -C checkup clean
@$(MAKE) -C snmpit_test clean @$(MAKE) -C snmpit_test clean
@$(MAKE) -C snmpit_old clean @$(MAKE) -C snmpit_old clean
@$(MAKE) -C snmpit_portfix clean
distclean: subdir-distclean distclean: subdir-distclean
...@@ -356,6 +361,7 @@ subdir-distclean: ...@@ -356,6 +361,7 @@ subdir-distclean:
@$(MAKE) -C checkup distclean @$(MAKE) -C checkup distclean
@$(MAKE) -C snmpit_test distclean @$(MAKE) -C snmpit_test distclean
@$(MAKE) -C snmpit_old distclean @$(MAKE) -C snmpit_old distclean
@$(MAKE) -C snmpit_portfix distclean
# #
# XXX Create non .tcl files. # XXX Create non .tcl files.
# #
......
...@@ -39,8 +39,7 @@ use libtestbed; ...@@ -39,8 +39,7 @@ use libtestbed;
use EmulabFeatures; use EmulabFeatures;
# #
# See if we use the alternate version of snmpit. Only user and # See if we use the alternate version of snmpit.
# global checks are done.
# #
my $this_user; my $this_user;
...@@ -62,6 +61,26 @@ if (EmulabFeatures->FeatureEnabled("OldSnmpit", $this_user, undef, undef)) { ...@@ -62,6 +61,26 @@ if (EmulabFeatures->FeatureEnabled("OldSnmpit", $this_user, undef, undef)) {
die("*** $0:\n". die("*** $0:\n".
" Could not exec $newpath: $!"); " Could not exec $newpath: $!");
} }
# Check feature access for both the user and the projects they belong to
# for the portfix version of portstats. The user should be a member of at least
# one project, so we will get into the foreach loop to check 'global' and
# 'user' permissions as well.
my @user_projects = ();
$this_user->ProjectMembershipList(\@user_projects);
foreach my $proj (@user_projects) {
if (EmulabFeatures->FeatureEnabled("PortfixSnmpit",
$this_user,
$proj,
undef)) {
my $newpath = "$TB/lib/snmpit_portfix/portstats";
print STDERR "Invoking alternate portstats from $newpath\n";
exec $newpath, @ARGV;
die("*** $0:\n".
" Could not exec $newpath: $!");
}
}
my $newpath = "$TB/lib/snmpit_test/portstats"; my $newpath = "$TB/lib/snmpit_test/portstats";
exec $newpath, @ARGV; exec $newpath, @ARGV;
die("*** $0:\n". die("*** $0:\n".
......
...@@ -39,8 +39,7 @@ use libtestbed; ...@@ -39,8 +39,7 @@ use libtestbed;
use EmulabFeatures; use EmulabFeatures;
# #
# See if we use the alternate version of snmpit. Only user and # See if we use the alternate version of snmpit.
# global checks are done.
# #
my $this_user; my $this_user;
...@@ -62,6 +61,26 @@ if (EmulabFeatures->FeatureEnabled("OldSnmpit", $this_user, undef, undef)) { ...@@ -62,6 +61,26 @@ if (EmulabFeatures->FeatureEnabled("OldSnmpit", $this_user, undef, undef)) {
die("*** $0:\n". die("*** $0:\n".
" Could not exec $newpath: $!"); " Could not exec $newpath: $!");
} }
# Check feature access for both the user and the projects they belong to
# for the portfix version of snmpit. The user should be a member of at least
# one project, so we will get into the foreach loop to check 'global' and
# 'user' permissions as well.
my @user_projects = ();
$this_user->ProjectMembershipList(\@user_projects);
foreach my $proj (@user_projects) {
if (EmulabFeatures->FeatureEnabled("PortfixSnmpit",
$this_user,
$proj,
undef)) {
my $newpath = "$TB/bin/snmpit_portfix";
print STDERR "Invoking alternate snmpit from $newpath\n";
exec $newpath, @ARGV;
die("*** $0:\n".
" Could not exec $newpath: $!");
}
}
my $newpath = "$TB/bin/snmpit_test"; my $newpath = "$TB/bin/snmpit_test";
exec $newpath, @ARGV; exec $newpath, @ARGV;
die("*** $0:\n". die("*** $0:\n".
......
#
# Copyright (c) 2000-2013 University of Utah and the Flux Group.
#
# {{{EMULAB-LICENSE
#
# This file is part of the Emulab network testbed software.
#
# This file is free software: you can redistribute it and/or modify it
# under the terms of the GNU Affero General Public License as published by
# the Free Software Foundation, either version 3 of the License, or (at
# your option) any later version.
#
# This file is distributed in the hope that it will be useful, but WITHOUT
# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
# FITNESS FOR A PARTICULAR PURPOSE. See the GNU Affero General Public
# License for more details.
#
# You should have received a copy of the GNU Affero General Public License
# along with this file. If not, see <http://www.gnu.org/licenses/>.
#
# }}}
#
SRCDIR = @srcdir@
TESTBED_SRCDIR = @top_srcdir@
OBJDIR = ../..
SUBDIR = tbsetup/snmpit_portfix
ISMAINSITE = @TBMAINSITE@
SYSTEM := $(shell uname -s)
include $(OBJDIR)/Makeconf
SUBDIRS =
BIN_STUFF = snmpit_portfix
LIB_STUFF = portstats snmpit_intel.pm \
snmpit_cisco.pm snmpit_lib.pm \
snmpit_cisco_stack.pm snmpit_intel_stack.pm \
snmpit_foundry.pm snmpit_stack.pm snmpit_remote.pm \
snmpit_nortel.pm snmpit_hp.pm snmpit_apcon.pm \
snmpit_arista.pm snmpit_arista_switch_daemon.py \
snmpit_mellanox.pm MLNX_XMLGateway.pm Port_portfix.pm
#
# Force dependencies on the scripts so that they will be rerun through
# configure if the .in file is changed.
#
all: $(LIB_STUFF) $(BIN_STUFF)
include $(TESTBED_SRCDIR)/GNUmakerules
install: all script-install
script-install: $(addprefix $(INSTALL_LIBDIR)/snmpit_portfix/, $(LIB_STUFF)) \
$(addprefix $(INSTALL_BINDIR)/, $(BIN_STUFF))
control-install:
fs-install:
tipserv-install:
clrhouse-install:
clean:
rm -f snmpit_arista_switch_daemon.py snmpit_remote.pm \
snmpit_portfix portstats snmpit_arista.pm
$(INSTALL_DIR)/lib/snmpit_portfix/%: %
@echo "Installing $<"
-mkdir -p $(INSTALL_DIR)/lib/snmpit_portfix
$(INSTALL) $< $@
$(INSTALL_DIR)/lib/snmpit_portfix/portstats: portstats
@echo "Installing $<"
-mkdir -p $(INSTALL_DIR)/lib/snmpit_portfix
$(INSTALL_PROGRAM) $< $@
#!/usr/bin/perl -w
#
# Copyright (c) 2013 University of Utah and the Flux Group.
#
# {{{EMULAB-LGPL
#
# This file is part of the Emulab network testbed software.
#
# This file is free software; you can redistribute it and/or modify it
# under the terms of the GNU Lesser General Public License as published by
# the Free Software Foundation; either version 2.1 of the License, or (at
# your option) any later version.
#
# This file is distributed in the hope that it will be useful, but WITHOUT
# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
# FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
# License for more details.
#
# You should have received a copy of the GNU Lesser General Public License
# along with this file. If not, see <http://www.gnu.org/licenses/>.
#
# }}}
#
# Simple test harness for the MLNX-gateway module.
use MLNX_XMLGateway;
use Getopt::Std;
use strict;
my @get_test1 = (
["name", "Basic 'get' Test #1"],
["get","/mlnxos/v1/api_version"],
["get","/mlnxos/v1/chassis/model"],
["get","/mlnxos/v1/chassis/pn"],
["get","/mlnxos/v1/chassis/fans/FAN/1/speed"],
["get","/mlnxos/v1/vsr/default_vsr/vlans/*"],
["submit"]
);
my @get_test2 = (
["name","Interface name 'get' Test #2"],
["get","/mlnxos/v1/vsr/default_vsr/interfaces_by_name/*"],
["submit"]
);
my @pget_test1 = (
["name", "Port 'get' Test (Eth1/8) #1"],
["get","/mlnxos/v1/vsr/default_vsr/interfaces/101/enabled"],
["get","/mlnxos/v1/vsr/default_vsr/interfaces/101/type"],
["get","/mlnxos/v1/vsr/default_vsr/interfaces/101/mtu"],
["get","/mlnxos/v1/vsr/default_vsr/interfaces/101/vlans/pvid"],
["get","/mlnxos/v1/vsr/default_vsr/interfaces/101/vlans/mode"],
["get","/mlnxos/v1/vsr/default_vsr/interfaces/101/vlans/allowed/*"],
["get","/mlnxos/v1/vsr/default_vsr/interfaces/101/physical_location"],
["get","/mlnxos/v1/vsr/default_vsr/interfaces/101/supported_speed"],
["get","/mlnxos/v1/vsr/default_vsr/interfaces/101/configured_speed"],
["get","/mlnxos/v1/vsr/default_vsr/interfaces/101/actual_speed"],
["get","/mlnxos/v1/vsr/default_vsr/interfaces/101/lag/membership"],
["submit"]
);
my @pget_test2 = (
["name", "Port 'get' Test (Po1) #2"],
["get","/mlnxos/v1/vsr/default_vsr/interfaces/13826/enabled"],
["get","/mlnxos/v1/vsr/default_vsr/interfaces/13826/type"],
["get","/mlnxos/v1/vsr/default_vsr/interfaces/13826/vlans/pvid"],
["get","/mlnxos/v1/vsr/default_vsr/interfaces/13826/vlans/mode"],
["get","/mlnxos/v1/vsr/default_vsr/interfaces/13826/vlans/allowed/*"],
["submit"]
);
my @vlan_test1 = (
["name", "Vlan Creation Test #1"],
["action","/mlnxos/v1/vsr/default_vsr/vlans/add",{vlan_id => 666}],
["set-modify","/mlnxos/v1/vsr/default_vsr/vlans/666/name=testvlan"],
["get","/mlnxos/v1/vsr/default_vsr/vlans/*"],
["submit"],
["action","/mlnxos/v1/vsr/default_vsr/vlans/delete",{vlan_id => 666}],
["get","/mlnxos/v1/vsr/default_vsr/vlans/*"],
["submit"]
);
my @port_test1 = (
["name", "Port Toggle Test (Eth1/8) #1"],
["set-modify","/mlnxos/v1/vsr/default_vsr/interfaces/101/enabled=false"],
["get","/mlnxos/v1/vsr/default_vsr/interfaces/101/enabled"],
["submit"],
["set-modify","/mlnxos/v1/vsr/default_vsr/interfaces/101/enabled=true"],
["get","/mlnxos/v1/vsr/default_vsr/interfaces/101/enabled"],
["submit"]
);
my @vport_test1 = (
["name", "Vlan + Port Test (Eth1/8) #1"],
["action","/mlnxos/v1/vsr/default_vsr/vlans/add",{vlan_id => 666}],
["set-modify","/mlnxos/v1/vsr/default_vsr/vlans/666/name=testvlan"],
["set-modify","/mlnxos/v1/vsr/default_vsr/interfaces/101/vlans/pvid=666"],
["get","/mlnxos/v1/vsr/default_vsr/vlans/*"],
["get","/mlnxos/v1/vsr/default_vsr/interfaces/101/vlans/pvid"],
["submit"],
["action","/mlnxos/v1/vsr/default_vsr/vlans/delete",{vlan_id => 666}],
["set-modify","/mlnxos/v1/vsr/default_vsr/interfaces/101/vlans/pvid=53"],
["get","/mlnxos/v1/vsr/default_vsr/vlans/*"],
["get","/mlnxos/v1/vsr/default_vsr/interfaces/101/vlans/pvid"],
["submit"]
);
my @trunk_test1 = (
["name", "Trunk Test (Eth1/8) #1"],
["action","/mlnxos/v1/vsr/default_vsr/vlans/add",{vlan_id => 666}],
["set-modify","/mlnxos/v1/vsr/default_vsr/vlans/666/name=testvlan1"],
["action","/mlnxos/v1/vsr/default_vsr/vlans/add",{vlan_id => 777}],
["set-modify","/mlnxos/v1/vsr/default_vsr/vlans/666/name=testvlan2"],
["set-modify","/mlnxos/v1/vsr/default_vsr/interfaces/101/vlans/mode=trunk"],
["action","/mlnxos/v1/vsr/default_vsr/interfaces/101/vlans/allowed/add",{vlan_ids => "666"}],
["action","/mlnxos/v1/vsr/default_vsr/interfaces/101/vlans/allowed/add",{vlan_ids => "777"}],
["submit"],
["get","/mlnxos/v1/vsr/default_vsr/interfaces/101/vlans/allowed/*"],
["get","/mlnxos/v1/vsr/default_vsr/interfaces/101/vlans/mode"],
["submit"],
["action","/mlnxos/v1/vsr/default_vsr/interfaces/101/vlans/allowed/delete",{vlan_ids => "666"}],
["action","/mlnxos/v1/vsr/default_vsr/interfaces/101/vlans/allowed/delete",{vlan_ids => "777"}],
["set-modify","/mlnxos/v1/vsr/default_vsr/interfaces/101/vlans/mode=access"],
["action","/mlnxos/v1/vsr/default_vsr/vlans/delete",{vlan_id => 666}],
["action","/mlnxos/v1/vsr/default_vsr/vlans/delete",{vlan_id => 777}],
["submit"]
);
# List the tests to run here.
my @testsets = (\@pget_test1,);
my %opts = ();
if (!getopts("a:d:",\%opts)) {
print "Usage: $0 -a <uri_auth_string> -d <level>\n";
exit 1;
}
my $auth = "";
my $debug = 0;
$auth = $opts{'a'} or die "Must specify an auth string!";
$debug = $opts{'d'} if $opts{'d'};
my $gateway = MLNX_XMLGateway->new($auth);
$gateway->debug($debug) if $debug;
foreach my $tlist (@testsets) {
my @cmdset = ();
my @results = ();
my $testname = "unnamed";
foreach my $cmd (@{$tlist}) {
TESTSW1: for ((@{$cmd})[0]) {
/^name$/ && do {
$testname = (@{$cmd})[1];
print "========== Running Test: $testname ==========\n";
last TESTSW1;
};
/^submit$/ && do {
push @results, $gateway->call(\@cmdset);
@cmdset = ();
last TESTSW1;
};
# Default
push @cmdset, $cmd;
}
}
print "--- Results:\n";
my $i = 1;
foreach my $reslist (@results) {
print "* Submission $i:\n";
foreach my $res (@$reslist) {
print "@$res\n";
}
++$i;
}
print "\n";
}
#!/usr/bin/perl -w
#
# Copyright (c) 2013 University of Utah and the Flux Group.
#
# {{{EMULAB-LGPL
#
# This file is part of the Emulab network testbed software.
#
# This file is free software; you can redistribute it and/or modify it
# under the terms of the GNU Lesser General Public License as published by
# the Free Software Foundation; either version 2.1 of the License, or (at
# your option) any later version.
#
# This file is distributed in the hope that it will be useful, but WITHOUT
# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
# FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
# License for more details.
#
# You should have received a copy of the GNU Lesser General Public License
# along with this file. If not, see <http://www.gnu.org/licenses/>.
#
# }}}
#
# Mellanox XML-Gateway handler class. Hides all of the connection
# management, XML method invocation, and response parsing goo from the caller.
package MLNX_XMLGateway;
use URI;
use LWP::UserAgent;
use LWP::ConnCache;
use XML::LibXML;
use strict;
$| = 1; # Turn off line buffering on output
my $DEBUG = 0;
my $MLNX_GATEWAY_PATH = "/xtree";
my $MLNX_AUTH_PATH = '/admin/launch?script=rh&template=login&action=login';
my $MLNX_CHECK_RPATH = "/mlnxos/v1/chassis/model";
my %MLNX_ACTIONS = ("action" => 1,
"get" => 1,
"set-create" => 1,
"set-modify" => 1,
"set-delete" => 1);
#
# Create a new Mellanox XML-Gateway object. $authority is an authority
# component for an HTTP URI. e.g., 'user:pass@hostname[:port]'
#
# user, password, and hostname components are required. Port is optional.
#
sub new($$) {
my ($class,$authority) = @_;
my $self = {};
my ($user,$pass);
# User needs to pass in the authority string.
defined($authority) or die "Must supply an authority string.";
# Construct URI from input argument, and extract username/password.
my $uri = URI->new();
$uri->scheme('http');
$uri->authority($authority);
my $uinfo = $uri->userinfo();
if (defined($uinfo) && $uinfo =~ /^(.+):(.+)$/) {
$user = $1;
$pass = $2;
} else {
die "Username and password must be present in URI authority string.";
}
$uri->userinfo(''); # clear user/pass from the URI now that we have it.
$uri->path($MLNX_GATEWAY_PATH); # Tack on the API entry point path.
$self->{'AUTHORITY'} = $authority;
$self->{'URI'} = $uri;
$self->{'USER'} = $user;
$self->{'PASS'} = $pass;
$self->{'CONN'} = undef;
bless($self, $class);
return $self;
}
# Ensure all of the objects we are storing get de-allocated when an instance
# of this class goes away.
sub DESTROY($) {
my ($self,) = @_;
$self->{'AUTHORITY'} = undef;
$self->{'URI'} = undef;
$self->{'USER'} = undef;
$self->{'PASS'} = undef;
$self->{'CONN'} = undef;
}
#
# Set/unset/query debug level
#
sub debug($;$) {
my ($self,$level) = @_;
if (defined($level)) {
$level =~ /^\d+$/ or
die "Debug level must be a positive integer or zero!";
$DEBUG = $level;
}
return $DEBUG;
}
#
# Debug print wrapper function
#
sub debugpr($;$) {
my ($msg, $level) = @_;
# Default to debug level '1' if not specified.
$level ||= 1;
if ($DEBUG >= $level) {
print $msg;
}
}
#
# Pretty print a parsed XML::LibXML DOM object. Requires a separate
# perl module. Assumes you are passing in a valid DOM object!
#
sub XMLPrettyPrint($) {
my ($xmldom,) = @_;
my $retstr;
eval { require XML::LibXML::PrettyPrint };
if ($@) {
$retstr = "-> Can't pretty print: XML::LibXML::PrettyPrint not found.";
} else {
my $pp = XML::LibXML::PrettyPrint->new(indent_string => " ");