File Coverage

blib/lib/FTN/Addr.pm

Criterion	Covered	Total	%
statement	88	115	76.5
branch	39	78	50.0
condition	24	66	36.3
subroutine	21	25	84.0
pod	18	21	85.7
total	190	305	62.3

#!/usr/bin/perl
package FTN::Addr;
our $VERSION = '20090704';

use strict;
use warnings;
#use base = qw(Exporter);
#our @EXPORT = ();
#our @EXPORT_OK = ();

use Carp qw(croak);

use overload
  "eq" => \&eq_,
  "cmp" => \&cmp_,
  fallback => 1;

my $default_domain = "fidonet";

sub set_results($) {
  my $t = shift;
  $t -> {full4d} = "$t->{zone}:$t->{net}/$t->{node}.$t->{point}";
  $t -> {full5d} = $t -> {full4d} . "\@$t->{domain}";
  $t -> {short4d} = "$t->{zone}:$t->{net}/$t->{node}" . ($t -> {point}? ".$t->{point}" : '');
  $t -> {short5d} = $t -> {short4d} . "\@$t->{domain}";
  $t -> {fqfa} = "$t->{domain}#$t->{zone}:$t->{net}/$t->{node}.$t->{point}";
  $t -> {brake_style} = "$t->{domain}.$t->{zone}.$t->{net}.$t->{node}.$t->{point}";
}

sub new($$;$) {
  my $either = shift;
  my $class = ref($either) || $either;
  my $addr = shift;
  my $base_addr = shift;
  $base_addr = undef unless defined($base_addr) && ref($base_addr) && $base_addr -> isa('FTN::Addr');

  if (ref $either) {
    %$either = ();
  } else {
    $either = {};
  }

  # let's figure domain
  if ($addr =~ m!(\w+)#([\d:/.]+)!) { # fidonet#2:451/31.0
    $either -> {domain} = $1;
    $addr = $2;
  } elsif ($addr =~ m!([\d:/.]+)@(\w+)!) { # 2:451/31.0@fidonet
    $either -> {domain} = $2;
    $addr = $1;
  } elsif ($addr =~ m!(\w+)\.(\d+\.\d+\.\d+\.\d+)!) { # fidonet.2.451.31.0
    $either -> {domain} = $1;
    $addr = $2;
  } else {
    $either -> {domain} = $base_addr? $base_addr -> {domain} : $default_domain;
  }

  # and the rest of the address
  if ($addr =~ m!^(\d+):(\d+)/(\d+)\.?(\d*)$!) { # 2:451/31.0 or 2:451/31
    $either -> {zone} = $1;
    $either -> {net} = $2;
    $either -> {node} = $3;
    $either -> {point} = $4 || 0;
  } elsif ($addr =~ m!^\.(\d+)$!) { # addr as .4
    if ($base_addr) {
      $either -> {zone} = $base_addr -> zone;
      $either -> {net} = $base_addr -> net;
      $either -> {node} = $base_addr -> node;
      $either -> {point} = $1;
    } else {			# no base addr - no way to get full addr...
      return undef;
    }
  } elsif ($addr =~ m!^(\d+)\.?(\d*)$!) { # addr as 31 or 31.6
    if ($base_addr) {
      $either -> {zone} = $base_addr -> zone;
      $either -> {net} = $base_addr -> net;
      $either -> {node} = $1;
      $either -> {point} = $2 || 0;
    } else {			# no base addr - no way to get full addr...
      return undef;
    }
  } elsif ($addr =~ m!^(\d+)/(\d+)\.?(\d*)$!) { # addr as 451/31 or 451/31.6
    if ($base_addr) {
      $either -> {zone} = $base_addr -> zone;
      $either -> {net} = $1;
      $either -> {node} = $2;
      $either -> {point} = $3 || 0;
    } else {			# no base addr - no way to get full addr...
      return undef;
    }
  } elsif ($addr =~ m!^(\d+)\.(\d+)\.(\d+)\.(\d+)$!) { # addr as 2.451.31.0 - brake style
    $either -> {zone} = $1;
    $either -> {net} = $2;
    $either -> {node} = $3;
    $either -> {point} = $4;
  } else {
    return undef;
  }

  # some checking for correctness...
  unless (1 <= $either -> {zone} && $either -> {zone} <= 32767 # FRL-1002.001
	  && 1 <= $either -> {net} && $either -> {net} <= 32767 # FRL-1002.001
	  && -1 <= $either -> {node} && $either -> {node} <= 32767 # FRL-1002.001
	  && 0 <= $either -> {point} && $either -> {point} <= 32767 # FRL-1002.001
	  && length($either -> {domain}) <= 8 # FRL-1002.001
	  && index($either -> {domain}, '.') == -1) { # FRL-1002.001
    %$either = ();
    return undef;
  }

  set_results($either);
  bless $either, $class;
}

sub domain($) {
  ref(my $inst = shift) or croak "I'm only instance method!";
  $inst -> {domain};
}

sub set_domain($$) {
  ref(my $inst = shift) or croak "I'm only instance method!";
  my $d = shift;
  $inst -> {domain} = $d || $default_domain;
  set_results($inst);
}

sub zone($) {
  ref(my $inst = shift) or croak "I'm only instance method!";
  $inst -> {zone};
}

sub set_zone($$) {
  ref(my $inst = shift) or croak "I'm only instance method!";
  $inst -> {zone} = shift;
  set_results($inst);
}

sub net($) {
  ref(my $inst = shift) or croak "I'm only instance method!";
  $inst -> {net};
}

sub set_net($$) {
  ref(my $inst = shift) or croak "I'm only instance method!";
  $inst -> {net} = shift;
  set_results($inst);
}

sub node($) {
  ref(my $inst = shift) or croak "I'm only instance method!";
  $inst -> {node};
}

sub set_node($$) {
  ref(my $inst = shift) or croak "I'm only instance method!";
  $inst -> {node} = shift;
  set_results($inst);
}

sub point($) {
  ref(my $inst = shift) or croak "I'm only instance method!";
  $inst -> {point};
}

sub set_point($$) {
  ref(my $inst = shift) or croak "I'm only instance method!";
  $inst -> {point} = shift;
  set_results($inst);
}

sub f4 {
  ref(my $inst = shift) or croak "I'm only instance method!";
  $inst -> {full4d};
}

sub s4 {
  ref(my $inst = shift) or croak "I'm only instance method!";
  $inst -> {short4d};
}

sub f5 {
  ref(my $inst = shift) or croak "I'm only instance method!";
  $inst -> {full5d};
}

sub s5 {
  ref(my $inst = shift) or croak "I'm only instance method!";
  $inst -> {short5d};
}

sub fqfa {
  ref(my $inst = shift) or croak "I'm only instance method!";
  $inst -> {fqfa};
}

sub bs {
  ref(my $inst = shift) or croak "I'm only instance method!";
  $inst -> {brake_style};
}

sub eq_ {			# eq operator
  return undef unless $_[1] -> isa('FTN::Addr');
  return lc($_[0] -> domain) eq lc($_[1] -> domain)
    && $_[0] -> zone == $_[1] -> zone && $_[0] -> net == $_[1] -> net
    && $_[0] -> node == $_[1] -> node && $_[0] -> point == $_[1] -> point;
}

sub cmp_ {			# cmp operator
  return undef unless $_[1] -> isa('FTN::Addr');
  if ($_[2]) {			# arguments were swapped
    lc($_[1] -> domain) cmp lc($_[0] -> domain) || $_[1] -> zone <=> $_[0] -> zone
      || $_[1] -> net <=> $_[0] -> net || $_[1] -> node <=> $_[0] -> node || $_[1] -> point <=> $_[0] -> point;
  } else {
    lc($_[0] -> domain) cmp lc($_[1] -> domain) || $_[0] -> zone <=> $_[1] -> zone
      || $_[0] -> net <=> $_[1] -> net || $_[0] -> node <=> $_[1] -> node || $_[0] -> point <=> $_[1] -> point;
  }
}

sub equal($$$) {
  ref(my $class = shift) and croak "I'm only class method!";
  return undef unless $_[0] -> isa('FTN::Addr');
  eq_(@_);
}

1;
__END__