File Coverage

blib/lib/Net/Brcd.pm

Criterion	Covered	Total	%
statement	27	291	9.2
branch	0	122	0.0
condition	0	38	0.0
subroutine	9	35	25.7
pod	22	24	91.6
total	58	510	11.3

#!/usr/local/bin/perl
# @(#)Brcd.pm	1.5

package Net::Brcd;

use 5.008;
use Carp;
use Data::Dumper;
use Socket;

use strict;
use constant DEBUG => 0;

use base qw(Exporter);

# Variables de gestion du package
our $VERSION      = 1.13;

# Variables privées
my $_brcd_wwn_re     = join(":",("[0-9A-Za-z][0-9A-Za-z]") x 8);
my $_brcd_port_id    = qr/\d+,\d+/;

sub new {
    my ($class)=shift;

    $class   = ref($class) || $class;
    my $self = {};

    bless $self, $class;
    return $self;
}

sub connect {
    my ($self,$switch,$user,$pass)=@_;

    $user   ||= $ENV{BRCD_USER} || 'admin';
    $pass   ||= $ENV{BRCD_PASS};
    $switch ||= $ENV{BRCD_SWITCH};

    unless ($switch) {
        croak __PACKAGE__,": Need switch \@IP or name.\n";
    }
    unless ($user and $pass) {
        croak __PACKAGE__,": Need user or password.\n";
    }
    $self->{FABRICS}->{$switch} = {};
    $self->{FABRIC}             = $switch;
    $self->{USER}               = $user;

    return $self->proto_connect($switch,$user,$pass);
}

sub proto_connect {
    my ($self,$switch,$user,$pass) = @_;

    croak __PACKAGE__, "Error - proto_connect is a virtual function.\n";
}

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

    croak __PACKAGE__, "Error - cmd is a virtual function.\n";
}

sub sendcmd {
    my ($self, $cmd, @cmd)=@_;

    croak __PACKAGE__, "Error - sendcmd is a virtual function.\n";
}

sub sendeof {
    my ($self, $cmd, @cmd)=@_;

    croak __PACKAGE__, "Error - sendeof is a virtual function.\n";
}

sub readline {
    my ($self, $arg_ref) = @_;

    croak __PACKAGE__, "Error - readline is a virtual function.\n";
}

sub cfgSave {
    my $self = shift;
    my %args = (
        -verbose => 0,
        @_,
    );
    my @rc   = $self->cmd('cfgSave');

    my $rc = '';
    SWITCH: {
        DEBUG && warn "DEBUG:cfgsave", Dumper(\@rc);
        unless (@rc) {
            last SWITCH;
        }
        if ($args{-verbose}) {
            warn join("\n", @rc), "\n";
        }
        $rc   = pop @rc;
        return 1 if ($rc =~ m/Nothing/i); # Pas de modif
        return 1 if ($rc =~ m/Updating/i); # Update fait
    }

    croak "Error - Cannot save current configuration: $rc.\n";
}

sub aliShow {
    my $self=shift;

    my %args=(
          -bywwn    =>  0,
          -byport   =>  0,
          -cache    =>  0,
          -onlywwn  =>  1,
          -filter   =>  '*',
          @_
          );

    my $fab_name = $self->{FABRIC};
    my $fab      = $self->{FABRICS}->{$fab_name};
    $args{-onlywwn} = 0 if $args{-byport};

    my ($alias);
    $fab->{PORTID} = {};
    $fab->{WWN}    = {};
    $fab->{ALIAS}  = {};
    foreach ($self->cmd('aliShow "' . $args{-filter} . '"')) {
        next unless $_;
        if (m/alias:\s+(\w+)/) {
            $alias=$1;
            next;
        }
        if ($alias && m/${_brcd_wwn_re}/) {
            s/^\s*//; # on enleve les blancs de devant
            DEBUG && warn "DEBUG: aliShow: $alias: $_\n";
            my @wwn_for_alias = split m/\s*;\s*/;
            foreach my $wwn (@wwn_for_alias) {
                $fab->{WWN}->{$wwn}     = $alias;
            }
            if (exists $fab->{ALIAS}->{$alias}) {
                my $old_alias_value = $fab->{ALIAS}->{$alias};
                unless (ref $old_alias_value) {
                    $fab->{ALIAS}->{$alias} = [$old_alias_value];
                }
                push @{$fab->{ALIAS}->{$alias}}, @wwn_for_alias;
            } else {
                $fab->{ALIAS}->{$alias} = (@wwn_for_alias == 1) ? $wwn_for_alias[0]
                                                                : \@wwn_for_alias;
            }

            next;
        }

        next if $args{-onlywwn};

        if ($alias && m/(${_brcd_port_id})/) {
            my $port_id = $1;
            $fab->{PORTID}->{$port_id} = $alias;
            $fab->{ALIAS}->{$alias}    = $port_id;
            next;
        }
    }
    #}
    DEBUG && warn "DEBUG:zone.?:", Dumper($fab);

    return ($args{'-bywwn'})  ? (%{$fab->{WWN}})    :
           ($args{'-byport'}) ? (%{$fab->{PORTID}}) :
                                (%{$fab->{ALIAS}});
}

sub zoneShow {
    my $self = shift;

    my %args = (
          -bymember => 0,
          -cache    => 0,
          -filter   => '*',
          @_
          );

    my $fab_name = $self->{FABRIC};
    my $fab      = $self->{FABRICS}->{$fab_name};

    my ($zone);
    foreach ($self->cmd('zoneShow "' . $args{-filter} . '"')) {
        DEBUG && warn "DEBUG:CMDDUMP: $_\n";
        if (m/zone:\s+(\w+)/) {
            $zone = $1;
            next;
        }
        if ($zone && m/\s*(\w[:\w\s;]+)/) {
            my $members = $1;
            my @member  = split m/;\s+/, $members;

            foreach my $member (@member) {
                $fab->{ZONE}->{$zone}->{$member}++;
                $fab->{MEMBER}->{$member}->{$zone}++;
            }
        }
    }

    unless ($fab->{MEMBER} and $fab->{ZONE}) {
        croak "Warning - Empty zone.\n";
    }

    if (wantarray()) {
        return ($args{'-bymember'})?(%{$fab->{MEMBER}}):(%{$fab->{ZONE}});
    }
}

sub zoneMember {
    my ($self, $zone)=@_;

    my $fab_name = $self->{FABRIC};
    my $fab      = $self->{FABRICS}->{$fab_name};

    return unless exists $fab->{ZONE}->{$zone};

    return sort keys %{$fab->{ZONE}->{$zone}};
}

sub memberZone {
    my ($self,$member)=@_;

    my $fab_name = $self->{FABRIC};
    my $fab      = $self->{FABRICS}->{$fab_name};

    return unless exists $fab->{MEMBER}->{$member};

    return sort keys %{$fab->{MEMBER}->{$member}};
}

sub switchShow {
    my $self=shift;

    my %args=(
          -bywwn        => 0,
          -withportname => 0,
          -byslot       => 0,
          @_
          );

    my $fab_name = $self->{FABRIC};
    my $fab      = $self->{FABRICS}->{$fab_name};

    my (%wwn);
    foreach ($self->cmd("switchShow")) {
        next unless $_;
DEBUG && warn  "SWITCHSHOW   : $_\n";
        if (m/^(\w+):\s+(.+)/) {
            $fab->{$1} = $2;
            next;
        }
#12000 :  0    1    0   id    2G   Online    E-Port  (Trunk port, master is Slot  1 Port
#48000 : 13    1   13   0a0d00   id    N2   Online           F-Port  10:00:00:00:c9:35:99:4b
#48000 : 12    1   12   0a0c00   id    N4   No_Light
#4100  :       0   0            id    2G   Online    E-Port  10:00:00:05:1e:35:f6:e5 "PS4100A"
#5100  :       0   0   010000   id    N4   Online      FC  F-Port  50:0a:09:81:98:4c:a8:9d
#5100  :       1   1   010100   id    N4   No_Light    FC
#3800  : port  0: id 2G Online         F-Port 50:06:01:60:10:60:04:26

        if (m{
            ^[port\s]*(\d+):? \s*     # Le port number forme ok:port 1: ; 12;144
            (?:
                (?:
                  (\d{1,3})\s+        # Le slot que sur les directeurs
                )?
                (\d{1,3})             # Le port dans le slot
                \s*
                (
                [0-9a-zA-Z]
                [0-9a-zA-Z]
                [0-9a-zA-Z]
                [0-9a-zA-Z]
                [0-9a-zA-Z]
                [0-9a-zA-Z]
                )?              # Adresse FC, qu'à partir de FabOS 5.2.0a
            )?
            \s+ [i-][d-] \s+             # Le mot magique qui dit que c'est la bonne ligne
            [a-zA-Z]*(\d+)[a-zA-Z]*  \s+ # Vitesse du port plusieurs format à priori toujours en Go/s
            (\w+)  \s*                   # Status du port
            (.*)                         # Toutes les autres informations (notamment le WWN si connectés)
        }mxs) {
DEBUG && warn  "SWITCHSHOW-RE: #$1# #$2# #$3# #$4# #$5# #$6# #$7#\n";
            # Récupération des champs, les champs dans les même ordre que les $
            my @fields = qw(SLOT NUMBER ADDRESS SPEED STATUS INFO);
            my $port_number  = $1;
            my $port_info    = $7;
            foreach my $re ($2, $3, $4, $5, $6, $7) {
                my $field = shift @fields;
                if (defined $re) {
                    $fab->{PORT}->{$port_number}->{$field} = $re;
                }
            }
            $fab->{PORT}->{$port_number}->{PORTNAME} = $self->portShow($port_number) if $args{-withportname};
            $fab->{SLOTN}->{
                (($fab->{PORT}->{$port_number}->{SLOT}) ? $fab->{PORT}->{$port_number}->{SLOT} . '/'
                :                                        "")
                . $fab->{PORT}->{$port_number}->{NUMBER}
            }->{PORT} = $port_number;

            if ($port_info and $port_info =~ m/^(\w-\w+)\s+(${_brcd_wwn_re})?/) {
                my ($type, $wwn) = ($1,$2);
                $fab->{PORT}->{$port_number}->{TYPE} = $type;
                $fab->{PORT}->{$port_number}->{WWN}  = $wwn   if $wwn;


                if ($type eq "F-Port") {
                    $wwn{$wwn} = $port_number;
                }
            }
        } else {
            DEBUG && warn "DEBUG:???? >>$_<<\n";
        }
    }

    return   ($args{'-bywwn'})       ? %wwn
           : ($args{'-byslot'})      ? %{$fab->{SLOTN}}
           : (exists $fab->{PORT})   ? %{$fab->{PORT}}
           :                           undef;
}

sub toSlot {
    my $self        = shift;
    my $port_number = shift;

    my $fab_name = $self->{FABRIC};
    my $fab      = $self->{FABRICS}->{$fab_name};

DEBUG && warn "TOSLOT: $port_number\n";

    unless (exists $fab->{PORT}->{$port_number}) {
        $@ = __PACKAGE__.":toSlot: port number $port_number does not exist\n";

DEBUG && warn "$@\n";

        return;
    }
    unless (exists $fab->{PORT}->{$port_number}->{SLOT}) {

        $@ = __PACKAGE__.":toSlot: port number $port_number is not a director\n";
DEBUG && warn "$@\n";

        return;
    }

DEBUG && warn "TOSLOT: ",$fab->{PORT}->{$port_number}->{SLOT}."/".$fab->{PORT}->{$port_number}->{NUMBER},"\n";

    return (wantarray())?($fab->{PORT}->{$port_number}->{SLOT},$fab->{PORT}->{$port_number}->{NUMBER}):
                          $fab->{PORT}->{$port_number}->{SLOT}."/".$fab->{PORT}->{$port_number}->{NUMBER};
}

sub portShow {
    my $self        = shift;
    my $port_number = shift;

    my $fab_name = $self->{FABRIC};
    my $fab      = $self->{FABRICS}->{$fab_name};

DEBUG && warn "PORTSHOW-PORTNUMBER:test: $port_number\n";
    $port_number = $self->toSlot($port_number) || $port_number;
DEBUG && warn "PORTSHOW-PORTNUMBER:set: $port_number\n";
    my (%port, $param, $value, $portname);

    no warnings;
    foreach ($self->cmd("portShow $port_number")) {
DEBUG && warn "PORTSHOW:parse: $_\n";

        if (m/^([\w\s]+):\s+(.+)/) {
            $param        = $1;
            $value        = $2;

DEBUG && warn "PORTSHOW: param #$param# value #$value#\n";

            $port{$param} = $value;
            SWITCH: {
                if ($param eq 'portName') {
                    $fab->{SLOTN}->{$port_number}->{PORTNAME} = $value;
                    $portname                                 = $value;
                    last SWITCH;
                }
            }
            next;
        }

        if (m/^([\w\s]+):\s*$/) {
            $param = $1;
            next;
        }

        if (m/^\s+(.+)/) {
            $port{$param} = $1;
            next;
        }
    }
    use warnings;

    return (wantarray())?(%port):($portname);
}

sub output {
    my $self=shift;

    return join("\n",@{$self->{OUTPUT}})."\n";
}

sub wwn_re {
    return ${_brcd_wwn_re};
}

sub fabricShow {
    my $self=shift;
    my %args=(
          -bydomain        => 0,
          @_
          );
    my (%fabric,%domain);

    foreach ($self->cmd('fabricShow')) {
        next unless $_;
DEBUG && warn "DEBUG:: $_\n";
        if (m{
            ^\s* (\d+) : \s+ \w+ \s+  # Domain id + identifiant FC
            ${_brcd_wwn_re} \s+       # WWN switch
            (\d+\.\d+\.\d+\.\d+) \s+  # Adresse IP switch
            \d+\.\d+\.\d+\.\d+   \s+  # Adresse IP FC switch (FCIP)
            (>?)"([^"]+)              # Master, nom du switch
        }msx) {
            my ($domain_id, $switch_ip, $switch_master, $switch_name) = ($1, $2, $3, $4);
            my $switch_host = gethostbyaddr(inet_aton($switch_ip), AF_INET);
            my @fields      = qw(DOMAIN IP MASTER FABRIC NAME MASTER);
            foreach my $re ($domain_id, $switch_ip, $switch_master, $switch_host, $switch_name) {
                my $field = shift @fields;
                if ($re) {
                    $domain{$domain_id}->{$field}   = $re;
                    $fabric{$switch_name}->{$field} = $re;
                }
            }

            $fabric{$switch_host} = $switch_name if $switch_host;
        }
    }

    return ($args{-bydomain}) ? (%domain) :
                                (%fabric);
}

sub currentFabric {
    my $self = shift;

    return $self->{FABRIC};
}


sub isWwn {
    my $self = shift;
    my $wwn = shift;

    ($wwn =~ m/^${_brcd_wwn_re}/)?(return 1):(return);

}

sub portAlias {
    my $self = shift;
    my $port_alias = shift;

    if ($port_alias =~ m/(\d+),(\d+)/){
        return ($1, $2);
    }
    return;
}

sub rename {
    my ($self, $old_zone_object, $new_zone_object) = @_;

    unless ($old_zone_object and $new_zone_object) {
        croak "Error - Need old and new name.\n";
    }

    return $self->cmd("zoneObjectRename $old_zone_object, $new_zone_object");
}

sub _zoning_cmd {
    my ($self, $cmd_name, $zone_object, @cmd_args) = @_;

    unless ($cmd_name) {
        croak "Error - Need command name.\n";
    }
    unless ($zone_object) {
        croak "Error - Need object name.\n";
    }

    my $cmd = "$cmd_name $zone_object";
    my $str_args;
    if (@cmd_args == 1) {
        $str_args = shift @cmd_args;
        if (ref $str_args eq 'ARRAY') {
            $str_args = join(';', @{$str_args});
        }
    } elsif (@cmd_args) {
        $str_args = join(';', @{$str_args});
    }
    if ($str_args) {
        $cmd .= ", \"$str_args\"";
    }

    return $self->cmd($cmd);
}

sub _build_cmd_name {
    my ($prefix, $args_ref) = @_;

    my @exclude = (
        '^-name',
        '^-members',
    );
    my $action;
    ARG_CMD: foreach my $arg (keys %{$args_ref}) {
        next unless ($args_ref->{$arg});
        foreach my $exclude (@exclude) {
            if ($arg =~ m/$exclude/) {
                next ARG_CMD;
            }
        }
        $arg    =~ s/^[-]*//;
        $action = $arg;
    }
    unless ($action) {
        croak "Error - cannot find action.\n";
    }

    return $prefix . $action;
}

sub zone {
    my $self = shift;

    my %args = (
        -create  => 0,
        -add     => 0,
        -delete  => 0,
        -remove  => 0,
        -name    => "",
        -members => "",
        @_,
    );
    my $cmd_name = _build_cmd_name('zone', \%args);

    return $self->_zoning_cmd($cmd_name, $args{-name}, $args{-members});
}

sub ali {
    my $self = shift;

    my %args = (
        -create  => 0,
        -add     => 0,
        -delete  => 0,
        -remove  => 0,
        -name    => "",
        -members => "",
        @_,
    );
    my $cmd_name = _build_cmd_name('ali', \%args);

    DEBUG && warn "DEBUG:ALI:", Dumper($cmd_name, \%args);

    return $self->_zoning_cmd($cmd_name, $args{-name}, $args{-members});
}


1;

__END__