File Coverage

blib/lib/Ed2k_link.pm

Criterion	Covered	Total	%
statement	53	210	25.2
branch	12	144	8.3
condition	2	51	3.9
subroutine	14	27	51.8
pod	15	18	83.3
total	96	450	21.3

#!/usr/bin/perl
package Ed2k_link;
our $VERSION = '20090428';

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

use Carp qw(croak);
use File::Basename qw();
use URI::Escape;
use Digest::MD4 qw(md4_hex);
use Digest::SHA1 qw(sha1);

use constant {
  CHANK_SIZE => 9_728_000,
  BLOCK_SIZE => 184_320,
};

sub encode_base32 {
  my %bits_to_char = qw# 00000 A 00001 B 00010 C 00011 D 00100 E 00101 F 00110 G 00111 H
			 01000 I 01001 J 01010 K 01011 L 01100 M 01101 N 01110 O 01111 P
			 10000 Q 10001 R 10010 S 10011 T 10100 U 10101 V 10110 W 10111 X
			 11000 Y 11001 Z 11010 2 11011 3 11100 4 11101 5 11110 6 11111 7
		       #;
  my ($source, $bits, $res) = shift;
  $bits .= unpack('B*', substr($source, $_, 1)) for 0 .. length($source) - 1;
  # generally $bits could be not 40 * k length and have to be padding. but not in our case
  $res .= $bits_to_char{$&} while $bits =~ m/.{5}/g;
  $res;
}

sub define_base_trees_orientation { # l/r, array_ref, start_idx, end_idx
  if ($_[2] - $_[3] >= 0) {
    $_[1][$_[2]] = $_[0];
  } elsif ($_[2] + 1 == $_[3]) {
    $_[1][$_[2]] = 'l';
    $_[1][$_[3]] = 'r';
  } else {
    my $med = sprintf("%d", ($_[2] + $_[3]) / 2);
    $med-- if $_[0] eq 'r' && $_[2] + $_[3] == $med * 2;
    &define_base_trees_orientation('l', $_[1], $_[2], $med++);
    &define_base_trees_orientation('r', $_[1], $med, $_[3]);
  }
}

sub get_root_hash {		# l/r, array_ref, start_idx, end_idx
  my $med = $_[3];
  if ($_[2] - $_[3] >= 0) {
    return;
  } elsif ($_[3] - $_[2] > 1) {
    $med = sprintf("%d", ($_[2] + $_[3]) / 2);
    $med-- if $_[0] eq 'r' && $_[2] + $_[3] == $med * 2;
    &get_root_hash('l', $_[1], $_[2], $med++);
    &get_root_hash('r', $_[1], $med, $_[3]);
  }
  $_[1] -> [$_[2]] = sha1($_[1] -> [$_[2]], $_[1] -> [$med]);
}

sub from_file {
  my $either = shift;
  %$either = () if ref $either;
  my $file = shift;
  return undef unless defined $file;

  # file must exist and be not empty!
  return undef unless -f $file && -s $file;

  my $self = { path_to_file => $file };
  $self -> {filename} = File::Basename::fileparse($file);
  # emule doesn't escape #[]@$&+,;=
  $self -> {escaped_filename} = uri_escape_utf8($self -> {filename}, '^A-Za-z0-9\-_.!~*\'()#&+,;=');
  # []@$
  $self -> {escaped_filename} =~ s/%5B/[/g;
  $self -> {escaped_filename} =~ s/%5D/]/g;
  $self -> {escaped_filename} =~ s/%40/\@/g;
  $self -> {escaped_filename} =~ s/%24/\$/g;
  $self -> {size} = -s $file;
  # hashes. step 1
  my @aich_tree;
  {
    my $base_blocks = sprintf("%d", $self -> {size} / CHANK_SIZE);
    $base_blocks-- if $self -> {size} == $base_blocks * CHANK_SIZE;
    &define_base_trees_orientation('l', \@aich_tree, 0, $base_blocks);
  }

  {
    open my $f, '<', $file or return undef;
    binmode $f;
    my ($t, $readed_bytes);
    my $md4 = Digest::MD4 -> new;
    while (defined($readed_bytes = read $f, $t, CHANK_SIZE)) {
      $md4 -> add($t);
      $self -> {hash} .= $md4 -> clone -> digest;
      push @{$self -> {p}}, uc $md4 -> hexdigest;
      if ($readed_bytes) {
	my $pos = 0;
	my @t_sha1;
	while ($pos < $readed_bytes) {
	  push @t_sha1, sha1(substr($t, $pos, BLOCK_SIZE));
	  $pos += BLOCK_SIZE;
	}
	# sha1 for chank
	&get_root_hash($aich_tree[$#{$self -> {p}}], \@t_sha1, 0, $#t_sha1);
	$aich_tree[$#{$self -> {p}}] = $t_sha1[0];
      }
      last if $readed_bytes != CHANK_SIZE;
    }
    close $f;
    return undef unless defined $readed_bytes
      && $self -> {size} == $#{$self -> {p}} * CHANK_SIZE + $readed_bytes;
  }

  # hashes. step 2
  if (@{$self -> {p}} == 1) {
    $self -> {hash} = $self -> {p}[0];
  } else {
    $self -> {hash} = uc md4_hex($self -> {hash});
  }
  # aich hashset
  &get_root_hash('l', \@aich_tree, 0, $#aich_tree);
  $self -> {aich} = encode_base32($aich_tree[0]);
  $self -> {reliable} = 1;

  if (ref $either) {
    %$either = %$self;
    1;
  } else {
    bless $self, $either;
  }
}

sub from_link {
  my $either = shift;
  %$either = () if ref $either;
  my $link = shift;
  return undef unless defined $link;
  return undef unless $link =~ m#^ed2k://\|file\|([\d\D]+?)\|(\d+)\|([\da-f]{32})\|#i;
  my $self;
  $self -> {escaped_filename} = $1;
  $self -> {filename} = uri_unescape($1);
  $self -> {size} = $2;
  $self -> {hash} = uc $3;
  $self -> {reliable} = 1;
  $link = "|$'";
  return undef unless $self -> {size};

  # complete hashset
  if ($link =~ m/\|p=([\d\D]*?)\|/) {
    my $t = uc $1;
    $link = "|$`$'";
    return undef unless $t =~ m/^([\dA-F]{32}(:[\dA-F]{32})*)$/;

    my @t = split ':', $1;
    $t = sprintf("%d", $self -> {size} / CHANK_SIZE);
    $t++ if $self -> {size} >= $t * CHANK_SIZE;
    return undef unless $t == @t;

    if (@t == 1) {
      return undef unless $self -> {hash} eq $t[0];
    } else {
      my $t = '';
      foreach my $bh (@t) {
	$t .= chr(hex($&)) while $bh =~ m/../g;
      }
      return undef unless $self -> {hash} eq uc md4_hex($t);
      $self -> {reliable} = 0;
    }
    $self -> {p} = \@t;
  }
  $self -> {p}[0] = $self -> {hash} if $self -> {size} < CHANK_SIZE && not exists $self -> {p};

  # aich
  if ($link =~ m/\|h=([\d\D]*?)\|/) {
    $self -> {aich} = uc $1;
    $link = "|$`$'";
    return undef unless $self -> {aich} =~ m/^[A-Z2-7]{32}$/;
    $self -> {reliable} = 0;
  }

  if (ref $either) {
    %$either = %$self;
    1;
  } else {
    bless $self, $either;
  }
}

sub ok {
  ref(my $instance = shift) or croak "class usage! need to be instance usage";
  return exists $instance -> {escaped_filename} && exists $instance -> {size} && exists $instance -> {hash};
}

sub filename {
  ref(my $instance = shift) or croak "class usage! need to be instance usage";
  $instance -> {filename};
}

sub escaped_filename {
  ref(my $instance = shift) or croak "class usage! need to be instance usage";
  $instance -> {escaped_filename};
}

sub filesize {
  ref(my $instance = shift) or croak "class usage! need to be instance usage";
  $instance -> {size};
}

sub hash {
  ref(my $instance = shift) or croak "class usage! need to be instance usage";
  $instance -> {hash};
}

sub has_complete_hashset {
  ref(my $instance = shift) or croak "class usage! need to be instance usage";
  exists $instance -> {p} && @{$instance -> {p}};
}

sub complete_hashset {
  ref(my $instance = shift) or croak "class usage! need to be instance usage";
  $instance -> has_complete_hashset ?
    join ':', @{$instance -> {p}}
      : undef;
}

sub has_aich {
  ref(my $instance = shift) or croak "class usage! need to be instance usage";
  exists $instance -> {aich};
}

sub aich {
  ref(my $instance = shift) or croak "class usage! need to be instance usage";
  $instance -> {aich};
}

sub link {
  ref(my $instance = shift) or croak "class usage! need to be instance usage";
  my $optional = shift;
  return undef unless $instance -> ok;
  my $res = 'ed2k://|file|'.$instance -> escaped_filename.'|'.$instance -> filesize.'|'.$instance -> hash.'|';
  if (defined $optional) {
    # complete hashset
    $res .= "p=" . $instance -> complete_hashset . '|'
      if $optional =~ /p/ && $instance -> filesize >= CHANK_SIZE && $instance -> has_complete_hashset;
    # aich hashset
    $res .= 'h=' . $instance -> aich . '|' if $optional =~ /h/ && $instance -> has_aich;
  }
  $res .= '/';
}

sub is_reliable {
  ref(my $instance = shift) or croak "class usage! need to be instance usage";
  $instance -> {reliable};
}

sub set_reliable {
  ref(my $instance = shift) or croak "class usage! need to be instance usage";
  $instance -> {reliable} = 1;
}

sub equal {
  my $class = shift;
  return undef unless @_ == 2;
  my $one = shift;
  my $two = shift;
  my $res = $one -> ok && $two -> ok && $one -> filesize == $two -> filesize && $one -> hash eq $two -> hash;
  return undef unless $res;
  $res = $one -> complete_hashset eq $two -> complete_hashset
    if $one -> has_complete_hashset && $two -> has_complete_hashset;
  return undef unless $res;
  $res = $one -> aich eq $two -> aich
    if $one -> has_aich && $two -> has_aich;
  return undef unless $res;

  # cases with copying complete hash or aich and setting reliable flag
  if ($one -> is_reliable && $two -> is_reliable) {
    if ($one -> has_complete_hashset && !$two -> has_complete_hashset) {
      $two -> {p} = $one -> {p};
    } elsif (!$one -> has_complete_hashset && $two -> has_complete_hashset) {
      $one -> {p} = $two -> {p};
    }
    if ($one -> has_aich && !$two -> has_aich) {
      $two -> {aich} = $one -> {aich};
    } elsif (!$one -> has_aich && $two -> has_aich) {
      $one -> {aich} = $two -> {aich};
    }
  } elsif ($one -> is_reliable) {
    my $t = 0;
    if ($one -> has_complete_hashset) {
      $t++;
      $two -> {p} = $one -> {p};
    }
    if ($one -> has_aich) {
      $t++;
      $two -> {aich} = $one -> {aich};
    }
    $t-- if $two -> has_complete_hashset;
    $t-- if $two -> has_aich;
    $two -> set_reliable if $t >= 0;
  } elsif ($two -> is_reliable) {
    my $t = 0;
    if ($two -> has_complete_hashset) {
      $t++;
      $one -> {p} = $two -> {p};
    }
    if ($two -> has_aich) {
      $t++;
      $one -> {aich} = $two -> {aich};
    }
    $t-- if $one -> has_complete_hashset;
    $t-- if $one -> has_aich;
    $one -> set_reliable if $t >= 0;
  }

  $res;
}

1;
__END__